MPOOps

Fortran module MPOOps: May 2017 (dj, udpated)

The matrix product operators (MPO) represent the Hamiltonian of the system. Its basic subroutines are defined in this module.

Authors

• 4. Jaschke

• 13. 12. Wall

MPOOps_f90.copy_hamiltonianparameters()

fortran-subroutine - August 2017 (dj, updated) Copy the TYPE(HamiltonianParameters) from source Objin to Objout. Recall indices start at zero.

Arguments

ObjoutTYPE(HamiltonianParameters)(*), inout

Target of copy.

ObjinTYPE(HamiltonianParameters)(*), in

Source of copy.

Source Code

show / hide f90 code

  subroutine copy_hamiltonianparameters(Objout, Objin)
      type(HamiltonianParameters), pointer, intent(inout) :: Objout(:)
      type(HamiltonianParameters), pointer, intent(in) :: Objin(:)

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

      ! for looping
      integer :: ii

      ! number of parameters
      INTEGER :: nparams

      nparams = ubound(Objin, 1)
      allocate(Objout(0:nparams))

      ! Identity hamiltonian parameter
      Objout(0)%ti = .true.
      Objout(0)%s = 1.0_rKind

      do ii = 1, nparams
          Objout(ii)%ti = Objin(ii)%ti

          if(Objout(ii)%ti) then
              Objout(ii)%s = Objin(ii)%s
          else
              allocate(Objout(ii)%d(size(Objin(ii)%d, 1)))
              Objout(ii)%d = Objin(ii)%d
          end if
      end do

  end subroutine copy_hamiltonianparameters

MPOOps_f90.read_hamiltonianparameters()

fortran-subroutine - August 2017 (dj, updated) Read/initialize the Hamiltonian parameters. (The corresponding python function should be WriteHparams in the module tools.py.)

Arguments

HparamsTYPE(HamiltonianParameters)(*), inout

to be filled with the Hamiltonian parameters for a simulation/model The array runs from zero.

filestubCHARACTER(*), in

filename

unitINTEGER, in

Open file on this unit.

Source Code

show / hide f90 code

  subroutine read_hamiltonianparameters(Hparams, filestub, unit)
      type(HamiltonianParameters), pointer, intent(inout) :: Hparams(:)
      character(len=*), intent(in) :: filestub
      integer, intent(in) :: unit

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

      ! for looping
      integer :: ii

      ! number of parameters
      integer :: nparams

      ! number of elements in the space dependent coupling
      integer :: nelems

      ! to build string formatter
      character(16) :: iwstring, specstring

      open(unit, file=trim(adjustl(filestub)), action='read', status='old')

      read(unit, '(1I16)') nparams
      allocate(Hparams(0:nparams))

      ! Identity hamiltonian parameter
      Hparams(0)%ti = .true. 
      Hparams(0)%s = 1.0_rKind

      do ii = 1, nparams
          read(unit, '(1I16)') nelems

          if(nelems == 1) then
              Hparams(ii)%ti = .true.
              read(unit, '(1E30.15)') Hparams(ii)%s
          else
              Hparams(ii)%ti = .false.
              allocate(Hparams(ii)%d(nelems))
              write(iwstring, '(I4)') nelems
              specString = "("//trim(adjustl(iwstring))//"E30.15)"
              read(unit, specstring) Hparams(ii)%d
          end if
      end do

      close(unit) 

  end subroutine read_hamiltonianparameters

MPOOps_f90.update_hamiltonianparameter()

fortran-subroutine - August 2017 (dj, updated) Read/Update the Hamiltonian parameters, e.g. for time-dependent evolutions. (The corresponding python function should be WriteDynamics in the module Dynamics.)

Arguments

HparamsTYPE(HamiltoniansParameters), POINTER, in

contains the Hamiltonian parameters

fileidINTEGER, in

This file-unit is open to read the parameters.

whichHparamsINTEGER(*), in

list of indices to update in Hparams

Source Code

show / hide f90 code

  subroutine update_hamiltonianparameter(Hparams, fileid, whichhparams)
      TYPE(HamiltonianParameters), pointer, intent(inout) :: Hparams(:)
      integer, intent(in) :: fileid, whichhparams(:)

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

      ! for looping
      integer :: ii

      ! for building string formatter
      character(16) :: iwstring, specstring

      do ii = 1, size(whichhparams, 1)
          if(Hparams(whichhparams(ii))%ti) then
              read(fileid, "(1E30.15)") Hparams(whichhparams(ii))%s
          else
              write(iwstring, '(I4)') size(Hparams(whichhparams(ii))%d, 1)
              specstring = "("//trim(adjustl(iwstring))//"E30.15)"
              read(fileid, specstring) Hparams(whichhparams(ii))%d
          end if
      end do

  end subroutine update_hamiltonianparameter

MPOOps_f90.destroy_hamiltonianparameters()

fortran-subroutine - August 2017 (dj, updated) Delete/deallocate all the Hamiltonian parameters.

Arguments

HparamsTYPE(HamiltonianParameters)(*), inout

Hamiltonian parameters to be deleted

filestubCHARACTER(*), in

filename.

unitINTEGER, in

Available unit to open file for deleting.

clearfileLOGICAL, OPTIONAL, in

.TRUE. : delete .dat-file as well .FALSE. : leave .dat-file on hard disk (default)

Source Code

show / hide f90 code

  subroutine destroy_hamiltonianparameters(Hparams, filestub, unit, clearfile)
      type(hamiltonianparameters), pointer, intent(inout) :: Hparams(:)
      character(len=*), intent(in) :: filestub
      integer, intent(in) :: unit
      logical, intent(in), optional :: clearfile

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

      ! for looping
      integer :: ii

      if(present(clearfile)) then
          if(clearfile) call delete_file(filestub, unit)
      end if

      do ii = 1, ubound(Hparams, 1)
          if(.not. Hparams(ii)%ti) then
              deallocate(Hparams(ii)%d)
          end if
      end do

      deallocate(Hparams)

  end subroutine destroy_hamiltonianparameters

MPOOps_f90.ReadOperators_tensorlist()

fortran-subroutine - August 2017 (dj, updated) Read Operators from the Python input file

Arguments

filestubCHARACTER(*), inout

filename containing operators.

OperatorsTYPE(tensorlist), inout

List of operators to be filled during the subroutine.

Details

(template defined in MPOOps_include.f90)

Source Code

show / hide f90 code

  subroutine ReadOperators_tensorlist(Operators, iop, filestub, opsunit, &
                                           Imapper, nqs, errst)
      type(tensorlist), intent(inout) :: Operators
      integer, intent(out) :: iop
      character(len=*) :: filestub
      integer, intent(in) :: opsunit
      type(imap), intent(inout) :: Imapper
      integer, dimension(2), intent(in) :: nqs
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: kk

      ! Number of operators and dimension
      integer :: nops, dl, dr

      ! For building the string formatter
      character(16) :: iwstring, specstring

      !if(present(errst)) errst = 0

      open(unit=opsunit, file=trim(adjustl(filestub)), action='read', &
           status='old')

      read(opsunit, '(3I16)') nops, dl, dr
      allocate(Operators%Li(nops))

      write(iwstring, '(I4)') dl * dr * 1
      specString = "("//trim(adjustl(iwstring))//"E30.15)"

      do kk = 1, nops
          call create(Operators%Li(kk), [dl, dr])

          ! Read and transpose due to different memory order py vs f90
          read(opsunit, specstring) Operators%Li(kk)%elem
          call transposed(Operators%Li(kk), doperm=.true.)
      end do

      read(opsunit, '(1I16)') iop
      close(opsunit)

  end subroutine ReadOperators_tensorlist

MPOOps_f90.ReadOperators_tensorlistc()

fortran-subroutine - August 2017 (dj, updated) Read Operators from the Python input file

Arguments

filestubCHARACTER(*), inout

filename containing operators.

OperatorsTYPE(tensorlistc), inout

List of operators to be filled during the subroutine.

Details

(template defined in MPOOps_include.f90)

Source Code

show / hide f90 code

  subroutine ReadOperators_tensorlistc(Operators, iop, filestub, opsunit, &
                                           Imapper, nqs, errst)
      type(tensorlistc), intent(inout) :: Operators
      integer, intent(out) :: iop
      character(len=*) :: filestub
      integer, intent(in) :: opsunit
      type(imap), intent(inout) :: Imapper
      integer, dimension(2), intent(in) :: nqs
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: kk

      ! Number of operators and dimension
      integer :: nops, dl, dr

      ! For building the string formatter
      character(16) :: iwstring, specstring

      !if(present(errst)) errst = 0

      open(unit=opsunit, file=trim(adjustl(filestub)), action='read', &
           status='old')

      read(opsunit, '(3I16)') nops, dl, dr
      allocate(Operators%Li(nops))

      write(iwstring, '(I4)') dl * dr * 2
      specString = "("//trim(adjustl(iwstring))//"E30.15)"

      do kk = 1, nops
          call create(Operators%Li(kk), [dl, dr])

          ! Read and transpose due to different memory order py vs f90
          read(opsunit, specstring) Operators%Li(kk)%elem
          call transposed(Operators%Li(kk), doperm=.true.)
      end do

      read(opsunit, '(1I16)') iop
      close(opsunit)

  end subroutine ReadOperators_tensorlistc

MPOOps_f90.ReadOperators_qtensorlist()

fortran-subroutine - August 2017 (dj, updated) Read Operators from the Python input file.

Arguments

fileStubCHARACTER(*), inout

filename containing the operators.

OperatorsTYPE(qtensorlist), inout

List with operators is filled according the input file fileStub generated of the python front-end.

nqsINTEGER, in

Number of conserved quantities / symmetries in the definition of the operators.

Source Code

show / hide f90 code

  subroutine ReadOperators_qtensorlist(Operators, iop, filestub, opsunit, &
                                           Imapper, nqs, errst)
      type(qtensorlist), intent(inout) :: Operators
      integer, intent(inout) :: iop
      character(len=*), intent(in) :: fileStub
      integer, intent(in) :: opsunit
      type(imap), intent(inout) :: Imapper
      integer, dimension(2), intent(in) :: nqs
      integer, intent(out), optional :: errst

      ! For looping
      integer :: jj, kk

      ! number of operators and their dimension
      integer :: nops, dl, dr

      ! sum of U(1) and Z_2 quantum numbers
      integer :: snqs

      ! number of tuples / blocks in the block-diagonal matrix
      integer :: ntuples

      ! size of blocks
      integer :: dsiz

      ! for contructing string formatter
      character(16) :: iwstring, specstring

      !if(present(errst)) errst = 0
      snqs = sum(nqs)

      open(unit=opsunit, file=trim(adjustl(filestub)), action='read', &
           status='old')

      ! number of operators (number of quantum numbers is in system settings)
      read(opsunit, '(I16)') nops

      allocate(Operators%Li(nOps))

      do kk = 1, nops 
          read(opsunit, '(1I16)') ntuples
          call create(Operators%Li(kk), nqs, ntuples)
          Operators%Li(kk)%nb = ntuples

          do jj = 1, ntuples
              ! Get index tuples (Note that these are sorted in ascending
              ! order by convention)
              write(iwstring, '(I4)') 2 * snqs
              specstring = "("//trim(adjustl(iwstring))//"I16)"

              allocate(Operators%Li(kk)%Data(ntuples + 1 -jj)%qq(2 * snqs))
              read(opsunit, specstring) &
                   Operators%Li(kk)%Data(ntuples + 1 -jj)%qq

              ! Definition of qmatrix canonical form requires right-hashing
              call set_hash(Operators%Li(kk), [2], (ntuples + 1 - jj))

              ! Get degeneracy dimensions
              read(opsunit, '(2I16)') dl, dr
              call create(Operators%Li(kk)%Data(ntuples + 1 - jj)%Tens, &
                          [dl, dr])

              ! get block matrix (transpose for memory order py vs f90)
              write(iwstring, '(I4)') dl * dr * 1
              specstring = "("//trim(adjustl(iwstring))//"E30.15)"
              read(opsunit, specstring) &
                   Operators%Li(kk)%Data(ntuples + 1 - jj)%Tens%elem
              call transposed(Operators%Li(kk)%Data(ntuples + 1 - jj)%Tens, &
                             doperm=.true.)
          end do
      end do

      read(opsunit, '(1I16)') iop
      close(opsunit)

      ! Built the mapping
      ! .................

      allocate(Imapper%start(Operators%Li(iop)%nb), &
               Imapper%dd(Operators%Li(iop)%nb), &
               Imapper%hashes(Operators%li(iop)%nb))
      imapper%start = 1

      do kk = 1, Operators%Li(iop)%nb
          dsiz = Operators%Li(iop)%Data(kk)%Tens%dl(1)
          Imapper%dd(kk) = dsiz - 1
          Imapper%hashes(kk) = Operators%Li(iop)%hash(kk)

          if(kk /= Operators%Li(iop)%nb) then
              Imapper%start(kk + 1) = Imapper%start(kk) + dsiz
          end if
      end do

      Imapper%totald = 0
      do kk = 1, size(Imapper%dd)
          Imapper%totald = Imapper%totald + Imapper%dd(kk) + 1
      end do

  end subroutine ReadOperators_qtensorlist

MPOOps_f90.ReadOperators_qtensorclist()

fortran-subroutine - August 2017 (dj, updated) Read Operators from the Python input file.

Arguments

fileStubCHARACTER(*), inout

filename containing the operators.

OperatorsTYPE(qtensorclist), inout

List with operators is filled according the input file fileStub generated of the python front-end.

nqsINTEGER, in

Number of conserved quantities / symmetries in the definition of the operators.

Source Code

show / hide f90 code

  subroutine ReadOperators_qtensorclist(Operators, iop, filestub, opsunit, &
                                           Imapper, nqs, errst)
      type(qtensorclist), intent(inout) :: Operators
      integer, intent(inout) :: iop
      character(len=*), intent(in) :: fileStub
      integer, intent(in) :: opsunit
      type(imap), intent(inout) :: Imapper
      integer, dimension(2), intent(in) :: nqs
      integer, intent(out), optional :: errst

      ! For looping
      integer :: jj, kk

      ! number of operators and their dimension
      integer :: nops, dl, dr

      ! sum of U(1) and Z_2 quantum numbers
      integer :: snqs

      ! number of tuples / blocks in the block-diagonal matrix
      integer :: ntuples

      ! size of blocks
      integer :: dsiz

      ! for contructing string formatter
      character(16) :: iwstring, specstring

      !if(present(errst)) errst = 0
      snqs = sum(nqs)

      open(unit=opsunit, file=trim(adjustl(filestub)), action='read', &
           status='old')

      ! number of operators (number of quantum numbers is in system settings)
      read(opsunit, '(I16)') nops

      allocate(Operators%Li(nOps))

      do kk = 1, nops 
          read(opsunit, '(1I16)') ntuples
          call create(Operators%Li(kk), nqs, ntuples)
          Operators%Li(kk)%nb = ntuples

          do jj = 1, ntuples
              ! Get index tuples (Note that these are sorted in ascending
              ! order by convention)
              write(iwstring, '(I4)') 2 * snqs
              specstring = "("//trim(adjustl(iwstring))//"I16)"

              allocate(Operators%Li(kk)%Data(ntuples + 1 -jj)%qq(2 * snqs))
              read(opsunit, specstring) &
                   Operators%Li(kk)%Data(ntuples + 1 -jj)%qq

              ! Definition of qmatrix canonical form requires right-hashing
              call set_hash(Operators%Li(kk), [2], (ntuples + 1 - jj))

              ! Get degeneracy dimensions
              read(opsunit, '(2I16)') dl, dr
              call create(Operators%Li(kk)%Data(ntuples + 1 - jj)%Tens, &
                          [dl, dr])

              ! get block matrix (transpose for memory order py vs f90)
              write(iwstring, '(I4)') dl * dr * 2
              specstring = "("//trim(adjustl(iwstring))//"E30.15)"
              read(opsunit, specstring) &
                   Operators%Li(kk)%Data(ntuples + 1 - jj)%Tens%elem
              call transposed(Operators%Li(kk)%Data(ntuples + 1 - jj)%Tens, &
                             doperm=.true.)
          end do
      end do

      read(opsunit, '(1I16)') iop
      close(opsunit)

      ! Built the mapping
      ! .................

      allocate(Imapper%start(Operators%Li(iop)%nb), &
               Imapper%dd(Operators%Li(iop)%nb), &
               Imapper%hashes(Operators%li(iop)%nb))
      imapper%start = 1

      do kk = 1, Operators%Li(iop)%nb
          dsiz = Operators%Li(iop)%Data(kk)%Tens%dl(1)
          Imapper%dd(kk) = dsiz - 1
          Imapper%hashes(kk) = Operators%Li(iop)%hash(kk)

          if(kk /= Operators%Li(iop)%nb) then
              Imapper%start(kk + 1) = Imapper%start(kk) + dsiz
          end if
      end do

      Imapper%totald = 0
      do kk = 1, size(Imapper%dd)
          Imapper%totald = Imapper%totald + Imapper%dd(kk) + 1
      end do

  end subroutine ReadOperators_qtensorclist

MPOOps_f90.DeallocateOperators_tensorlist()

fortran-subroutine - August 2017 (dj, updated) Deallocate the operators used by the Python interface.

Arguments

fileStubCHARACTER(*), inout

Filename. This is only used when deleting the file.

OperatorsTYPE(tensorlist), inout

Contains the operator alphabet for the simulation which is deleted during this subroutine

clearfileLOGICAL, OPTIONAL, in

T : delete input file for operators as well F : keep input file and only delete matrix list Default if not given: F

Source Code

show / hide f90 code

  subroutine DeallocateOperators_tensorlist(Operators, filestub, &
                                                 opsunit, clearfile)
      type(tensorlist), intent(inout) :: Operators
      character(len=*), intent(in) :: fileStub
      integer, intent(in) :: opsunit
      logical, intent(in), optional :: clearfile

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


      if(present(clearfile)) then
          if(clearfile) then
              open(unit=opsunit, file=trim(adjustl(filestub)), &
                   action='read', status='old')
              close(opsunit, status='delete')
          end if
      end if

      call destroy(Operators)

  end subroutine DeallocateOperators_tensorlist

MPOOps_f90.DeallocateOperators_tensorlistc()

fortran-subroutine - August 2017 (dj, updated) Deallocate the operators used by the Python interface.

Arguments

fileStubCHARACTER(*), inout

Filename. This is only used when deleting the file.

OperatorsTYPE(tensorlistc), inout

Contains the operator alphabet for the simulation which is deleted during this subroutine

clearfileLOGICAL, OPTIONAL, in

T : delete input file for operators as well F : keep input file and only delete matrix list Default if not given: F

Source Code

show / hide f90 code

  subroutine DeallocateOperators_tensorlistc(Operators, filestub, &
                                                 opsunit, clearfile)
      type(tensorlistc), intent(inout) :: Operators
      character(len=*), intent(in) :: fileStub
      integer, intent(in) :: opsunit
      logical, intent(in), optional :: clearfile

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


      if(present(clearfile)) then
          if(clearfile) then
              open(unit=opsunit, file=trim(adjustl(filestub)), &
                   action='read', status='old')
              close(opsunit, status='delete')
          end if
      end if

      call destroy(Operators)

  end subroutine DeallocateOperators_tensorlistc

MPOOps_f90.DeallocateOperators_qtensorlist()

fortran-subroutine - August 2017 (dj, updated) Deallocate the operators used by the Python interface.

Arguments

fileStubCHARACTER(*), inout

Filename. This is only used when deleting the file.

OperatorsTYPE(qtensorlist), inout

Contains the operator alphabet for the simulation which is deleted during this subroutine

clearfileLOGICAL, OPTIONAL, in

T : delete input file for operators as well F : keep input file and only delete matrix list Default if not given: F

Source Code

show / hide f90 code

  subroutine DeallocateOperators_qtensorlist(Operators, filestub, &
                                                 opsunit, clearfile)
      type(qtensorlist), intent(inout) :: Operators
      character(len=*), intent(in) :: fileStub
      integer, intent(in) :: opsunit
      logical, intent(in), optional :: clearfile

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


      if(present(clearfile)) then
          if(clearfile) then
              open(unit=opsunit, file=trim(adjustl(filestub)), &
                   action='read', status='old')
              close(opsunit, status='delete')
          end if
      end if

      call destroy(Operators)

  end subroutine DeallocateOperators_qtensorlist

MPOOps_f90.DeallocateOperators_qtensorclist()

fortran-subroutine - August 2017 (dj, updated) Deallocate the operators used by the Python interface.

Arguments

fileStubCHARACTER(*), inout

Filename. This is only used when deleting the file.

OperatorsTYPE(qtensorclist), inout

Contains the operator alphabet for the simulation which is deleted during this subroutine

clearfileLOGICAL, OPTIONAL, in

T : delete input file for operators as well F : keep input file and only delete matrix list Default if not given: F

Source Code

show / hide f90 code

  subroutine DeallocateOperators_qtensorclist(Operators, filestub, &
                                                 opsunit, clearfile)
      type(qtensorclist), intent(inout) :: Operators
      character(len=*), intent(in) :: fileStub
      integer, intent(in) :: opsunit
      logical, intent(in), optional :: clearfile

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


      if(present(clearfile)) then
          if(clearfile) then
              open(unit=opsunit, file=trim(adjustl(filestub)), &
                   action='read', status='old')
              close(opsunit, status='delete')
          end if
      end if

      call destroy(Operators)

  end subroutine DeallocateOperators_qtensorclist

MPOOps_f90.has_lindblads()

fortran-function - August 2017 (dj) Check if a rule set has any Lindblad terms in it.

Arguments

RsTYPE(MPORuleSet), in

Check this rule set for Lindblad terms.

Source Code

show / hide f90 code

  function has_lindblads(Rs) result(res)
      type(MPORuleSet), intent(in) :: Rs
      logical :: res

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

      ! overall number of Lindblad terms
      integer :: nl

      nl = Rs%nlxx + Rs%nmbsl + Rs%nlexp + Rs%nmbslxy

      res = (nl > 0)

  end function has_lindblads

MPOOps_f90.get_coupl()

fortran-function - May 2017 (dj) Extract the coupling.

Arguments

HparamsTYPE(HamiltonianParameters), in

Contains the coupling for the each parameters in the Hamiltonian.

idxINTEGER, in

Position of the parameter in the list.

xxINTEGER, in

Site index in case the coupling is site dependent.

Source Code

show / hide f90 code

  function get_coupl(Hparams, idx, xx) result(coupl)
      type(HamiltonianParameters), intent(in), pointer :: Hparams(:)
      integer, intent(in) :: idx, xx
      real(KIND=rKIND) :: coupl

      ! Local variables

      if(Hparams(idx)%ti) then
          coupl = Hparams(idx)%s
      else
          coupl = Hparams(idx)%d(xx)
      end if

  end function get_coupl

MPOOps_f90.fuse_sparse_row_tensor()

fortran-subroutine - September 2017 (dj) Fuse the operators from a rank-4 to a rank-2 tensor.

Arguments

RowTYPE(sparse_row_tensor), inout

The row of a sparse matrix. The operators are reduced from rank-4 to rank-2 on exit.

Source Code

show / hide f90 code

  subroutine fuse_sparse_row_tensor(Row, errst)
      type(sparse_row_tensor), intent(inout) :: Row
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! indices for fusing
      integer, dimension(2, 2) :: fidx

      !if(present(errst)) errst = 0

      fidx = reshape([1, 2, 3, 4], [2, 2])

      do ii = 1, Row%numel
          call fuse(Row%Op(ii), fidx, '0', errst=errst)
          !if(prop_error('fuse_sparse_row_tensor : fuse '//&
          !              'failed.', 'MPOOps_include.f90:1183', errst=errst)) return
      end do

  end subroutine fuse_sparse_row_tensor

MPOOps_f90.fuse_sparse_row_tensorc()

fortran-subroutine - September 2017 (dj) Fuse the operators from a rank-4 to a rank-2 tensor.

Arguments

RowTYPE(sparse_row_tensorc), inout

The row of a sparse matrix. The operators are reduced from rank-4 to rank-2 on exit.

Source Code

show / hide f90 code

  subroutine fuse_sparse_row_tensorc(Row, errst)
      type(sparse_row_tensorc), intent(inout) :: Row
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! indices for fusing
      integer, dimension(2, 2) :: fidx

      !if(present(errst)) errst = 0

      fidx = reshape([1, 2, 3, 4], [2, 2])

      do ii = 1, Row%numel
          call fuse(Row%Op(ii), fidx, '0', errst=errst)
          !if(prop_error('fuse_sparse_row_tensorc : fuse '//&
          !              'failed.', 'MPOOps_include.f90:1183', errst=errst)) return
      end do

  end subroutine fuse_sparse_row_tensorc

MPOOps_f90.fuse_sparse_row_qtensor()

fortran-subroutine - September 2017 (dj) Fuse the operators from a rank-4 to a rank-2 tensor.

Arguments

RowTYPE(sparse_row_qtensor), inout

The row of a sparse matrix. The operators are reduced from rank-4 to rank-2 on exit.

Source Code

show / hide f90 code

  subroutine fuse_sparse_row_qtensor(Row, errst)
      type(sparse_row_qtensor), intent(inout) :: Row
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! indices for fusing
      integer, dimension(2, 2) :: fidx

      !if(present(errst)) errst = 0

      fidx = reshape([1, 2, 3, 4], [2, 2])

      do ii = 1, Row%numel
          call fuse(Row%Op(ii), fidx, '0', errst=errst)
          !if(prop_error('fuse_sparse_row_qtensor : fuse '//&
          !              'failed.', 'MPOOps_include.f90:1183', errst=errst)) return
      end do

  end subroutine fuse_sparse_row_qtensor

MPOOps_f90.fuse_sparse_row_qtensorc()

fortran-subroutine - September 2017 (dj) Fuse the operators from a rank-4 to a rank-2 tensor.

Arguments

RowTYPE(sparse_row_qtensorc), inout

The row of a sparse matrix. The operators are reduced from rank-4 to rank-2 on exit.

Source Code

show / hide f90 code

  subroutine fuse_sparse_row_qtensorc(Row, errst)
      type(sparse_row_qtensorc), intent(inout) :: Row
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! indices for fusing
      integer, dimension(2, 2) :: fidx

      !if(present(errst)) errst = 0

      fidx = reshape([1, 2, 3, 4], [2, 2])

      do ii = 1, Row%numel
          call fuse(Row%Op(ii), fidx, '0', errst=errst)
          !if(prop_error('fuse_sparse_row_qtensorc : fuse '//&
          !              'failed.', 'MPOOps_include.f90:1183', errst=errst)) return
      end do

  end subroutine fuse_sparse_row_qtensorc

MPOOps_f90.fuse_sr_matrix_tensor()

fortran-subroutine - September 2017 (dj) Fuse the operators from a rank-4 to a rank-2 tensor.

Arguments

MatTYPE(sr_matrix_tensor), inout

A sparse matrix. The operators are reduced from rank-4 to rank-2 on exit.

Source Code

show / hide f90 code

  subroutine fuse_sr_matrix_tensor(Mat, errst)
      type(sr_matrix_tensor), intent(inout) :: Mat
      integer, intent(out), optional :: errst

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

      ! for lopping
      integer :: ii

      !if(present(errst)) errst = 0

      do ii = 1, Mat%rbd
          call fuse(Mat%Row(ii), errst=errst)
          !if(prop_error('fuse_sr_matrix_tensor : fuse failed.', &
          !              errst=errst)) return
      end do

  end subroutine fuse_sr_matrix_tensor

MPOOps_f90.fuse_sr_matrix_tensorc()

fortran-subroutine - September 2017 (dj) Fuse the operators from a rank-4 to a rank-2 tensor.

Arguments

MatTYPE(sr_matrix_tensorc), inout

A sparse matrix. The operators are reduced from rank-4 to rank-2 on exit.

Source Code

show / hide f90 code

  subroutine fuse_sr_matrix_tensorc(Mat, errst)
      type(sr_matrix_tensorc), intent(inout) :: Mat
      integer, intent(out), optional :: errst

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

      ! for lopping
      integer :: ii

      !if(present(errst)) errst = 0

      do ii = 1, Mat%rbd
          call fuse(Mat%Row(ii), errst=errst)
          !if(prop_error('fuse_sr_matrix_tensorc : fuse failed.', &
          !              errst=errst)) return
      end do

  end subroutine fuse_sr_matrix_tensorc

MPOOps_f90.fuse_sr_matrix_qtensor()

fortran-subroutine - September 2017 (dj) Fuse the operators from a rank-4 to a rank-2 tensor.

Arguments

MatTYPE(sr_matrix_qtensor), inout

A sparse matrix. The operators are reduced from rank-4 to rank-2 on exit.

Source Code

show / hide f90 code

  subroutine fuse_sr_matrix_qtensor(Mat, errst)
      type(sr_matrix_qtensor), intent(inout) :: Mat
      integer, intent(out), optional :: errst

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

      ! for lopping
      integer :: ii

      !if(present(errst)) errst = 0

      do ii = 1, Mat%rbd
          call fuse(Mat%Row(ii), errst=errst)
          !if(prop_error('fuse_sr_matrix_qtensor : fuse failed.', &
          !              errst=errst)) return
      end do

  end subroutine fuse_sr_matrix_qtensor

MPOOps_f90.fuse_sr_matrix_qtensorc()

fortran-subroutine - September 2017 (dj) Fuse the operators from a rank-4 to a rank-2 tensor.

Arguments

MatTYPE(sr_matrix_qtensorc), inout

A sparse matrix. The operators are reduced from rank-4 to rank-2 on exit.

Source Code

show / hide f90 code

  subroutine fuse_sr_matrix_qtensorc(Mat, errst)
      type(sr_matrix_qtensorc), intent(inout) :: Mat
      integer, intent(out), optional :: errst

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

      ! for lopping
      integer :: ii

      !if(present(errst)) errst = 0

      do ii = 1, Mat%rbd
          call fuse(Mat%Row(ii), errst=errst)
          !if(prop_error('fuse_sr_matrix_qtensorc : fuse failed.', &
          !              errst=errst)) return
      end do

  end subroutine fuse_sr_matrix_qtensorc

MPOOps_f90.sdot_sr_matrix_tensor()

fortran-subroutine - May 2017 (dj) Dot product / matrix-matrix multiplication between to sparse matrices.

Arguments

MatcTYPE(sr_matrix_tensor), inout

The outcome of the matrix-matrix multiplication. The entries are combined with the outer product or Kronecker product leading to rank-4 tensors.

MataTYPE(sr_matrix_tensor), in

The left sparse matrix in the matrix-matrix multiplications.

MatbTYPE(sr_matrix_tensor), in

The left sparse matrix in the matrix-matrix multiplications.

Source Code

show / hide f90 code

  subroutine sdot_sr_matrix_tensor(Matc, Mata, Matb)
      type(sr_matrix_tensor), intent(inout) :: Matc
      type(sr_matrix_tensor), intent(in) :: Mata, Matb

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

      ! for looping
      integer :: ii, jj, kk

      ! actual index for jj, kk
      integer :: indj, indk

      ! index in Matc
      integer :: idx

      ! number of elements in a row of Matc
      integer :: numel

      ! table for entries in Matb, serves as backmap
      integer, dimension(:, :), allocatable :: bjk

      ! logical to catch first entry
      logical :: first

      ! Get all entries of Matb
      allocate(bjk(Matb%rbd, Matb%cbd))
      bjk = 0

      do jj = 1, Matb%rbd
          do kk = 1, Matb%Row(jj)%numel
              bjk(jj, Matb%Row(jj)%ind(kk)) = kk
          end do
      end do

      ! Start multiplication
      ! --------------------

      Matc%rbd = Mata%rbd
      Matc%cbd = Matb%cbd
      allocate(Matc%Row(Matc%rbd))

      do ii = 1, Matc%rbd

          ! Find number of elements in each row
          numel = 0
          do kk = 1, Matb%cbd
              first = .true.

              do jj = 1, Mata%Row(ii)%numel
                  if(bjk(Mata%Row(ii)%ind(jj), kk) > 0) then
                      if(first) then
                          numel = numel + 1
                          first = .false.
                      end if
                  end if
              end do
          end do

          Matc%Row(ii)%numel = numel
          allocate(Matc%Row(ii)%ind(numel), Matc%Row(ii)%Op(numel))

          ! Carry out multiplication with outer product
          idx = 0

          do kk = 1, Matb%cbd
              ! This are entries in Matc(ii, kk)
              first = .true.

              do jj = 1, Mata%Row(ii)%numel
                  indj = Mata%Row(ii)%ind(jj)

                  if(bjk(indj, kk) > 0) then
                      indk = bjk(indj, kk)

                      if(first) then
                          first = .false.
                          idx = idx + 1
                          Matc%Row(ii)%ind(idx) = kk

                          call kron(Matc%Row(ii)%Op(idx), &
                                    Mata%Row(ii)%Op(jj), &
                                    Matb%Row(indj)%Op(indk), &
                                    1, 1, 'N', 'N', op='N')

                      else
                          call kron(Matc%Row(ii)%Op(idx), &
                                    Mata%Row(ii)%Op(jj), &
                                    Matb%Row(indj)%Op(indk), &
                                    1, 1, 'N', 'N', op='+')
                      end if
                  end if
              end do
          end do
      end do

      deallocate(bjk)

  end subroutine sdot_sr_matrix_tensor

MPOOps_f90.sdot_sr_matrix_tensorc()

fortran-subroutine - May 2017 (dj) Dot product / matrix-matrix multiplication between to sparse matrices.

Arguments

MatcTYPE(sr_matrix_tensorc), inout

The outcome of the matrix-matrix multiplication. The entries are combined with the outer product or Kronecker product leading to rank-4 tensors.

MataTYPE(sr_matrix_tensorc), in

The left sparse matrix in the matrix-matrix multiplications.

MatbTYPE(sr_matrix_tensorc), in

The left sparse matrix in the matrix-matrix multiplications.

Source Code

show / hide f90 code

  subroutine sdot_sr_matrix_tensorc(Matc, Mata, Matb)
      type(sr_matrix_tensorc), intent(inout) :: Matc
      type(sr_matrix_tensorc), intent(in) :: Mata, Matb

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

      ! for looping
      integer :: ii, jj, kk

      ! actual index for jj, kk
      integer :: indj, indk

      ! index in Matc
      integer :: idx

      ! number of elements in a row of Matc
      integer :: numel

      ! table for entries in Matb, serves as backmap
      integer, dimension(:, :), allocatable :: bjk

      ! logical to catch first entry
      logical :: first

      ! Get all entries of Matb
      allocate(bjk(Matb%rbd, Matb%cbd))
      bjk = 0

      do jj = 1, Matb%rbd
          do kk = 1, Matb%Row(jj)%numel
              bjk(jj, Matb%Row(jj)%ind(kk)) = kk
          end do
      end do

      ! Start multiplication
      ! --------------------

      Matc%rbd = Mata%rbd
      Matc%cbd = Matb%cbd
      allocate(Matc%Row(Matc%rbd))

      do ii = 1, Matc%rbd

          ! Find number of elements in each row
          numel = 0
          do kk = 1, Matb%cbd
              first = .true.

              do jj = 1, Mata%Row(ii)%numel
                  if(bjk(Mata%Row(ii)%ind(jj), kk) > 0) then
                      if(first) then
                          numel = numel + 1
                          first = .false.
                      end if
                  end if
              end do
          end do

          Matc%Row(ii)%numel = numel
          allocate(Matc%Row(ii)%ind(numel), Matc%Row(ii)%Op(numel))

          ! Carry out multiplication with outer product
          idx = 0

          do kk = 1, Matb%cbd
              ! This are entries in Matc(ii, kk)
              first = .true.

              do jj = 1, Mata%Row(ii)%numel
                  indj = Mata%Row(ii)%ind(jj)

                  if(bjk(indj, kk) > 0) then
                      indk = bjk(indj, kk)

                      if(first) then
                          first = .false.
                          idx = idx + 1
                          Matc%Row(ii)%ind(idx) = kk

                          call kron(Matc%Row(ii)%Op(idx), &
                                    Mata%Row(ii)%Op(jj), &
                                    Matb%Row(indj)%Op(indk), &
                                    1, 1, 'N', 'N', op='N')

                      else
                          call kron(Matc%Row(ii)%Op(idx), &
                                    Mata%Row(ii)%Op(jj), &
                                    Matb%Row(indj)%Op(indk), &
                                    1, 1, 'N', 'N', op='+')
                      end if
                  end if
              end do
          end do
      end do

      deallocate(bjk)

  end subroutine sdot_sr_matrix_tensorc

MPOOps_f90.sdot_sr_matrix_qtensor()

fortran-subroutine - May 2017 (dj) Dot product / matrix-matrix multiplication between to sparse matrices.

Arguments

MatcTYPE(sr_matrix_qtensor), inout

The outcome of the matrix-matrix multiplication. The entries are combined with the outer product or Kronecker product leading to rank-4 tensors.

MataTYPE(sr_matrix_qtensor), in

The left sparse matrix in the matrix-matrix multiplications.

MatbTYPE(sr_matrix_qtensor), in

The left sparse matrix in the matrix-matrix multiplications.

Source Code

show / hide f90 code

  subroutine sdot_sr_matrix_qtensor(Matc, Mata, Matb)
      type(sr_matrix_qtensor), intent(inout) :: Matc
      type(sr_matrix_qtensor), intent(in) :: Mata, Matb

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

      ! for looping
      integer :: ii, jj, kk

      ! actual index for jj, kk
      integer :: indj, indk

      ! index in Matc
      integer :: idx

      ! number of elements in a row of Matc
      integer :: numel

      ! table for entries in Matb, serves as backmap
      integer, dimension(:, :), allocatable :: bjk

      ! logical to catch first entry
      logical :: first

      ! Get all entries of Matb
      allocate(bjk(Matb%rbd, Matb%cbd))
      bjk = 0

      do jj = 1, Matb%rbd
          do kk = 1, Matb%Row(jj)%numel
              bjk(jj, Matb%Row(jj)%ind(kk)) = kk
          end do
      end do

      ! Start multiplication
      ! --------------------

      Matc%rbd = Mata%rbd
      Matc%cbd = Matb%cbd
      allocate(Matc%Row(Matc%rbd))

      do ii = 1, Matc%rbd

          ! Find number of elements in each row
          numel = 0
          do kk = 1, Matb%cbd
              first = .true.

              do jj = 1, Mata%Row(ii)%numel
                  if(bjk(Mata%Row(ii)%ind(jj), kk) > 0) then
                      if(first) then
                          numel = numel + 1
                          first = .false.
                      end if
                  end if
              end do
          end do

          Matc%Row(ii)%numel = numel
          allocate(Matc%Row(ii)%ind(numel), Matc%Row(ii)%Op(numel))

          ! Carry out multiplication with outer product
          idx = 0

          do kk = 1, Matb%cbd
              ! This are entries in Matc(ii, kk)
              first = .true.

              do jj = 1, Mata%Row(ii)%numel
                  indj = Mata%Row(ii)%ind(jj)

                  if(bjk(indj, kk) > 0) then
                      indk = bjk(indj, kk)

                      if(first) then
                          first = .false.
                          idx = idx + 1
                          Matc%Row(ii)%ind(idx) = kk

                          call kron(Matc%Row(ii)%Op(idx), &
                                    Mata%Row(ii)%Op(jj), &
                                    Matb%Row(indj)%Op(indk), &
                                    1, 1, 'N', 'N', op='N')

                      else
                          call kron(Matc%Row(ii)%Op(idx), &
                                    Mata%Row(ii)%Op(jj), &
                                    Matb%Row(indj)%Op(indk), &
                                    1, 1, 'N', 'N', op='+')
                      end if
                  end if
              end do
          end do
      end do

      deallocate(bjk)

  end subroutine sdot_sr_matrix_qtensor

MPOOps_f90.sdot_sr_matrix_qtensorc()

fortran-subroutine - May 2017 (dj) Dot product / matrix-matrix multiplication between to sparse matrices.

Arguments

MatcTYPE(sr_matrix_qtensorc), inout

The outcome of the matrix-matrix multiplication. The entries are combined with the outer product or Kronecker product leading to rank-4 tensors.

MataTYPE(sr_matrix_qtensorc), in

The left sparse matrix in the matrix-matrix multiplications.

MatbTYPE(sr_matrix_qtensorc), in

The left sparse matrix in the matrix-matrix multiplications.

Source Code

show / hide f90 code

  subroutine sdot_sr_matrix_qtensorc(Matc, Mata, Matb)
      type(sr_matrix_qtensorc), intent(inout) :: Matc
      type(sr_matrix_qtensorc), intent(in) :: Mata, Matb

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

      ! for looping
      integer :: ii, jj, kk

      ! actual index for jj, kk
      integer :: indj, indk

      ! index in Matc
      integer :: idx

      ! number of elements in a row of Matc
      integer :: numel

      ! table for entries in Matb, serves as backmap
      integer, dimension(:, :), allocatable :: bjk

      ! logical to catch first entry
      logical :: first

      ! Get all entries of Matb
      allocate(bjk(Matb%rbd, Matb%cbd))
      bjk = 0

      do jj = 1, Matb%rbd
          do kk = 1, Matb%Row(jj)%numel
              bjk(jj, Matb%Row(jj)%ind(kk)) = kk
          end do
      end do

      ! Start multiplication
      ! --------------------

      Matc%rbd = Mata%rbd
      Matc%cbd = Matb%cbd
      allocate(Matc%Row(Matc%rbd))

      do ii = 1, Matc%rbd

          ! Find number of elements in each row
          numel = 0
          do kk = 1, Matb%cbd
              first = .true.

              do jj = 1, Mata%Row(ii)%numel
                  if(bjk(Mata%Row(ii)%ind(jj), kk) > 0) then
                      if(first) then
                          numel = numel + 1
                          first = .false.
                      end if
                  end if
              end do
          end do

          Matc%Row(ii)%numel = numel
          allocate(Matc%Row(ii)%ind(numel), Matc%Row(ii)%Op(numel))

          ! Carry out multiplication with outer product
          idx = 0

          do kk = 1, Matb%cbd
              ! This are entries in Matc(ii, kk)
              first = .true.

              do jj = 1, Mata%Row(ii)%numel
                  indj = Mata%Row(ii)%ind(jj)

                  if(bjk(indj, kk) > 0) then
                      indk = bjk(indj, kk)

                      if(first) then
                          first = .false.
                          idx = idx + 1
                          Matc%Row(ii)%ind(idx) = kk

                          call kron(Matc%Row(ii)%Op(idx), &
                                    Mata%Row(ii)%Op(jj), &
                                    Matb%Row(indj)%Op(indk), &
                                    1, 1, 'N', 'N', op='N')

                      else
                          call kron(Matc%Row(ii)%Op(idx), &
                                    Mata%Row(ii)%Op(jj), &
                                    Matb%Row(indj)%Op(indk), &
                                    1, 1, 'N', 'N', op='+')
                      end if
                  end if
              end do
          end do
      end do

      deallocate(bjk)

  end subroutine sdot_sr_matrix_qtensorc

MPOOps_f90.set_hash_sparse_row_qtensor()

fortran-subroutine - October 2017 (dj) Set the hashes for all operators in a row of a sparse matrix.

Arguments

RowTYPE(sparse_row_qtensor), inout

The row of a sparse matrix. The operators are hashed according to their quantum numbers and the given index.

idxsINTEGER(*), in

Specify indices to be hashed in regard to the legs of the tensor.

Source Code

show / hide f90 code

  subroutine set_hash_sparse_row_qtensor(Row, idxs, errst)
      type(sparse_row_qtensor), intent(inout) :: Row
      integer, dimension(:), intent(in) :: idxs
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      !if(present(errst)) errst = 0

      do ii = 1, Row%numel
          call set_hash(Row%Op(ii), idxs, errst=errst)
          !if(prop_error('set_operator_hash_sparse_row_qtensor'//&
          !              ': set_hash failed.', 'MPOOps_include.f90:1424', &
          !              errst=errst)) return

          call sort(Row%Op(ii), errst=errst)
          !if(prop_error('set_operator_hash_sparse_row_qtensor'//&
          !              ': sort failed.', 'MPOOps_include.f90:1429', &
          !              errst=errst)) return
      end do

  end subroutine set_hash_sparse_row_qtensor

MPOOps_f90.set_hash_sparse_row_qtensorc()

fortran-subroutine - October 2017 (dj) Set the hashes for all operators in a row of a sparse matrix.

Arguments

RowTYPE(sparse_row_qtensorc), inout

The row of a sparse matrix. The operators are hashed according to their quantum numbers and the given index.

idxsINTEGER(*), in

Specify indices to be hashed in regard to the legs of the tensor.

Source Code

show / hide f90 code

  subroutine set_hash_sparse_row_qtensorc(Row, idxs, errst)
      type(sparse_row_qtensorc), intent(inout) :: Row
      integer, dimension(:), intent(in) :: idxs
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      !if(present(errst)) errst = 0

      do ii = 1, Row%numel
          call set_hash(Row%Op(ii), idxs, errst=errst)
          !if(prop_error('set_operator_hash_sparse_row_qtensorc'//&
          !              ': set_hash failed.', 'MPOOps_include.f90:1424', &
          !              errst=errst)) return

          call sort(Row%Op(ii), errst=errst)
          !if(prop_error('set_operator_hash_sparse_row_qtensorc'//&
          !              ': sort failed.', 'MPOOps_include.f90:1429', &
          !              errst=errst)) return
      end do

  end subroutine set_hash_sparse_row_qtensorc

MPOOps_f90.set_hash_sr_matrix_qtensor()

fortran-subroutine - October 2017 (dj) Set the hashes for all operators in a sparse matrix.

Arguments

MatTYPE(sr_matrix_qtensor), inout

A sparse matrix. The operators are hashed according to their quantum numbers and the given indices.

idxsINTEGER(*), in

Specify indices to be hashed in regard to the legs of the tensor.

Source Code

show / hide f90 code

  subroutine set_hash_sr_matrix_qtensor(Mat, idxs, errst)
      type(sr_matrix_qtensor), intent(inout) :: Mat
      integer, dimension(:), intent(in) :: idxs
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      !if(present(errst)) errst = 0

      do ii = 1, Mat%rbd
          call set_hash(Mat%Row(ii), idxs, errst=errst)
          !if(prop_error('set_hash_sr_matrix_qtensor : set_hash '//&
          !              'failed.', 'MPOOps_include.f90:1477', errst=errst)) return
      end do

  end subroutine set_hash_sr_matrix_qtensor

MPOOps_f90.set_hash_sr_matrix_qtensorc()

fortran-subroutine - October 2017 (dj) Set the hashes for all operators in a sparse matrix.

Arguments

MatTYPE(sr_matrix_qtensorc), inout

A sparse matrix. The operators are hashed according to their quantum numbers and the given indices.

idxsINTEGER(*), in

Specify indices to be hashed in regard to the legs of the tensor.

Source Code

show / hide f90 code

  subroutine set_hash_sr_matrix_qtensorc(Mat, idxs, errst)
      type(sr_matrix_qtensorc), intent(inout) :: Mat
      integer, dimension(:), intent(in) :: idxs
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      !if(present(errst)) errst = 0

      do ii = 1, Mat%rbd
          call set_hash(Mat%Row(ii), idxs, errst=errst)
          !if(prop_error('set_hash_sr_matrix_qtensorc : set_hash '//&
          !              'failed.', 'MPOOps_include.f90:1477', errst=errst)) return
      end do

  end subroutine set_hash_sr_matrix_qtensorc

MPOOps_f90.set_hash_sr_matrix_tensor()

fortran-subroutine - October 2017 (dj) Dummy interface to supply interface for usual tensors without symmetries.

Arguments

MatTYPE(sr_matrix_tensor), inout

A sparse matrix. The operators are hashed according to their quantum numbers and the given indices.

idxsINTEGER(*), in

Specify indices to be hashed in regard to the legs of the tensor.

Source Code

show / hide f90 code

  subroutine set_hash_sr_matrix_tensor(Mat, idxs, errst)
      type(sr_matrix_tensor), intent(inout) :: Mat
      integer, dimension(:), intent(in) :: idxs
      integer, intent(out), optional :: errst

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

      !CHEK_if(present(errst)) errst = 0

      ! Avoid unused variable warning for intentionally unused variables
      !if(.false.) print *, Mat%rbd
      !if(.false.) print *, idxs

  end subroutine set_hash_sr_matrix_tensor

MPOOps_f90.set_hash_sr_matrix_tensorc()

fortran-subroutine - October 2017 (dj) Dummy interface to supply interface for usual tensors without symmetries.

Arguments

MatTYPE(sr_matrix_tensorc), inout

A sparse matrix. The operators are hashed according to their quantum numbers and the given indices.

idxsINTEGER(*), in

Specify indices to be hashed in regard to the legs of the tensor.

Source Code

show / hide f90 code

  subroutine set_hash_sr_matrix_tensorc(Mat, idxs, errst)
      type(sr_matrix_tensorc), intent(inout) :: Mat
      integer, dimension(:), intent(in) :: idxs
      integer, intent(out), optional :: errst

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

      !CHEK_if(present(errst)) errst = 0

      ! Avoid unused variable warning for intentionally unused variables
      !if(.false.) print *, Mat%rbd
      !if(.false.) print *, idxs

  end subroutine set_hash_sr_matrix_tensorc

MPOOps_f90.shift_sr_matrix_tensor()

fortran-subroutine - Construct the sparse MPO matrix representing (H - shift)

Arguments

MatTYPE(sr_matrix_tensor), inout

On exit, this is the shifted MPO.

shftREAL, in

The value for the shift.

Source Code

show / hide f90 code

  subroutine shift_sr_matrix_tensor(Mat, shft, errst)
      type(sr_matrix_tensor), intent(inout) :: Mat
      real(KIND=rKind), intent(in) :: shft
      integer, intent(out), optional :: errst

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

      !if(present(errst)) errst = 0

      ! Add -shift * Id to one operator
      ! First row, last column is always identity
      call gaxpy(Mat%Row(Mat%rbd)%Op(1), -shft, &
                 Mat%Row(1)%Op(Mat%Row(1)%numel))

  end subroutine shift_sr_matrix_tensor

MPOOps_f90.shift_sr_matrix_tensorc()

fortran-subroutine - Construct the sparse MPO matrix representing (H - shift)

Arguments

MatTYPE(sr_matrix_tensorc), inout

On exit, this is the shifted MPO.

shftREAL, in

The value for the shift.

Source Code

show / hide f90 code

  subroutine shift_sr_matrix_tensorc(Mat, shft, errst)
      type(sr_matrix_tensorc), intent(inout) :: Mat
      real(KIND=rKind), intent(in) :: shft
      integer, intent(out), optional :: errst

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

      !if(present(errst)) errst = 0

      ! Add -shift * Id to one operator
      ! First row, last column is always identity
      call gaxpy(Mat%Row(Mat%rbd)%Op(1), -shft, &
                 Mat%Row(1)%Op(Mat%Row(1)%numel))

  end subroutine shift_sr_matrix_tensorc

MPOOps_f90.shift_sr_matrix_qtensor()

fortran-subroutine - Construct the sparse MPO matrix representing (H - shift)

Arguments

MatTYPE(sr_matrix_qtensor), inout

On exit, this is the shifted MPO.

shftREAL, in

The value for the shift.

Source Code

show / hide f90 code

  subroutine shift_sr_matrix_qtensor(Mat, shft, errst)
      type(sr_matrix_qtensor), intent(inout) :: Mat
      real(KIND=rKind), intent(in) :: shft
      integer, intent(out), optional :: errst

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

      !if(present(errst)) errst = 0

      ! Add -shift * Id to one operator
      ! First row, last column is always identity
      call gaxpy(Mat%Row(Mat%rbd)%Op(1), -shft, &
                 Mat%Row(1)%Op(Mat%Row(1)%numel))

  end subroutine shift_sr_matrix_qtensor

MPOOps_f90.shift_sr_matrix_qtensorc()

fortran-subroutine - Construct the sparse MPO matrix representing (H - shift)

Arguments

MatTYPE(sr_matrix_qtensorc), inout

On exit, this is the shifted MPO.

shftREAL, in

The value for the shift.

Source Code

show / hide f90 code

  subroutine shift_sr_matrix_qtensorc(Mat, shft, errst)
      type(sr_matrix_qtensorc), intent(inout) :: Mat
      real(KIND=rKind), intent(in) :: shft
      integer, intent(out), optional :: errst

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

      !if(present(errst)) errst = 0

      ! Add -shift * Id to one operator
      ! First row, last column is always identity
      call gaxpy(Mat%Row(Mat%rbd)%Op(1), -shft, &
                 Mat%Row(1)%Op(Mat%Row(1)%numel))

  end subroutine shift_sr_matrix_qtensorc

MPOOps_f90.shiftandsquare_sparse_row_tensor()

fortran-subroutine - May 2017 (dj, updated) Shift and calculate the square for an MPO for one row.

Arguments

RowsqTYPE(MPO_ROW_TYPE), inout

Contains on exit on row of the shifted and squared MPO.

RowiTYPE(MPO_ROW_TYPE), inout

The left row in the sparse matrix to be shifted and squared. Intent(out) is to allow for possible transformations.

RowjTYPE(MPO_ROW_TYPE), inout

The right row in the sparse matrix to be shifted and squared. Intent(out) is to allow for possible transformations.

ilrLOGICAL, in

Flag if the left row equals to the last row in the original matrix.

jlrLOGICAL, in

Flag if the right row equals to the last row in the original matrix.

cbdINTEGER, in

Number of columns in the original matrix.

ShTYPE(MATRIX_TYPE), in

Contains - shift x Id, where Id is the identity matrix.

Source Code

show / hide f90 code

  subroutine shiftandsquare_sparse_row_tensor(Rowsq, Rowi, Rowj, ilr, &
                                                   jlr, cbd, Sh, errst)
      type(sparse_row_tensor), intent(inout) :: Rowsq
      type(sparse_row_tensor), intent(inout) :: Rowi, Rowj
      logical, intent(in) :: ilr, jlr
      integer, intent(in) :: cbd
      type(tensor), intent(in) :: Sh
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii, jj, kk

      ! shortcut to number of entries
      integer :: numel

      ! logical for first column
      logical :: ifc, jfc

      ! Shifted matrices
      type(tensor) :: Si, Sj

      !if(present(errst)) errst = 0

      numel = Rowi%numel * Rowj%numel
      Rowsq%numel = numel
      allocate(Rowsq%ind(numel), Rowsq%Op(numel))

      kk = 0
      do ii = 1, Rowi%numel
          ifc = (ii == 1)

          do jj = 1, Rowj%numel
              jfc = (jj == 1)
              kk = kk + 1

              Rowsq%ind(kk) = (Rowi%ind(ii) - 1) * cbd + Rowj%ind(jj)

              ! Split into cases to apply shift properly
              ! ........................................
              !
              ! assumes matrix for contr

              if(ilr .and. ifc .and. jlr .and. jfc) then
                  ! H^2 = (H - s) * (H - s)

                  call copy(Si, Rowi%Op(ii))
                  call gaxpy(Si, 1.0_rkind, Sh)

                  call copy(Sj, Rowj%Op(jj))
                  call gaxpy(Sj, 1.0_rKind, Sh)

                  call contr(Rowsq%Op(kk), Si, Sj, [2], [1])

                  call destroy(Si)
                  call destroy(Sj)
              elseif(ilr .and. ifc) then
                  ! H^2 = (H - s) * H

                  call copy(Si, Rowi%Op(ii))
                  call gaxpy(Si, 1.0_rKind, Sh)

                  call contr(Rowsq%Op(kk), Si, Rowj%Op(jj), [2], [1])

                  call destroy(Si)

              elseif(jlr .and. jfc) then
                  ! H^2 = H * (H - s)

                  call copy(Sj, Rowj%Op(jj))
                  call gaxpy(Sj, 1.0_rKind, Sh)

                  call contr(Rowsq%Op(kk), Rowi%Op(ii), Sj, [2], [1])

                  call destroy(Sj)
              else
                  ! H^2 = H * H
                  call contr(Rowsq%Op(kk), Rowi%Op(ii), Rowj%Op(jj), [2], [1])
              end if
          end do
      end do

  end subroutine shiftandsquare_sparse_row_tensor

MPOOps_f90.shiftandsquare_sparse_row_tensorc()

fortran-subroutine - May 2017 (dj, updated) Shift and calculate the square for an MPO for one row.

Arguments

RowsqTYPE(MPO_ROW_TYPE), inout

Contains on exit on row of the shifted and squared MPO.

RowiTYPE(MPO_ROW_TYPE), inout

The left row in the sparse matrix to be shifted and squared. Intent(out) is to allow for possible transformations.

RowjTYPE(MPO_ROW_TYPE), inout

The right row in the sparse matrix to be shifted and squared. Intent(out) is to allow for possible transformations.

ilrLOGICAL, in

Flag if the left row equals to the last row in the original matrix.

jlrLOGICAL, in

Flag if the right row equals to the last row in the original matrix.

cbdINTEGER, in

Number of columns in the original matrix.

ShTYPE(MATRIX_TYPE), in

Contains - shift x Id, where Id is the identity matrix.

Source Code

show / hide f90 code

  subroutine shiftandsquare_sparse_row_tensorc(Rowsq, Rowi, Rowj, ilr, &
                                                   jlr, cbd, Sh, errst)
      type(sparse_row_tensorc), intent(inout) :: Rowsq
      type(sparse_row_tensorc), intent(inout) :: Rowi, Rowj
      logical, intent(in) :: ilr, jlr
      integer, intent(in) :: cbd
      type(tensorc), intent(in) :: Sh
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii, jj, kk

      ! shortcut to number of entries
      integer :: numel

      ! logical for first column
      logical :: ifc, jfc

      ! Shifted matrices
      type(tensorc) :: Si, Sj

      !if(present(errst)) errst = 0

      numel = Rowi%numel * Rowj%numel
      Rowsq%numel = numel
      allocate(Rowsq%ind(numel), Rowsq%Op(numel))

      kk = 0
      do ii = 1, Rowi%numel
          ifc = (ii == 1)

          do jj = 1, Rowj%numel
              jfc = (jj == 1)
              kk = kk + 1

              Rowsq%ind(kk) = (Rowi%ind(ii) - 1) * cbd + Rowj%ind(jj)

              ! Split into cases to apply shift properly
              ! ........................................
              !
              ! assumes matrix for contr

              if(ilr .and. ifc .and. jlr .and. jfc) then
                  ! H^2 = (H - s) * (H - s)

                  call copy(Si, Rowi%Op(ii))
                  call gaxpy(Si, 1.0_rkind, Sh)

                  call copy(Sj, Rowj%Op(jj))
                  call gaxpy(Sj, 1.0_rKind, Sh)

                  call contr(Rowsq%Op(kk), Si, Sj, [2], [1])

                  call destroy(Si)
                  call destroy(Sj)
              elseif(ilr .and. ifc) then
                  ! H^2 = (H - s) * H

                  call copy(Si, Rowi%Op(ii))
                  call gaxpy(Si, 1.0_rKind, Sh)

                  call contr(Rowsq%Op(kk), Si, Rowj%Op(jj), [2], [1])

                  call destroy(Si)

              elseif(jlr .and. jfc) then
                  ! H^2 = H * (H - s)

                  call copy(Sj, Rowj%Op(jj))
                  call gaxpy(Sj, 1.0_rKind, Sh)

                  call contr(Rowsq%Op(kk), Rowi%Op(ii), Sj, [2], [1])

                  call destroy(Sj)
              else
                  ! H^2 = H * H
                  call contr(Rowsq%Op(kk), Rowi%Op(ii), Rowj%Op(jj), [2], [1])
              end if
          end do
      end do

  end subroutine shiftandsquare_sparse_row_tensorc

MPOOps_f90.shiftandsquare_sparse_row_qtensor()

fortran-subroutine - May 2017 (dj, updated) Shift and calculate the square for an MPO for one row.

Arguments

RowsqTYPE(MPO_ROW_TYPE), inout

Contains on exit on row of the shifted and squared MPO.

RowiTYPE(MPO_ROW_TYPE), inout

The left row in the sparse matrix to be shifted and squared. Intent(out) is to allow for possible transformations.

RowjTYPE(MPO_ROW_TYPE), inout

The right row in the sparse matrix to be shifted and squared. Intent(out) is to allow for possible transformations.

ilrLOGICAL, in

Flag if the left row equals to the last row in the original matrix.

jlrLOGICAL, in

Flag if the right row equals to the last row in the original matrix.

cbdINTEGER, in

Number of columns in the original matrix.

ShTYPE(MATRIX_TYPE), in

Contains - shift x Id, where Id is the identity matrix.

Source Code

show / hide f90 code

  subroutine shiftandsquare_sparse_row_qtensor(Rowsq, Rowi, Rowj, ilr, &
                                                   jlr, cbd, Sh, errst)
      type(sparse_row_qtensor), intent(inout) :: Rowsq
      type(sparse_row_qtensor), intent(inout) :: Rowi, Rowj
      logical, intent(in) :: ilr, jlr
      integer, intent(in) :: cbd
      type(qtensor), intent(in) :: Sh
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii, jj, kk

      ! shortcut to number of entries
      integer :: numel

      ! logical for first column
      logical :: ifc, jfc

      ! Shifted matrices
      type(qtensor) :: Si, Sj

      !if(present(errst)) errst = 0

      numel = Rowi%numel * Rowj%numel
      Rowsq%numel = numel
      allocate(Rowsq%ind(numel), Rowsq%Op(numel))

      kk = 0
      do ii = 1, Rowi%numel
          ifc = (ii == 1)

          do jj = 1, Rowj%numel
              jfc = (jj == 1)
              kk = kk + 1

              Rowsq%ind(kk) = (Rowi%ind(ii) - 1) * cbd + Rowj%ind(jj)

              ! Split into cases to apply shift properly
              ! ........................................
              !
              ! assumes matrix for contr

              if(ilr .and. ifc .and. jlr .and. jfc) then
                  ! H^2 = (H - s) * (H - s)

                  call copy(Si, Rowi%Op(ii))
                  call gaxpy(Si, 1.0_rkind, Sh)

                  call copy(Sj, Rowj%Op(jj))
                  call gaxpy(Sj, 1.0_rKind, Sh)

                  call contr(Rowsq%Op(kk), Si, Sj, [2], [1])

                  call destroy(Si)
                  call destroy(Sj)
              elseif(ilr .and. ifc) then
                  ! H^2 = (H - s) * H

                  call copy(Si, Rowi%Op(ii))
                  call gaxpy(Si, 1.0_rKind, Sh)

                  call contr(Rowsq%Op(kk), Si, Rowj%Op(jj), [2], [1])

                  call destroy(Si)

              elseif(jlr .and. jfc) then
                  ! H^2 = H * (H - s)

                  call copy(Sj, Rowj%Op(jj))
                  call gaxpy(Sj, 1.0_rKind, Sh)

                  call contr(Rowsq%Op(kk), Rowi%Op(ii), Sj, [2], [1])

                  call destroy(Sj)
              else
                  ! H^2 = H * H
                  call contr(Rowsq%Op(kk), Rowi%Op(ii), Rowj%Op(jj), [2], [1])
              end if
          end do
      end do

  end subroutine shiftandsquare_sparse_row_qtensor

MPOOps_f90.shiftandsquare_sparse_row_qtensorc()

fortran-subroutine - May 2017 (dj, updated) Shift and calculate the square for an MPO for one row.

Arguments

RowsqTYPE(MPO_ROW_TYPE), inout

Contains on exit on row of the shifted and squared MPO.

RowiTYPE(MPO_ROW_TYPE), inout

The left row in the sparse matrix to be shifted and squared. Intent(out) is to allow for possible transformations.

RowjTYPE(MPO_ROW_TYPE), inout

The right row in the sparse matrix to be shifted and squared. Intent(out) is to allow for possible transformations.

ilrLOGICAL, in

Flag if the left row equals to the last row in the original matrix.

jlrLOGICAL, in

Flag if the right row equals to the last row in the original matrix.

cbdINTEGER, in

Number of columns in the original matrix.

ShTYPE(MATRIX_TYPE), in

Contains - shift x Id, where Id is the identity matrix.

Source Code

show / hide f90 code

  subroutine shiftandsquare_sparse_row_qtensorc(Rowsq, Rowi, Rowj, ilr, &
                                                   jlr, cbd, Sh, errst)
      type(sparse_row_qtensorc), intent(inout) :: Rowsq
      type(sparse_row_qtensorc), intent(inout) :: Rowi, Rowj
      logical, intent(in) :: ilr, jlr
      integer, intent(in) :: cbd
      type(qtensorc), intent(in) :: Sh
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii, jj, kk

      ! shortcut to number of entries
      integer :: numel

      ! logical for first column
      logical :: ifc, jfc

      ! Shifted matrices
      type(qtensorc) :: Si, Sj

      !if(present(errst)) errst = 0

      numel = Rowi%numel * Rowj%numel
      Rowsq%numel = numel
      allocate(Rowsq%ind(numel), Rowsq%Op(numel))

      kk = 0
      do ii = 1, Rowi%numel
          ifc = (ii == 1)

          do jj = 1, Rowj%numel
              jfc = (jj == 1)
              kk = kk + 1

              Rowsq%ind(kk) = (Rowi%ind(ii) - 1) * cbd + Rowj%ind(jj)

              ! Split into cases to apply shift properly
              ! ........................................
              !
              ! assumes matrix for contr

              if(ilr .and. ifc .and. jlr .and. jfc) then
                  ! H^2 = (H - s) * (H - s)

                  call copy(Si, Rowi%Op(ii))
                  call gaxpy(Si, 1.0_rkind, Sh)

                  call copy(Sj, Rowj%Op(jj))
                  call gaxpy(Sj, 1.0_rKind, Sh)

                  call contr(Rowsq%Op(kk), Si, Sj, [2], [1])

                  call destroy(Si)
                  call destroy(Sj)
              elseif(ilr .and. ifc) then
                  ! H^2 = (H - s) * H

                  call copy(Si, Rowi%Op(ii))
                  call gaxpy(Si, 1.0_rKind, Sh)

                  call contr(Rowsq%Op(kk), Si, Rowj%Op(jj), [2], [1])

                  call destroy(Si)

              elseif(jlr .and. jfc) then
                  ! H^2 = H * (H - s)

                  call copy(Sj, Rowj%Op(jj))
                  call gaxpy(Sj, 1.0_rKind, Sh)

                  call contr(Rowsq%Op(kk), Rowi%Op(ii), Sj, [2], [1])

                  call destroy(Sj)
              else
                  ! H^2 = H * H
                  call contr(Rowsq%Op(kk), Rowi%Op(ii), Rowj%Op(jj), [2], [1])
              end if
          end do
      end do

  end subroutine shiftandsquare_sparse_row_qtensorc

MPOOps_f90.shiftandsquare_sr_matrix_tensor()

fortran-subroutine - May 2017 (dj, updated) Find a representation of a shifted and squared MPO matrix using the matrix direct product.

Arguments

MatsqTYPE(sr_matrix_tensor), inout

On exit, the shifted square of the original MPO matrix.

MatTYPE(sr_matrix_tensor), inout

The MPO matrix to be shifted and squared.

shiftREAL, in

The shift as scalar.

Source Code

show / hide f90 code

  subroutine shiftandsquare_sr_matrix_tensor(Matsq, Mat, shift, errst)
      type(sr_matrix_tensor), intent(inout) :: Matsq, Mat
      real(KIND=rKind), intent(in) :: shift
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii, jj, kk

      ! identify last rows
      logical :: ilast, jlast

      ! Scaled identity matrix
      type(tensor) :: Sh

      !if(present(errst)) errst = 0

      ! First row, last column is always identity
      call copy(Sh, Mat%Row(1)%Op(Mat%Row(1)%numel))
      call scale(-shift, Sh)

      ! Get dimensions and allocate rows
      Matsq%rbd = Mat%rbd**2
      Matsq%cbd = Mat%cbd**2
      allocate(Matsq%Row(Matsq%rbd))

      ! Loop over all rows

      kk = 0
      do ii = 1, Mat%rbd
          ilast = (ii == Mat%rbd)

          do jj = 1, Mat%rbd
              jlast = (jj == Mat%rbd)
              kk = kk + 1

              call shiftandsquare(Matsq%Row(kk), Mat%Row(ii), Mat%Row(jj), &
                                  ilast, jlast, Mat%cbd, Sh)
          end do
      end do

      call destroy(Sh)

  end subroutine shiftandsquare_sr_matrix_tensor

MPOOps_f90.shiftandsquare_sr_matrix_tensorc()

fortran-subroutine - May 2017 (dj, updated) Find a representation of a shifted and squared MPO matrix using the matrix direct product.

Arguments

MatsqTYPE(sr_matrix_tensorc), inout

On exit, the shifted square of the original MPO matrix.

MatTYPE(sr_matrix_tensorc), inout

The MPO matrix to be shifted and squared.

shiftREAL, in

The shift as scalar.

Source Code

show / hide f90 code

  subroutine shiftandsquare_sr_matrix_tensorc(Matsq, Mat, shift, errst)
      type(sr_matrix_tensorc), intent(inout) :: Matsq, Mat
      real(KIND=rKind), intent(in) :: shift
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii, jj, kk

      ! identify last rows
      logical :: ilast, jlast

      ! Scaled identity matrix
      type(tensorc) :: Sh

      !if(present(errst)) errst = 0

      ! First row, last column is always identity
      call copy(Sh, Mat%Row(1)%Op(Mat%Row(1)%numel))
      call scale(-shift, Sh)

      ! Get dimensions and allocate rows
      Matsq%rbd = Mat%rbd**2
      Matsq%cbd = Mat%cbd**2
      allocate(Matsq%Row(Matsq%rbd))

      ! Loop over all rows

      kk = 0
      do ii = 1, Mat%rbd
          ilast = (ii == Mat%rbd)

          do jj = 1, Mat%rbd
              jlast = (jj == Mat%rbd)
              kk = kk + 1

              call shiftandsquare(Matsq%Row(kk), Mat%Row(ii), Mat%Row(jj), &
                                  ilast, jlast, Mat%cbd, Sh)
          end do
      end do

      call destroy(Sh)

  end subroutine shiftandsquare_sr_matrix_tensorc

MPOOps_f90.shiftandsquare_sr_matrix_qtensor()

fortran-subroutine - May 2017 (dj, updated) Find a representation of a shifted and squared MPO matrix using the matrix direct product.

Arguments

MatsqTYPE(sr_matrix_qtensor), inout

On exit, the shifted square of the original MPO matrix.

MatTYPE(sr_matrix_qtensor), inout

The MPO matrix to be shifted and squared.

shiftREAL, in

The shift as scalar.

Source Code

show / hide f90 code

  subroutine shiftandsquare_sr_matrix_qtensor(Matsq, Mat, shift, errst)
      type(sr_matrix_qtensor), intent(inout) :: Matsq, Mat
      real(KIND=rKind), intent(in) :: shift
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii, jj, kk

      ! identify last rows
      logical :: ilast, jlast

      ! Scaled identity matrix
      type(qtensor) :: Sh

      !if(present(errst)) errst = 0

      ! First row, last column is always identity
      call copy(Sh, Mat%Row(1)%Op(Mat%Row(1)%numel))
      call scale(-shift, Sh)

      ! Get dimensions and allocate rows
      Matsq%rbd = Mat%rbd**2
      Matsq%cbd = Mat%cbd**2
      allocate(Matsq%Row(Matsq%rbd))

      ! Loop over all rows

      kk = 0
      do ii = 1, Mat%rbd
          ilast = (ii == Mat%rbd)

          do jj = 1, Mat%rbd
              jlast = (jj == Mat%rbd)
              kk = kk + 1

              call shiftandsquare(Matsq%Row(kk), Mat%Row(ii), Mat%Row(jj), &
                                  ilast, jlast, Mat%cbd, Sh)
          end do
      end do

      call destroy(Sh)

  end subroutine shiftandsquare_sr_matrix_qtensor

MPOOps_f90.shiftandsquare_sr_matrix_qtensorc()

fortran-subroutine - May 2017 (dj, updated) Find a representation of a shifted and squared MPO matrix using the matrix direct product.

Arguments

MatsqTYPE(sr_matrix_qtensorc), inout

On exit, the shifted square of the original MPO matrix.

MatTYPE(sr_matrix_qtensorc), inout

The MPO matrix to be shifted and squared.

shiftREAL, in

The shift as scalar.

Source Code

show / hide f90 code

  subroutine shiftandsquare_sr_matrix_qtensorc(Matsq, Mat, shift, errst)
      type(sr_matrix_qtensorc), intent(inout) :: Matsq, Mat
      real(KIND=rKind), intent(in) :: shift
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii, jj, kk

      ! identify last rows
      logical :: ilast, jlast

      ! Scaled identity matrix
      type(qtensorc) :: Sh

      !if(present(errst)) errst = 0

      ! First row, last column is always identity
      call copy(Sh, Mat%Row(1)%Op(Mat%Row(1)%numel))
      call scale(-shift, Sh)

      ! Get dimensions and allocate rows
      Matsq%rbd = Mat%rbd**2
      Matsq%cbd = Mat%cbd**2
      allocate(Matsq%Row(Matsq%rbd))

      ! Loop over all rows

      kk = 0
      do ii = 1, Mat%rbd
          ilast = (ii == Mat%rbd)

          do jj = 1, Mat%rbd
              jlast = (jj == Mat%rbd)
              kk = kk + 1

              call shiftandsquare(Matsq%Row(kk), Mat%Row(ii), Mat%Row(jj), &
                                  ilast, jlast, Mat%cbd, Sh)
          end do
      end do

      call destroy(Sh)

  end subroutine shiftandsquare_sr_matrix_qtensorc

MPOOps_f90.square_sparse_row_tensor()

fortran-subroutine - May 2017 (dj, updated) Calculate the square of an MPO for one row.

Arguments

RowsqTYPE(sparse_row_tensor), inout

Contains on exit the sparse matrix necessary for squaring an MPO.

Rowito, inout

allow for possible transformations.

Rowjto, inout

allow for possible transformations.

cbdINTEGER, in

Number of columns in the sparse matrix to be squared.

trafolCHARACTER, OPTIONAL, inout

Transformation on the left matrix.

traforCHARACTER, OPTIONAL, inout

Transformation on the right matrix.

Source Code

show / hide f90 code

  subroutine square_sparse_row_tensor(Rowsq, Rowi, Rowj, cbd, &
                                            trafol, trafor, errst)
      type(sparse_row_tensor), intent(inout) :: Rowsq
      type(sparse_row_tensor), intent(inout) :: Rowi, Rowj
      integer, intent(in) :: cbd
      character, intent(in), optional :: trafol, trafor
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii, jj, kk

      ! contraction index
      integer :: cl, cr

      ! shortcut to number of entries
      integer :: numel

      ! actual trans - doublet of optional argument
      character :: transl, transr

      ! Temporary tensors
      type(tensor) :: Tmpl, Tmpr

      !if(present(errst)) errst = 0

      if(present(trafol)) then
          if(trafol == 'N') then
              ! No transformation
              cl = 2
              transl = 'N'
          elseif(trafol == 'C') then
              ! Complex conjugated (without transposed)
              cl = 2
              transl = 'C'
          elseif(trafol == 'T') then
              ! Transposed
              cl = 1
              transl = 'N'
          elseif(trafol == 'D') then
              ! Daggered (tranposed complex conjugated)
              cl = 1
              transl = 'C'
          else
              errst = raise_error('square_sparse_row_tensor: '//&
                                  'unknown transformation.', 99, & 
                                  'MPOOps_include.f90:1884', errst=errst)
              return
          end if
      else
          cl = 2
          transl = 'N'
      end if

      if(present(trafor)) then
          if(trafor == 'N') then
              ! No transformation
              cr = 1
              transr = 'N'
          elseif(trafor == 'C') then
              ! Complex conjugated (without transposed)
              cr = 1
              transr = 'C'
          elseif(trafor == 'T') then
              ! Transposed
              cr = 2
              transr = 'N'
          elseif(trafor == 'D') then
              ! Daggered (tranposed complex conjugated)
              cr = 2
              transr = 'C'
          else
              errst = raise_error('square_sparse_row_tensor: '//&
                                  'unknown transformation.', 99, & 
                                  'MPOOps_include.f90:1912', errst=errst)
              return
          end if
      else
          cr = 1
          transr = 'N'
      end if

      numel = Rowi%numel * Rowj%numel
      Rowsq%numel = numel
      allocate(Rowsq%ind(numel), Rowsq%Op(numel))

      kk = 0

      if((cl == 2) .and. (cr == 1)) then
          do ii = 1, Rowi%numel
              do jj = 1, Rowj%numel
                  kk = kk + 1

                  Rowsq%ind(kk) = (Rowi%ind(ii) - 1) * cbd + Rowj%ind(jj)

                  ! Assumes matrix
                  call contr(Rowsq%Op(kk), Rowi%Op(ii), Rowj%Op(jj), &
                             [2], [1], transl=transl, transr=transr)
      ! To-Do: avoid permutations here.
              end do
          end do
      else
          do ii = 1, Rowi%numel
              do jj = 1, Rowj%numel
                  kk = kk + 1

                  Rowsq%ind(kk) = (Rowi%ind(ii) - 1) * cbd + Rowj%ind(jj)

                  call copy(Tmpl, Rowi%Op(ii))
                  call copy(Tmpr, Rowj%Op(jj))

                  ! Assumes matrix
                  call contr(Rowsq%Op(kk), Tmpl, Tmpr, [cl], [cr], &
                             transl=transl, transr=transr)

                  call destroy(Tmpl)
                  call destroy(Tmpr)
              end do
          end do
      end if

  end subroutine square_sparse_row_tensor

MPOOps_f90.square_sparse_row_tensorc()

fortran-subroutine - May 2017 (dj, updated) Calculate the square of an MPO for one row.

Arguments

RowsqTYPE(sparse_row_tensorc), inout

Contains on exit the sparse matrix necessary for squaring an MPO.

Rowito, inout

allow for possible transformations.

Rowjto, inout

allow for possible transformations.

cbdINTEGER, in

Number of columns in the sparse matrix to be squared.

trafolCHARACTER, OPTIONAL, inout

Transformation on the left matrix.

traforCHARACTER, OPTIONAL, inout

Transformation on the right matrix.

Source Code

show / hide f90 code

  subroutine square_sparse_row_tensorc(Rowsq, Rowi, Rowj, cbd, &
                                            trafol, trafor, errst)
      type(sparse_row_tensorc), intent(inout) :: Rowsq
      type(sparse_row_tensorc), intent(inout) :: Rowi, Rowj
      integer, intent(in) :: cbd
      character, intent(in), optional :: trafol, trafor
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii, jj, kk

      ! contraction index
      integer :: cl, cr

      ! shortcut to number of entries
      integer :: numel

      ! actual trans - doublet of optional argument
      character :: transl, transr

      ! Temporary tensors
      type(tensorc) :: Tmpl, Tmpr

      !if(present(errst)) errst = 0

      if(present(trafol)) then
          if(trafol == 'N') then
              ! No transformation
              cl = 2
              transl = 'N'
          elseif(trafol == 'C') then
              ! Complex conjugated (without transposed)
              cl = 2
              transl = 'C'
          elseif(trafol == 'T') then
              ! Transposed
              cl = 1
              transl = 'N'
          elseif(trafol == 'D') then
              ! Daggered (tranposed complex conjugated)
              cl = 1
              transl = 'C'
          else
              errst = raise_error('square_sparse_row_tensorc: '//&
                                  'unknown transformation.', 99, & 
                                  'MPOOps_include.f90:1884', errst=errst)
              return
          end if
      else
          cl = 2
          transl = 'N'
      end if

      if(present(trafor)) then
          if(trafor == 'N') then
              ! No transformation
              cr = 1
              transr = 'N'
          elseif(trafor == 'C') then
              ! Complex conjugated (without transposed)
              cr = 1
              transr = 'C'
          elseif(trafor == 'T') then
              ! Transposed
              cr = 2
              transr = 'N'
          elseif(trafor == 'D') then
              ! Daggered (tranposed complex conjugated)
              cr = 2
              transr = 'C'
          else
              errst = raise_error('square_sparse_row_tensorc: '//&
                                  'unknown transformation.', 99, & 
                                  'MPOOps_include.f90:1912', errst=errst)
              return
          end if
      else
          cr = 1
          transr = 'N'
      end if

      numel = Rowi%numel * Rowj%numel
      Rowsq%numel = numel
      allocate(Rowsq%ind(numel), Rowsq%Op(numel))

      kk = 0

      if((cl == 2) .and. (cr == 1)) then
          do ii = 1, Rowi%numel
              do jj = 1, Rowj%numel
                  kk = kk + 1

                  Rowsq%ind(kk) = (Rowi%ind(ii) - 1) * cbd + Rowj%ind(jj)

                  ! Assumes matrix
                  call contr(Rowsq%Op(kk), Rowi%Op(ii), Rowj%Op(jj), &
                             [2], [1], transl=transl, transr=transr)
      ! To-Do: avoid permutations here.
              end do
          end do
      else
          do ii = 1, Rowi%numel
              do jj = 1, Rowj%numel
                  kk = kk + 1

                  Rowsq%ind(kk) = (Rowi%ind(ii) - 1) * cbd + Rowj%ind(jj)

                  call copy(Tmpl, Rowi%Op(ii))
                  call copy(Tmpr, Rowj%Op(jj))

                  ! Assumes matrix
                  call contr(Rowsq%Op(kk), Tmpl, Tmpr, [cl], [cr], &
                             transl=transl, transr=transr)

                  call destroy(Tmpl)
                  call destroy(Tmpr)
              end do
          end do
      end if

  end subroutine square_sparse_row_tensorc

MPOOps_f90.square_sparse_row_qtensor()

fortran-subroutine - May 2017 (dj, updated) Calculate the square of an MPO for one row.

Arguments

RowsqTYPE(sparse_row_qtensor), inout

Contains on exit the sparse matrix necessary for squaring an MPO.

Rowito, inout

allow for possible transformations.

Rowjto, inout

allow for possible transformations.

cbdINTEGER, in

Number of columns in the sparse matrix to be squared.

trafolCHARACTER, OPTIONAL, inout

Transformation on the left matrix.

traforCHARACTER, OPTIONAL, inout

Transformation on the right matrix.

Source Code

show / hide f90 code

  subroutine square_sparse_row_qtensor(Rowsq, Rowi, Rowj, cbd, &
                                            trafol, trafor, errst)
      type(sparse_row_qtensor), intent(inout) :: Rowsq
      type(sparse_row_qtensor), intent(inout) :: Rowi, Rowj
      integer, intent(in) :: cbd
      character, intent(in), optional :: trafol, trafor
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii, jj, kk

      ! contraction index
      integer :: cl, cr

      ! shortcut to number of entries
      integer :: numel

      ! actual trans - doublet of optional argument
      character :: transl, transr

      ! Temporary tensors
      type(qtensor) :: Tmpl, Tmpr

      !if(present(errst)) errst = 0

      if(present(trafol)) then
          if(trafol == 'N') then
              ! No transformation
              cl = 2
              transl = 'N'
          elseif(trafol == 'C') then
              ! Complex conjugated (without transposed)
              cl = 2
              transl = 'C'
          elseif(trafol == 'T') then
              ! Transposed
              cl = 1
              transl = 'N'
          elseif(trafol == 'D') then
              ! Daggered (tranposed complex conjugated)
              cl = 1
              transl = 'C'
          else
              errst = raise_error('square_sparse_row_qtensor: '//&
                                  'unknown transformation.', 99, & 
                                  'MPOOps_include.f90:1884', errst=errst)
              return
          end if
      else
          cl = 2
          transl = 'N'
      end if

      if(present(trafor)) then
          if(trafor == 'N') then
              ! No transformation
              cr = 1
              transr = 'N'
          elseif(trafor == 'C') then
              ! Complex conjugated (without transposed)
              cr = 1
              transr = 'C'
          elseif(trafor == 'T') then
              ! Transposed
              cr = 2
              transr = 'N'
          elseif(trafor == 'D') then
              ! Daggered (tranposed complex conjugated)
              cr = 2
              transr = 'C'
          else
              errst = raise_error('square_sparse_row_qtensor: '//&
                                  'unknown transformation.', 99, & 
                                  'MPOOps_include.f90:1912', errst=errst)
              return
          end if
      else
          cr = 1
          transr = 'N'
      end if

      numel = Rowi%numel * Rowj%numel
      Rowsq%numel = numel
      allocate(Rowsq%ind(numel), Rowsq%Op(numel))

      kk = 0

      if((cl == 2) .and. (cr == 1)) then
          do ii = 1, Rowi%numel
              do jj = 1, Rowj%numel
                  kk = kk + 1

                  Rowsq%ind(kk) = (Rowi%ind(ii) - 1) * cbd + Rowj%ind(jj)

                  ! Assumes matrix
                  call contr(Rowsq%Op(kk), Rowi%Op(ii), Rowj%Op(jj), &
                             [2], [1], transl=transl, transr=transr)
      ! To-Do: avoid permutations here.
              end do
          end do
      else
          do ii = 1, Rowi%numel
              do jj = 1, Rowj%numel
                  kk = kk + 1

                  Rowsq%ind(kk) = (Rowi%ind(ii) - 1) * cbd + Rowj%ind(jj)

                  call copy(Tmpl, Rowi%Op(ii))
                  call copy(Tmpr, Rowj%Op(jj))

                  ! Assumes matrix
                  call contr(Rowsq%Op(kk), Tmpl, Tmpr, [cl], [cr], &
                             transl=transl, transr=transr)

                  call destroy(Tmpl)
                  call destroy(Tmpr)
              end do
          end do
      end if

  end subroutine square_sparse_row_qtensor

MPOOps_f90.square_sparse_row_qtensorc()

fortran-subroutine - May 2017 (dj, updated) Calculate the square of an MPO for one row.

Arguments

RowsqTYPE(sparse_row_qtensorc), inout

Contains on exit the sparse matrix necessary for squaring an MPO.

Rowito, inout

allow for possible transformations.

Rowjto, inout

allow for possible transformations.

cbdINTEGER, in

Number of columns in the sparse matrix to be squared.

trafolCHARACTER, OPTIONAL, inout

Transformation on the left matrix.

traforCHARACTER, OPTIONAL, inout

Transformation on the right matrix.

Source Code

show / hide f90 code

  subroutine square_sparse_row_qtensorc(Rowsq, Rowi, Rowj, cbd, &
                                            trafol, trafor, errst)
      type(sparse_row_qtensorc), intent(inout) :: Rowsq
      type(sparse_row_qtensorc), intent(inout) :: Rowi, Rowj
      integer, intent(in) :: cbd
      character, intent(in), optional :: trafol, trafor
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii, jj, kk

      ! contraction index
      integer :: cl, cr

      ! shortcut to number of entries
      integer :: numel

      ! actual trans - doublet of optional argument
      character :: transl, transr

      ! Temporary tensors
      type(qtensorc) :: Tmpl, Tmpr

      !if(present(errst)) errst = 0

      if(present(trafol)) then
          if(trafol == 'N') then
              ! No transformation
              cl = 2
              transl = 'N'
          elseif(trafol == 'C') then
              ! Complex conjugated (without transposed)
              cl = 2
              transl = 'C'
          elseif(trafol == 'T') then
              ! Transposed
              cl = 1
              transl = 'N'
          elseif(trafol == 'D') then
              ! Daggered (tranposed complex conjugated)
              cl = 1
              transl = 'C'
          else
              errst = raise_error('square_sparse_row_qtensorc: '//&
                                  'unknown transformation.', 99, & 
                                  'MPOOps_include.f90:1884', errst=errst)
              return
          end if
      else
          cl = 2
          transl = 'N'
      end if

      if(present(trafor)) then
          if(trafor == 'N') then
              ! No transformation
              cr = 1
              transr = 'N'
          elseif(trafor == 'C') then
              ! Complex conjugated (without transposed)
              cr = 1
              transr = 'C'
          elseif(trafor == 'T') then
              ! Transposed
              cr = 2
              transr = 'N'
          elseif(trafor == 'D') then
              ! Daggered (tranposed complex conjugated)
              cr = 2
              transr = 'C'
          else
              errst = raise_error('square_sparse_row_qtensorc: '//&
                                  'unknown transformation.', 99, & 
                                  'MPOOps_include.f90:1912', errst=errst)
              return
          end if
      else
          cr = 1
          transr = 'N'
      end if

      numel = Rowi%numel * Rowj%numel
      Rowsq%numel = numel
      allocate(Rowsq%ind(numel), Rowsq%Op(numel))

      kk = 0

      if((cl == 2) .and. (cr == 1)) then
          do ii = 1, Rowi%numel
              do jj = 1, Rowj%numel
                  kk = kk + 1

                  Rowsq%ind(kk) = (Rowi%ind(ii) - 1) * cbd + Rowj%ind(jj)

                  ! Assumes matrix
                  call contr(Rowsq%Op(kk), Rowi%Op(ii), Rowj%Op(jj), &
                             [2], [1], transl=transl, transr=transr)
      ! To-Do: avoid permutations here.
              end do
          end do
      else
          do ii = 1, Rowi%numel
              do jj = 1, Rowj%numel
                  kk = kk + 1

                  Rowsq%ind(kk) = (Rowi%ind(ii) - 1) * cbd + Rowj%ind(jj)

                  call copy(Tmpl, Rowi%Op(ii))
                  call copy(Tmpr, Rowj%Op(jj))

                  ! Assumes matrix
                  call contr(Rowsq%Op(kk), Tmpl, Tmpr, [cl], [cr], &
                             transl=transl, transr=transr)

                  call destroy(Tmpl)
                  call destroy(Tmpr)
              end do
          end do
      end if

  end subroutine square_sparse_row_qtensorc

MPOOps_f90.square_sr_matrix_tensor()

fortran-subroutine - May 2017 (dj, updated) Find a sparse MPOm representation of the square of H using the matrix direct product.

Arguments

MatsqTYPE(sr_matrix_tensor), inout

On exit, the square of the original MPO matrix.

MatTYPE(sr_matrix_tensor), inout

The MPO matrix to be squared.

trafolCHARACTER, OPTIONAL, inout

Transformation on the left matrix.

traforCHARACTER, OPTIONAL, inout

Transformation on the right matrix.

Source Code

show / hide f90 code

  subroutine square_sr_matrix_tensor(Matsq, Mat, trafol, trafor, &
                                              errst)
      type(sr_matrix_tensor), intent(inout) :: Matsq
      type(sr_matrix_tensor), intent(inout) :: Mat
      character, intent(in), optional :: trafol, trafor
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii, jj, kk

      !if(present(errst)) errst = 0

      ! Get dimensions and allocate rows
      Matsq%rbd = Mat%rbd**2
      Matsq%cbd = Mat%cbd**2
      allocate(Matsq%Row(Matsq%rbd))

      ! Loop over all rows

      kk = 0
      do ii = 1, Mat%rbd
          do jj = 1, Mat%rbd
              kk = kk + 1

              call square(Matsq%Row(kk), Mat%Row(ii), Mat%Row(jj), &
                          Mat%cbd, trafol=trafol, trafor=trafor, &
                          errst=errst)
              !if(prop_error('square_sr_matrix_tensor: '//&
              !              'square failed.', 'MPOOps_include.f90:2030', &
              !              errst=errst)) return
          end do
      end do

  end subroutine square_sr_matrix_tensor

MPOOps_f90.square_sr_matrix_tensorc()

fortran-subroutine - May 2017 (dj, updated) Find a sparse MPOm representation of the square of H using the matrix direct product.

Arguments

MatsqTYPE(sr_matrix_tensorc), inout

On exit, the square of the original MPO matrix.

MatTYPE(sr_matrix_tensorc), inout

The MPO matrix to be squared.

trafolCHARACTER, OPTIONAL, inout

Transformation on the left matrix.

traforCHARACTER, OPTIONAL, inout

Transformation on the right matrix.

Source Code

show / hide f90 code

  subroutine square_sr_matrix_tensorc(Matsq, Mat, trafol, trafor, &
                                              errst)
      type(sr_matrix_tensorc), intent(inout) :: Matsq
      type(sr_matrix_tensorc), intent(inout) :: Mat
      character, intent(in), optional :: trafol, trafor
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii, jj, kk

      !if(present(errst)) errst = 0

      ! Get dimensions and allocate rows
      Matsq%rbd = Mat%rbd**2
      Matsq%cbd = Mat%cbd**2
      allocate(Matsq%Row(Matsq%rbd))

      ! Loop over all rows

      kk = 0
      do ii = 1, Mat%rbd
          do jj = 1, Mat%rbd
              kk = kk + 1

              call square(Matsq%Row(kk), Mat%Row(ii), Mat%Row(jj), &
                          Mat%cbd, trafol=trafol, trafor=trafor, &
                          errst=errst)
              !if(prop_error('square_sr_matrix_tensorc: '//&
              !              'square failed.', 'MPOOps_include.f90:2030', &
              !              errst=errst)) return
          end do
      end do

  end subroutine square_sr_matrix_tensorc

MPOOps_f90.square_sr_matrix_qtensor()

fortran-subroutine - May 2017 (dj, updated) Find a sparse MPOm representation of the square of H using the matrix direct product.

Arguments

MatsqTYPE(sr_matrix_qtensor), inout

On exit, the square of the original MPO matrix.

MatTYPE(sr_matrix_qtensor), inout

The MPO matrix to be squared.

trafolCHARACTER, OPTIONAL, inout

Transformation on the left matrix.

traforCHARACTER, OPTIONAL, inout

Transformation on the right matrix.

Source Code

show / hide f90 code

  subroutine square_sr_matrix_qtensor(Matsq, Mat, trafol, trafor, &
                                              errst)
      type(sr_matrix_qtensor), intent(inout) :: Matsq
      type(sr_matrix_qtensor), intent(inout) :: Mat
      character, intent(in), optional :: trafol, trafor
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii, jj, kk

      !if(present(errst)) errst = 0

      ! Get dimensions and allocate rows
      Matsq%rbd = Mat%rbd**2
      Matsq%cbd = Mat%cbd**2
      allocate(Matsq%Row(Matsq%rbd))

      ! Loop over all rows

      kk = 0
      do ii = 1, Mat%rbd
          do jj = 1, Mat%rbd
              kk = kk + 1

              call square(Matsq%Row(kk), Mat%Row(ii), Mat%Row(jj), &
                          Mat%cbd, trafol=trafol, trafor=trafor, &
                          errst=errst)
              !if(prop_error('square_sr_matrix_qtensor: '//&
              !              'square failed.', 'MPOOps_include.f90:2030', &
              !              errst=errst)) return
          end do
      end do

  end subroutine square_sr_matrix_qtensor

MPOOps_f90.square_sr_matrix_qtensorc()

fortran-subroutine - May 2017 (dj, updated) Find a sparse MPOm representation of the square of H using the matrix direct product.

Arguments

MatsqTYPE(sr_matrix_qtensorc), inout

On exit, the square of the original MPO matrix.

MatTYPE(sr_matrix_qtensorc), inout

The MPO matrix to be squared.

trafolCHARACTER, OPTIONAL, inout

Transformation on the left matrix.

traforCHARACTER, OPTIONAL, inout

Transformation on the right matrix.

Source Code

show / hide f90 code

  subroutine square_sr_matrix_qtensorc(Matsq, Mat, trafol, trafor, &
                                              errst)
      type(sr_matrix_qtensorc), intent(inout) :: Matsq
      type(sr_matrix_qtensorc), intent(inout) :: Mat
      character, intent(in), optional :: trafol, trafor
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii, jj, kk

      !if(present(errst)) errst = 0

      ! Get dimensions and allocate rows
      Matsq%rbd = Mat%rbd**2
      Matsq%cbd = Mat%cbd**2
      allocate(Matsq%Row(Matsq%rbd))

      ! Loop over all rows

      kk = 0
      do ii = 1, Mat%rbd
          do jj = 1, Mat%rbd
              kk = kk + 1

              call square(Matsq%Row(kk), Mat%Row(ii), Mat%Row(jj), &
                          Mat%cbd, trafol=trafol, trafor=trafor, &
                          errst=errst)
              !if(prop_error('square_sr_matrix_qtensorc: '//&
              !              'square failed.', 'MPOOps_include.f90:2030', &
              !              errst=errst)) return
          end do
      end do

  end subroutine square_sr_matrix_qtensorc

MPOOps_f90.construct_two_site_mpo_matrix_mpo()

fortran-subroutine - July 2017 (dj) Construct all nearest-neighbor two site MPO matrices.

Arguments

HtsTYPE(sr_matrix_tensor)(*), inout

On exit allocated array of (ll - 1) nearest-neighbor two-site MPO matrices.

HamTYPE(mpo), inout

Ham represents the MPO from which the two site MPO matrices are built.

Source Code

show / hide f90 code

  subroutine construct_two_site_mpo_matrix_mpo(Hts, Ham, errst)
      type(sr_matrix_tensor), dimension(:), allocatable, &
                                                 intent(inout) :: Hts
      type(mpo), intent(inout) :: Ham
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      !if(present(errst)) errst = 0

      allocate(Hts(Ham%ll - 1))

      do ii = 1, (Ham%ll - 1)
          call sdot(Hts(ii), Ham%Ws(ii), Ham%Ws(ii + 1))
      end do

  end subroutine construct_two_site_mpo_matrix_mpo

MPOOps_f90.construct_two_site_mpo_matrix_mpoc()

fortran-subroutine - July 2017 (dj) Construct all nearest-neighbor two site MPO matrices.

Arguments

HtsTYPE(sr_matrix_tensorc)(*), inout

On exit allocated array of (ll - 1) nearest-neighbor two-site MPO matrices.

HamTYPE(mpoc), inout

Ham represents the MPO from which the two site MPO matrices are built.

Source Code

show / hide f90 code

  subroutine construct_two_site_mpo_matrix_mpoc(Hts, Ham, errst)
      type(sr_matrix_tensorc), dimension(:), allocatable, &
                                                 intent(inout) :: Hts
      type(mpoc), intent(inout) :: Ham
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      !if(present(errst)) errst = 0

      allocate(Hts(Ham%ll - 1))

      do ii = 1, (Ham%ll - 1)
          call sdot(Hts(ii), Ham%Ws(ii), Ham%Ws(ii + 1))
      end do

  end subroutine construct_two_site_mpo_matrix_mpoc

MPOOps_f90.construct_two_site_mpo_matrix_qmpo()

fortran-subroutine - July 2017 (dj) Construct all nearest-neighbor two site MPO matrices.

Arguments

HtsTYPE(sr_matrix_qtensor)(*), inout

On exit allocated array of (ll - 1) nearest-neighbor two-site MPO matrices.

HamTYPE(qmpo), inout

Ham represents the MPO from which the two site MPO matrices are built.

Source Code

show / hide f90 code

  subroutine construct_two_site_mpo_matrix_qmpo(Hts, Ham, errst)
      type(sr_matrix_qtensor), dimension(:), allocatable, &
                                                 intent(inout) :: Hts
      type(qmpo), intent(inout) :: Ham
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      !if(present(errst)) errst = 0

      allocate(Hts(Ham%ll - 1))

      do ii = 1, (Ham%ll - 1)
          call sdot(Hts(ii), Ham%Ws(ii), Ham%Ws(ii + 1))
      end do

  end subroutine construct_two_site_mpo_matrix_qmpo

MPOOps_f90.construct_two_site_mpo_matrix_qmpoc()

fortran-subroutine - July 2017 (dj) Construct all nearest-neighbor two site MPO matrices.

Arguments

HtsTYPE(sr_matrix_qtensorc)(*), inout

On exit allocated array of (ll - 1) nearest-neighbor two-site MPO matrices.

HamTYPE(qmpoc), inout

Ham represents the MPO from which the two site MPO matrices are built.

Source Code

show / hide f90 code

  subroutine construct_two_site_mpo_matrix_qmpoc(Hts, Ham, errst)
      type(sr_matrix_qtensorc), dimension(:), allocatable, &
                                                 intent(inout) :: Hts
      type(qmpoc), intent(inout) :: Ham
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      !if(present(errst)) errst = 0

      allocate(Hts(Ham%ll - 1))

      do ii = 1, (Ham%ll - 1)
          call sdot(Hts(ii), Ham%Ws(ii), Ham%Ws(ii + 1))
      end do

  end subroutine construct_two_site_mpo_matrix_qmpoc

MPOOps_f90.destroy_two_site_mpo_matrix_mpo()

fortran-subroutine - July 2017 (dj) Destroy all two site MPO matrices.

Arguments

HtsTYPE(sr_matrix_tensor)(*), inout

Deallocate array of (ll - 1) nearest-neighbor two-site MPO matrices.

Source Code

show / hide f90 code

  subroutine destroy_two_site_mpo_matrix_mpo(Hts)
      type(sr_matrix_tensor), dimension(:), allocatable, &
                                                 intent(inout) :: Hts

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

      ! for looping
      integer :: ii

      do ii = 1, size(Hts)
          call destroy(Hts(ii))
      end do

      deallocate(Hts)

  end subroutine destroy_two_site_mpo_matrix_mpo

MPOOps_f90.destroy_two_site_mpo_matrix_mpoc()

fortran-subroutine - July 2017 (dj) Destroy all two site MPO matrices.

Arguments

HtsTYPE(sr_matrix_tensorc)(*), inout

Deallocate array of (ll - 1) nearest-neighbor two-site MPO matrices.

Source Code

show / hide f90 code

  subroutine destroy_two_site_mpo_matrix_mpoc(Hts)
      type(sr_matrix_tensorc), dimension(:), allocatable, &
                                                 intent(inout) :: Hts

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

      ! for looping
      integer :: ii

      do ii = 1, size(Hts)
          call destroy(Hts(ii))
      end do

      deallocate(Hts)

  end subroutine destroy_two_site_mpo_matrix_mpoc

MPOOps_f90.destroy_two_site_mpo_matrix_qmpo()

fortran-subroutine - July 2017 (dj) Destroy all two site MPO matrices.

Arguments

HtsTYPE(sr_matrix_qtensor)(*), inout

Deallocate array of (ll - 1) nearest-neighbor two-site MPO matrices.

Source Code

show / hide f90 code

  subroutine destroy_two_site_mpo_matrix_qmpo(Hts)
      type(sr_matrix_qtensor), dimension(:), allocatable, &
                                                 intent(inout) :: Hts

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

      ! for looping
      integer :: ii

      do ii = 1, size(Hts)
          call destroy(Hts(ii))
      end do

      deallocate(Hts)

  end subroutine destroy_two_site_mpo_matrix_qmpo

MPOOps_f90.destroy_two_site_mpo_matrix_qmpoc()

fortran-subroutine - July 2017 (dj) Destroy all two site MPO matrices.

Arguments

HtsTYPE(sr_matrix_qtensorc)(*), inout

Deallocate array of (ll - 1) nearest-neighbor two-site MPO matrices.

Source Code

show / hide f90 code

  subroutine destroy_two_site_mpo_matrix_qmpoc(Hts)
      type(sr_matrix_qtensorc), dimension(:), allocatable, &
                                                 intent(inout) :: Hts

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

      ! for looping
      integer :: ii

      do ii = 1, size(Hts)
          call destroy(Hts(ii))
      end do

      deallocate(Hts)

  end subroutine destroy_two_site_mpo_matrix_qmpoc

MPOOps_f90.destroy_mpo()

fortran-subroutine - May 2017 (dj, updated) Deallocate/destroy an MPO.

Arguments

ObjTYPE(mpo), inout

On exit, all variables are deallocated.

Source Code

show / hide f90 code

  subroutine destroy_mpo(Obj)
      type(mpo), intent(inout) :: Obj

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

      ! for looping
      integer :: ii

      if(Obj%ti) then
          ! Translational invariant

          ! null pointers first
          do ii = 1, Obj%ll
              nullify(Obj%Ws(ii)%Row)
          end do

          ! Destroy Wl, Wb, Wr
          call destroy(Obj%Wl)
          call destroy(Obj%Wb)
          call destroy(Obj%Wr)
      else
          ! Destroy each Ws(:)

          do ii = 1, Obj%ll
              call destroy(Obj%Ws(ii))
          end do
      end if

      deallocate(Obj%Ws)
      Obj%ll = 0

  end subroutine destroy_mpo

MPOOps_f90.destroy_mpoc()

fortran-subroutine - May 2017 (dj, updated) Deallocate/destroy an MPO.

Arguments

ObjTYPE(mpoc), inout

On exit, all variables are deallocated.

Source Code

show / hide f90 code

  subroutine destroy_mpoc(Obj)
      type(mpoc), intent(inout) :: Obj

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

      ! for looping
      integer :: ii

      if(Obj%ti) then
          ! Translational invariant

          ! null pointers first
          do ii = 1, Obj%ll
              nullify(Obj%Ws(ii)%Row)
          end do

          ! Destroy Wl, Wb, Wr
          call destroy(Obj%Wl)
          call destroy(Obj%Wb)
          call destroy(Obj%Wr)
      else
          ! Destroy each Ws(:)

          do ii = 1, Obj%ll
              call destroy(Obj%Ws(ii))
          end do
      end if

      deallocate(Obj%Ws)
      Obj%ll = 0

  end subroutine destroy_mpoc

MPOOps_f90.destroy_qmpo()

fortran-subroutine - May 2017 (dj, updated) Deallocate/destroy an MPO.

Arguments

ObjTYPE(qmpo), inout

On exit, all variables are deallocated.

Source Code

show / hide f90 code

  subroutine destroy_qmpo(Obj)
      type(qmpo), intent(inout) :: Obj

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

      ! for looping
      integer :: ii

      if(Obj%ti) then
          ! Translational invariant

          ! null pointers first
          do ii = 1, Obj%ll
              nullify(Obj%Ws(ii)%Row)
          end do

          ! Destroy Wl, Wb, Wr
          call destroy(Obj%Wl)
          call destroy(Obj%Wb)
          call destroy(Obj%Wr)
      else
          ! Destroy each Ws(:)

          do ii = 1, Obj%ll
              call destroy(Obj%Ws(ii))
          end do
      end if

      deallocate(Obj%Ws)
      Obj%ll = 0

  end subroutine destroy_qmpo

MPOOps_f90.destroy_qmpoc()

fortran-subroutine - May 2017 (dj, updated) Deallocate/destroy an MPO.

Arguments

ObjTYPE(qmpoc), inout

On exit, all variables are deallocated.

Source Code

show / hide f90 code

  subroutine destroy_qmpoc(Obj)
      type(qmpoc), intent(inout) :: Obj

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

      ! for looping
      integer :: ii

      if(Obj%ti) then
          ! Translational invariant

          ! null pointers first
          do ii = 1, Obj%ll
              nullify(Obj%Ws(ii)%Row)
          end do

          ! Destroy Wl, Wb, Wr
          call destroy(Obj%Wl)
          call destroy(Obj%Wb)
          call destroy(Obj%Wr)
      else
          ! Destroy each Ws(:)

          do ii = 1, Obj%ll
              call destroy(Obj%Ws(ii))
          end do
      end if

      deallocate(Obj%Ws)
      Obj%ll = 0

  end subroutine destroy_qmpoc

MPOOps_f90.set_hash_mpo()

fortran-subroutine - October 2017 (dj) Set the hashes in an MPO iff it has symmetries according to the given indices.

Arguments

ObjTYPE(mpo), inout

Is MPO. On exit, the hashes will be set on each operator with symmetries in the complete MPO.

idxsINTEGER(*), in

Specify indices to be hashed in regard to the legs of the tensor.

Source Code

show / hide f90 code

  subroutine set_hash_mpo(Obj, idxs, errst)
      type(mpo), intent(inout) :: Obj
      integer, dimension(:), intent(in) :: idxs
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      !if(present(errst)) errst = 0

      if(Obj%ti) then
          ! Translational invariant, just act on Wl, Wb, Wr

          call set_hash(Obj%Wl, idxs, errst=errst)
          !if(prop_error('set_hash_mpo : set_hash failed.', &
          !              'MPOOps_include.f90:2400', errst=errst)) return

          call set_hash(Obj%Wb, idxs, errst=errst)
          !if(prop_error('set_hash_mpo : set_hash failed.', &
          !              'MPOOps_include.f90:2404', errst=errst)) return

          call set_hash(Obj%Wr, idxs, errst=errst)
          !if(prop_error('set_hash_mpo : set_hash failed.', &
          !              'MPOOps_include.f90:2408', errst=errst)) return

      else
          ! Act on each entry in array Ws(:)

          do ii = 1, Obj%ll
              call set_hash(Obj%Ws(ii), idxs, errst=errst)
              !if(prop_error('set_hash_mpo : set_hash failed.', &
              !              'MPOOps_include.f90:2416', errst=errst)) return
          end do

      end if

  end subroutine set_hash_mpo

MPOOps_f90.set_hash_mpoc()

fortran-subroutine - October 2017 (dj) Set the hashes in an MPO iff it has symmetries according to the given indices.

Arguments

ObjTYPE(mpoc), inout

Is MPO. On exit, the hashes will be set on each operator with symmetries in the complete MPO.

idxsINTEGER(*), in

Specify indices to be hashed in regard to the legs of the tensor.

Source Code

show / hide f90 code

  subroutine set_hash_mpoc(Obj, idxs, errst)
      type(mpoc), intent(inout) :: Obj
      integer, dimension(:), intent(in) :: idxs
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      !if(present(errst)) errst = 0

      if(Obj%ti) then
          ! Translational invariant, just act on Wl, Wb, Wr

          call set_hash(Obj%Wl, idxs, errst=errst)
          !if(prop_error('set_hash_mpoc : set_hash failed.', &
          !              'MPOOps_include.f90:2400', errst=errst)) return

          call set_hash(Obj%Wb, idxs, errst=errst)
          !if(prop_error('set_hash_mpoc : set_hash failed.', &
          !              'MPOOps_include.f90:2404', errst=errst)) return

          call set_hash(Obj%Wr, idxs, errst=errst)
          !if(prop_error('set_hash_mpoc : set_hash failed.', &
          !              'MPOOps_include.f90:2408', errst=errst)) return

      else
          ! Act on each entry in array Ws(:)

          do ii = 1, Obj%ll
              call set_hash(Obj%Ws(ii), idxs, errst=errst)
              !if(prop_error('set_hash_mpoc : set_hash failed.', &
              !              'MPOOps_include.f90:2416', errst=errst)) return
          end do

      end if

  end subroutine set_hash_mpoc

MPOOps_f90.set_hash_qmpo()

fortran-subroutine - October 2017 (dj) Set the hashes in an MPO iff it has symmetries according to the given indices.

Arguments

ObjTYPE(qmpo), inout

Is MPO. On exit, the hashes will be set on each operator with symmetries in the complete MPO.

idxsINTEGER(*), in

Specify indices to be hashed in regard to the legs of the tensor.

Source Code

show / hide f90 code

  subroutine set_hash_qmpo(Obj, idxs, errst)
      type(qmpo), intent(inout) :: Obj
      integer, dimension(:), intent(in) :: idxs
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      !if(present(errst)) errst = 0

      if(Obj%ti) then
          ! Translational invariant, just act on Wl, Wb, Wr

          call set_hash(Obj%Wl, idxs, errst=errst)
          !if(prop_error('set_hash_qmpo : set_hash failed.', &
          !              'MPOOps_include.f90:2400', errst=errst)) return

          call set_hash(Obj%Wb, idxs, errst=errst)
          !if(prop_error('set_hash_qmpo : set_hash failed.', &
          !              'MPOOps_include.f90:2404', errst=errst)) return

          call set_hash(Obj%Wr, idxs, errst=errst)
          !if(prop_error('set_hash_qmpo : set_hash failed.', &
          !              'MPOOps_include.f90:2408', errst=errst)) return

      else
          ! Act on each entry in array Ws(:)

          do ii = 1, Obj%ll
              call set_hash(Obj%Ws(ii), idxs, errst=errst)
              !if(prop_error('set_hash_qmpo : set_hash failed.', &
              !              'MPOOps_include.f90:2416', errst=errst)) return
          end do

      end if

  end subroutine set_hash_qmpo

MPOOps_f90.set_hash_qmpoc()

fortran-subroutine - October 2017 (dj) Set the hashes in an MPO iff it has symmetries according to the given indices.

Arguments

ObjTYPE(qmpoc), inout

Is MPO. On exit, the hashes will be set on each operator with symmetries in the complete MPO.

idxsINTEGER(*), in

Specify indices to be hashed in regard to the legs of the tensor.

Source Code

show / hide f90 code

  subroutine set_hash_qmpoc(Obj, idxs, errst)
      type(qmpoc), intent(inout) :: Obj
      integer, dimension(:), intent(in) :: idxs
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      !if(present(errst)) errst = 0

      if(Obj%ti) then
          ! Translational invariant, just act on Wl, Wb, Wr

          call set_hash(Obj%Wl, idxs, errst=errst)
          !if(prop_error('set_hash_qmpoc : set_hash failed.', &
          !              'MPOOps_include.f90:2400', errst=errst)) return

          call set_hash(Obj%Wb, idxs, errst=errst)
          !if(prop_error('set_hash_qmpoc : set_hash failed.', &
          !              'MPOOps_include.f90:2404', errst=errst)) return

          call set_hash(Obj%Wr, idxs, errst=errst)
          !if(prop_error('set_hash_qmpoc : set_hash failed.', &
          !              'MPOOps_include.f90:2408', errst=errst)) return

      else
          ! Act on each entry in array Ws(:)

          do ii = 1, Obj%ll
              call set_hash(Obj%Ws(ii), idxs, errst=errst)
              !if(prop_error('set_hash_qmpoc : set_hash failed.', &
              !              'MPOOps_include.f90:2416', errst=errst)) return
          end do

      end if

  end subroutine set_hash_qmpoc

MPOOps_f90.set_timpo_pointers_mpo()

fortran-subroutine - May 2017 (dj, updated) Set the pointers for the MPO-matrix of each site for a translational invariant MPO.

Arguments

ObjTYPE(mpo), inout

Set the pointers in this MPO.

Source Code

show / hide f90 code

  subroutine set_timpo_pointers_mpo(Obj)
      type(mpo), intent(inout) :: Obj

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

      ! for looping
      integer :: ii

      ! left MPO matrix
      Obj%Ws(1)%rbd = Obj%Wl%rbd
      Obj%Ws(1)%cbd = Obj%Wl%cbd
      Obj%Ws(1)%Row => Obj%Wl%Row

      ! bulk MPO matrices
      do ii = 2, (Obj%ll - 1)
          Obj%Ws(ii)%rbd = Obj%Wb%rbd
          Obj%Ws(ii)%cbd = Obj%Wb%cbd
          Obj%Ws(ii)%Row => Obj%Wb%Row
      end do

      ! right MPO matrix
      Obj%Ws(Obj%ll)%rbd = Obj%Wr%rbd
      Obj%Ws(Obj%ll)%cbd = Obj%Wr%cbd
      Obj%Ws(Obj%ll)%Row => Obj%Wr%Row

  end subroutine set_timpo_pointers_mpo

MPOOps_f90.shift_mpo()

fortran-subroutine - May 2017 (dj, updated) Transform the MPO H to the representation (H - shift).

Arguments

ObjTYPE(mpo), inout

MPO to be shifted. Shifted on exit.

shREAL, in

Apply this shift sh to the MPO.

Source Code

show / hide f90 code

  subroutine shift_mpo(Obj, sh)
      type(mpo), intent(inout) :: Obj
      real(KIND=rKind), intent(in) :: sh

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

      ! for looping
      integer :: ii

      if(Obj%ti) then
          ! Translational invariant, just shift Wl, Wb, Wr

          call shift(Obj%Wl, sh / Obj%ll)
          call shift(Obj%Wb, sh / Obj%ll)
          call shift(Obj%Wr, sh / Obj%ll)
      else
          ! Shift each entry in Ws(:)

          do ii = 1, Obj%ll
              call shift(Obj%Ws(ii), sh / Obj%ll)
          end do
      end if

  end subroutine shift_mpo

MPOOps_f90.shiftandsquare_mpo()

fortran-subroutine - May 2017 (dj, updated) Find a sparse MPO representation of the square of (H - shift) using the matrix direct product.

Arguments

ObjsqTYPE(mpo), inout

On exit, the MPO shifted and squared.

ObjTYPE(mpo), inout

MPO to be shifted and squared.

shREAL, in

The negative shift sh applied to the MPO.

Source Code

show / hide f90 code

  subroutine shiftandsquare_mpo(Objsq, Obj, sh)
      type(mpo), intent(inout) :: Objsq
      type(mpo), intent(inout) :: Obj
      real(KIND=rKind), intent(in) :: sh

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

      ! for looping
      integer :: ii

      ! scaled shift
      real(KIND=rKind) :: scaledsh

      Objsq%ti = Obj%ti
      Objsq%ll = Obj%ll
      allocate(Objsq%Ws(Objsq%ll))

      scaledsh = sh / (1.0_rKind * Obj%ll)

      if(Objsq%ti) then
          ! Translational invariant: calculate Wl, Wb, Wr; set pointers

          call shiftandsquare(Objsq%Wl, Obj%Wl, scaledsh)
          call shiftandsquare(Objsq%Wb, Obj%Wb, scaledsh)
          call shiftandsquare(Objsq%Wr, Obj%Wr, scaledsh)

          call set_timpo_pointers(Objsq)
      else
          ! Operate on each entry of Ws(:)

          do ii = 1, Objsq%ll
              call shiftandsquare(Objsq%Ws(ii), Obj%Ws(ii), scaledsh)
          end do
      end if

  end subroutine shiftandsquare_mpo

MPOOps_f90.square_mpo()

fortran-subroutine - May 2017 (dj, updated) Square an MPO. The bond dimension on each link squares as well.

Arguments

ObjsqTYPE(mpo), inout

On exit, the squared MPO of Obj using the direct product.

ObjTYPE(mpo), inout

MPO to be squared.

trafolCHARACTER, OPTIONAL, inout

Transformation on the left matrix.

traforCHARACTER, OPTIONAL, inout

Transformation on the right matrix.

Source Code

show / hide f90 code

  subroutine square_mpo(Objsq, Obj, trafol, trafor, errst)
      type(mpo), intent(inout) :: Objsq
      type(mpo), intent(inout) :: Obj
      character, intent(in), optional :: trafol, trafor
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      !if(present(errst)) errst = 0

      Objsq%ti = Obj%ti
      Objsq%ll = Obj%ll
      allocate(Objsq%Ws(Objsq%ll))

      if(Obj%ti) then
          ! Tranlational invariant: only square Wl, Wb, Wr; point to them

          ! Get squares
          call square(Objsq%Wl, Obj%Wl, trafol=trafol, trafor=trafor, &
                      errst=errst)
          !if(prop_error('square_mpo: square failed.', &
          !              'MPOOps_include.f90:2645', errst=errst)) return

          call square(Objsq%Wb, Obj%Wb, trafol=trafol, trafor=trafor, &
                      errst=errst)
          !if(prop_error('square_mpo: square failed.', &
          !              'MPOOps_include.f90:2650', errst=errst)) return

          call square(Objsq%Wr, Obj%Wr, trafol=trafol, trafor=trafor, &
                      errst=errst)
          !if(prop_error('square_mpo: square failed.', &
          !              'MPOOps_include.f90:2655', errst=errst)) return

          ! Point Ws to them
          call set_timpo_pointers(Objsq)

      else
          ! Calculate each MPO matrix on its own

          do ii = 1, Objsq%ll
              call square(Objsq%Ws(ii), Obj%Ws(ii), trafol=trafol, &
                          trafor=trafor, errst=errst)
          !if(prop_error('square_mpo: square failed.', &
          !              'MPOOps_include.f90:2667', errst=errst)) return
          end do
      end if

  end subroutine square_mpo

MPOOps_f90.set_timpo_pointers_mpoc()

fortran-subroutine - May 2017 (dj, updated) Set the pointers for the MPO-matrix of each site for a translational invariant MPO.

Arguments

ObjTYPE(mpoc), inout

Set the pointers in this MPO.

Source Code

show / hide f90 code

  subroutine set_timpo_pointers_mpoc(Obj)
      type(mpoc), intent(inout) :: Obj

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

      ! for looping
      integer :: ii

      ! left MPO matrix
      Obj%Ws(1)%rbd = Obj%Wl%rbd
      Obj%Ws(1)%cbd = Obj%Wl%cbd
      Obj%Ws(1)%Row => Obj%Wl%Row

      ! bulk MPO matrices
      do ii = 2, (Obj%ll - 1)
          Obj%Ws(ii)%rbd = Obj%Wb%rbd
          Obj%Ws(ii)%cbd = Obj%Wb%cbd
          Obj%Ws(ii)%Row => Obj%Wb%Row
      end do

      ! right MPO matrix
      Obj%Ws(Obj%ll)%rbd = Obj%Wr%rbd
      Obj%Ws(Obj%ll)%cbd = Obj%Wr%cbd
      Obj%Ws(Obj%ll)%Row => Obj%Wr%Row

  end subroutine set_timpo_pointers_mpoc

MPOOps_f90.shift_mpoc()

fortran-subroutine - May 2017 (dj, updated) Transform the MPO H to the representation (H - shift).

Arguments

ObjTYPE(mpoc), inout

MPO to be shifted. Shifted on exit.

shREAL, in

Apply this shift sh to the MPO.

Source Code

show / hide f90 code

  subroutine shift_mpoc(Obj, sh)
      type(mpoc), intent(inout) :: Obj
      real(KIND=rKind), intent(in) :: sh

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

      ! for looping
      integer :: ii

      if(Obj%ti) then
          ! Translational invariant, just shift Wl, Wb, Wr

          call shift(Obj%Wl, sh / Obj%ll)
          call shift(Obj%Wb, sh / Obj%ll)
          call shift(Obj%Wr, sh / Obj%ll)
      else
          ! Shift each entry in Ws(:)

          do ii = 1, Obj%ll
              call shift(Obj%Ws(ii), sh / Obj%ll)
          end do
      end if

  end subroutine shift_mpoc

MPOOps_f90.shiftandsquare_mpoc()

fortran-subroutine - May 2017 (dj, updated) Find a sparse MPO representation of the square of (H - shift) using the matrix direct product.

Arguments

ObjsqTYPE(mpoc), inout

On exit, the MPO shifted and squared.

ObjTYPE(mpoc), inout

MPO to be shifted and squared.

shREAL, in

The negative shift sh applied to the MPO.

Source Code

show / hide f90 code

  subroutine shiftandsquare_mpoc(Objsq, Obj, sh)
      type(mpoc), intent(inout) :: Objsq
      type(mpoc), intent(inout) :: Obj
      real(KIND=rKind), intent(in) :: sh

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

      ! for looping
      integer :: ii

      ! scaled shift
      real(KIND=rKind) :: scaledsh

      Objsq%ti = Obj%ti
      Objsq%ll = Obj%ll
      allocate(Objsq%Ws(Objsq%ll))

      scaledsh = sh / (1.0_rKind * Obj%ll)

      if(Objsq%ti) then
          ! Translational invariant: calculate Wl, Wb, Wr; set pointers

          call shiftandsquare(Objsq%Wl, Obj%Wl, scaledsh)
          call shiftandsquare(Objsq%Wb, Obj%Wb, scaledsh)
          call shiftandsquare(Objsq%Wr, Obj%Wr, scaledsh)

          call set_timpo_pointers(Objsq)
      else
          ! Operate on each entry of Ws(:)

          do ii = 1, Objsq%ll
              call shiftandsquare(Objsq%Ws(ii), Obj%Ws(ii), scaledsh)
          end do
      end if

  end subroutine shiftandsquare_mpoc

MPOOps_f90.square_mpoc()

fortran-subroutine - May 2017 (dj, updated) Square an MPO. The bond dimension on each link squares as well.

Arguments

ObjsqTYPE(mpoc), inout

On exit, the squared MPO of Obj using the direct product.

ObjTYPE(mpoc), inout

MPO to be squared.

trafolCHARACTER, OPTIONAL, inout

Transformation on the left matrix.

traforCHARACTER, OPTIONAL, inout

Transformation on the right matrix.

Source Code

show / hide f90 code

  subroutine square_mpoc(Objsq, Obj, trafol, trafor, errst)
      type(mpoc), intent(inout) :: Objsq
      type(mpoc), intent(inout) :: Obj
      character, intent(in), optional :: trafol, trafor
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      !if(present(errst)) errst = 0

      Objsq%ti = Obj%ti
      Objsq%ll = Obj%ll
      allocate(Objsq%Ws(Objsq%ll))

      if(Obj%ti) then
          ! Tranlational invariant: only square Wl, Wb, Wr; point to them

          ! Get squares
          call square(Objsq%Wl, Obj%Wl, trafol=trafol, trafor=trafor, &
                      errst=errst)
          !if(prop_error('square_mpoc: square failed.', &
          !              'MPOOps_include.f90:2645', errst=errst)) return

          call square(Objsq%Wb, Obj%Wb, trafol=trafol, trafor=trafor, &
                      errst=errst)
          !if(prop_error('square_mpoc: square failed.', &
          !              'MPOOps_include.f90:2650', errst=errst)) return

          call square(Objsq%Wr, Obj%Wr, trafol=trafol, trafor=trafor, &
                      errst=errst)
          !if(prop_error('square_mpoc: square failed.', &
          !              'MPOOps_include.f90:2655', errst=errst)) return

          ! Point Ws to them
          call set_timpo_pointers(Objsq)

      else
          ! Calculate each MPO matrix on its own

          do ii = 1, Objsq%ll
              call square(Objsq%Ws(ii), Obj%Ws(ii), trafol=trafol, &
                          trafor=trafor, errst=errst)
          !if(prop_error('square_mpoc: square failed.', &
          !              'MPOOps_include.f90:2667', errst=errst)) return
          end do
      end if

  end subroutine square_mpoc

MPOOps_f90.set_timpo_pointers_qmpo()

fortran-subroutine - May 2017 (dj, updated) Set the pointers for the MPO-matrix of each site for a translational invariant MPO.

Arguments

ObjTYPE(qmpo), inout

Set the pointers in this MPO.

Source Code

show / hide f90 code

  subroutine set_timpo_pointers_qmpo(Obj)
      type(qmpo), intent(inout) :: Obj

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

      ! for looping
      integer :: ii

      ! left MPO matrix
      Obj%Ws(1)%rbd = Obj%Wl%rbd
      Obj%Ws(1)%cbd = Obj%Wl%cbd
      Obj%Ws(1)%Row => Obj%Wl%Row

      ! bulk MPO matrices
      do ii = 2, (Obj%ll - 1)
          Obj%Ws(ii)%rbd = Obj%Wb%rbd
          Obj%Ws(ii)%cbd = Obj%Wb%cbd
          Obj%Ws(ii)%Row => Obj%Wb%Row
      end do

      ! right MPO matrix
      Obj%Ws(Obj%ll)%rbd = Obj%Wr%rbd
      Obj%Ws(Obj%ll)%cbd = Obj%Wr%cbd
      Obj%Ws(Obj%ll)%Row => Obj%Wr%Row

  end subroutine set_timpo_pointers_qmpo

MPOOps_f90.shift_qmpo()

fortran-subroutine - May 2017 (dj, updated) Transform the MPO H to the representation (H - shift).

Arguments

ObjTYPE(qmpo), inout

MPO to be shifted. Shifted on exit.

shREAL, in

Apply this shift sh to the MPO.

Source Code

show / hide f90 code

  subroutine shift_qmpo(Obj, sh)
      type(qmpo), intent(inout) :: Obj
      real(KIND=rKind), intent(in) :: sh

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

      ! for looping
      integer :: ii

      if(Obj%ti) then
          ! Translational invariant, just shift Wl, Wb, Wr

          call shift(Obj%Wl, sh / Obj%ll)
          call shift(Obj%Wb, sh / Obj%ll)
          call shift(Obj%Wr, sh / Obj%ll)
      else
          ! Shift each entry in Ws(:)

          do ii = 1, Obj%ll
              call shift(Obj%Ws(ii), sh / Obj%ll)
          end do
      end if

  end subroutine shift_qmpo

MPOOps_f90.shiftandsquare_qmpo()

fortran-subroutine - May 2017 (dj, updated) Find a sparse MPO representation of the square of (H - shift) using the matrix direct product.

Arguments

ObjsqTYPE(qmpo), inout

On exit, the MPO shifted and squared.

ObjTYPE(qmpo), inout

MPO to be shifted and squared.

shREAL, in

The negative shift sh applied to the MPO.

Source Code

show / hide f90 code

  subroutine shiftandsquare_qmpo(Objsq, Obj, sh)
      type(qmpo), intent(inout) :: Objsq
      type(qmpo), intent(inout) :: Obj
      real(KIND=rKind), intent(in) :: sh

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

      ! for looping
      integer :: ii

      ! scaled shift
      real(KIND=rKind) :: scaledsh

      Objsq%ti = Obj%ti
      Objsq%ll = Obj%ll
      allocate(Objsq%Ws(Objsq%ll))

      scaledsh = sh / (1.0_rKind * Obj%ll)

      if(Objsq%ti) then
          ! Translational invariant: calculate Wl, Wb, Wr; set pointers

          call shiftandsquare(Objsq%Wl, Obj%Wl, scaledsh)
          call shiftandsquare(Objsq%Wb, Obj%Wb, scaledsh)
          call shiftandsquare(Objsq%Wr, Obj%Wr, scaledsh)

          call set_timpo_pointers(Objsq)
      else
          ! Operate on each entry of Ws(:)

          do ii = 1, Objsq%ll
              call shiftandsquare(Objsq%Ws(ii), Obj%Ws(ii), scaledsh)
          end do
      end if

  end subroutine shiftandsquare_qmpo

MPOOps_f90.square_qmpo()

fortran-subroutine - May 2017 (dj, updated) Square an MPO. The bond dimension on each link squares as well.

Arguments

ObjsqTYPE(qmpo), inout

On exit, the squared MPO of Obj using the direct product.

ObjTYPE(qmpo), inout

MPO to be squared.

trafolCHARACTER, OPTIONAL, inout

Transformation on the left matrix.

traforCHARACTER, OPTIONAL, inout

Transformation on the right matrix.

Source Code

show / hide f90 code

  subroutine square_qmpo(Objsq, Obj, trafol, trafor, errst)
      type(qmpo), intent(inout) :: Objsq
      type(qmpo), intent(inout) :: Obj
      character, intent(in), optional :: trafol, trafor
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      !if(present(errst)) errst = 0

      Objsq%ti = Obj%ti
      Objsq%ll = Obj%ll
      allocate(Objsq%Ws(Objsq%ll))

      if(Obj%ti) then
          ! Tranlational invariant: only square Wl, Wb, Wr; point to them

          ! Get squares
          call square(Objsq%Wl, Obj%Wl, trafol=trafol, trafor=trafor, &
                      errst=errst)
          !if(prop_error('square_qmpo: square failed.', &
          !              'MPOOps_include.f90:2645', errst=errst)) return

          call square(Objsq%Wb, Obj%Wb, trafol=trafol, trafor=trafor, &
                      errst=errst)
          !if(prop_error('square_qmpo: square failed.', &
          !              'MPOOps_include.f90:2650', errst=errst)) return

          call square(Objsq%Wr, Obj%Wr, trafol=trafol, trafor=trafor, &
                      errst=errst)
          !if(prop_error('square_qmpo: square failed.', &
          !              'MPOOps_include.f90:2655', errst=errst)) return

          ! Point Ws to them
          call set_timpo_pointers(Objsq)

      else
          ! Calculate each MPO matrix on its own

          do ii = 1, Objsq%ll
              call square(Objsq%Ws(ii), Obj%Ws(ii), trafol=trafol, &
                          trafor=trafor, errst=errst)
          !if(prop_error('square_qmpo: square failed.', &
          !              'MPOOps_include.f90:2667', errst=errst)) return
          end do
      end if

  end subroutine square_qmpo

MPOOps_f90.set_timpo_pointers_qmpoc()

fortran-subroutine - May 2017 (dj, updated) Set the pointers for the MPO-matrix of each site for a translational invariant MPO.

Arguments

ObjTYPE(qmpoc), inout

Set the pointers in this MPO.

Source Code

show / hide f90 code

  subroutine set_timpo_pointers_qmpoc(Obj)
      type(qmpoc), intent(inout) :: Obj

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

      ! for looping
      integer :: ii

      ! left MPO matrix
      Obj%Ws(1)%rbd = Obj%Wl%rbd
      Obj%Ws(1)%cbd = Obj%Wl%cbd
      Obj%Ws(1)%Row => Obj%Wl%Row

      ! bulk MPO matrices
      do ii = 2, (Obj%ll - 1)
          Obj%Ws(ii)%rbd = Obj%Wb%rbd
          Obj%Ws(ii)%cbd = Obj%Wb%cbd
          Obj%Ws(ii)%Row => Obj%Wb%Row
      end do

      ! right MPO matrix
      Obj%Ws(Obj%ll)%rbd = Obj%Wr%rbd
      Obj%Ws(Obj%ll)%cbd = Obj%Wr%cbd
      Obj%Ws(Obj%ll)%Row => Obj%Wr%Row

  end subroutine set_timpo_pointers_qmpoc

MPOOps_f90.shift_qmpoc()

fortran-subroutine - May 2017 (dj, updated) Transform the MPO H to the representation (H - shift).

Arguments

ObjTYPE(qmpoc), inout

MPO to be shifted. Shifted on exit.

shREAL, in

Apply this shift sh to the MPO.

Source Code

show / hide f90 code

  subroutine shift_qmpoc(Obj, sh)
      type(qmpoc), intent(inout) :: Obj
      real(KIND=rKind), intent(in) :: sh

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

      ! for looping
      integer :: ii

      if(Obj%ti) then
          ! Translational invariant, just shift Wl, Wb, Wr

          call shift(Obj%Wl, sh / Obj%ll)
          call shift(Obj%Wb, sh / Obj%ll)
          call shift(Obj%Wr, sh / Obj%ll)
      else
          ! Shift each entry in Ws(:)

          do ii = 1, Obj%ll
              call shift(Obj%Ws(ii), sh / Obj%ll)
          end do
      end if

  end subroutine shift_qmpoc

MPOOps_f90.shiftandsquare_qmpoc()

fortran-subroutine - May 2017 (dj, updated) Find a sparse MPO representation of the square of (H - shift) using the matrix direct product.

Arguments

ObjsqTYPE(qmpoc), inout

On exit, the MPO shifted and squared.

ObjTYPE(qmpoc), inout

MPO to be shifted and squared.

shREAL, in

The negative shift sh applied to the MPO.

Source Code

show / hide f90 code

  subroutine shiftandsquare_qmpoc(Objsq, Obj, sh)
      type(qmpoc), intent(inout) :: Objsq
      type(qmpoc), intent(inout) :: Obj
      real(KIND=rKind), intent(in) :: sh

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

      ! for looping
      integer :: ii

      ! scaled shift
      real(KIND=rKind) :: scaledsh

      Objsq%ti = Obj%ti
      Objsq%ll = Obj%ll
      allocate(Objsq%Ws(Objsq%ll))

      scaledsh = sh / (1.0_rKind * Obj%ll)

      if(Objsq%ti) then
          ! Translational invariant: calculate Wl, Wb, Wr; set pointers

          call shiftandsquare(Objsq%Wl, Obj%Wl, scaledsh)
          call shiftandsquare(Objsq%Wb, Obj%Wb, scaledsh)
          call shiftandsquare(Objsq%Wr, Obj%Wr, scaledsh)

          call set_timpo_pointers(Objsq)
      else
          ! Operate on each entry of Ws(:)

          do ii = 1, Objsq%ll
              call shiftandsquare(Objsq%Ws(ii), Obj%Ws(ii), scaledsh)
          end do
      end if

  end subroutine shiftandsquare_qmpoc

MPOOps_f90.square_qmpoc()

fortran-subroutine - May 2017 (dj, updated) Square an MPO. The bond dimension on each link squares as well.

Arguments

ObjsqTYPE(qmpoc), inout

On exit, the squared MPO of Obj using the direct product.

ObjTYPE(qmpoc), inout

MPO to be squared.

trafolCHARACTER, OPTIONAL, inout

Transformation on the left matrix.

traforCHARACTER, OPTIONAL, inout

Transformation on the right matrix.

Source Code

show / hide f90 code

  subroutine square_qmpoc(Objsq, Obj, trafol, trafor, errst)
      type(qmpoc), intent(inout) :: Objsq
      type(qmpoc), intent(inout) :: Obj
      character, intent(in), optional :: trafol, trafor
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      !if(present(errst)) errst = 0

      Objsq%ti = Obj%ti
      Objsq%ll = Obj%ll
      allocate(Objsq%Ws(Objsq%ll))

      if(Obj%ti) then
          ! Tranlational invariant: only square Wl, Wb, Wr; point to them

          ! Get squares
          call square(Objsq%Wl, Obj%Wl, trafol=trafol, trafor=trafor, &
                      errst=errst)
          !if(prop_error('square_qmpoc: square failed.', &
          !              'MPOOps_include.f90:2645', errst=errst)) return

          call square(Objsq%Wb, Obj%Wb, trafol=trafol, trafor=trafor, &
                      errst=errst)
          !if(prop_error('square_qmpoc: square failed.', &
          !              'MPOOps_include.f90:2650', errst=errst)) return

          call square(Objsq%Wr, Obj%Wr, trafol=trafol, trafor=trafor, &
                      errst=errst)
          !if(prop_error('square_qmpoc: square failed.', &
          !              'MPOOps_include.f90:2655', errst=errst)) return

          ! Point Ws to them
          call set_timpo_pointers(Objsq)

      else
          ! Calculate each MPO matrix on its own

          do ii = 1, Objsq%ll
              call square(Objsq%Ws(ii), Obj%Ws(ii), trafol=trafol, &
                          trafor=trafor, errst=errst)
          !if(prop_error('square_qmpoc: square failed.', &
          !              'MPOOps_include.f90:2667', errst=errst)) return
          end do
      end if

  end subroutine square_qmpoc

MPOOps_f90.ruleset_to_ham_2site_tensorlist_tensor()

fortran-subroutine - May 2017 (dj, update) Extract the 2-site Hamiltonian for a Trotter decomposition from the Rule Set.

Arguments

HamTYPE(tensor), out

Contains on exit the two-site Hamiltonian as rank four tensor. The weight of the local Hamiltonians is equally 0.5 for PBC and on sites 2 .. (ll-1) for the bulk in OBC. Sites 1 and ll have weight 1.0 in OPC.

xxINTEGER, in

Get hamiltonian for sites xx, xx+1

RsTYPE(MPORuleSet), in

Contains the rule set to build up the MPO. For the 2-site Hamiltonian only site-rules and bond-rules are considered.

OpsTYPE(tensorlist), in

List containing all operators for the evolution

HparamsTYPE(HamiltonianParameters), in

containing the couplings for each operator

iopINTEGER, in

The index of the identity in the operator list.

Source Code

show / hide f90 code

  subroutine ruleset_to_ham_2site_tensorlist_tensor(Ham, xx, ll, Rs, &
       Ops, Hparams, iop, errst)
      type(tensor), intent(inout) :: Ham
      integer, intent(in) :: xx, ll
      type(MPORuleSet), intent(in) :: Rs
      type(tensorlist), intent(in) :: Ops
      type(HamiltonianParameters), pointer, intent(in) :: Hparams(:)
      integer, intent(in) :: iop
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! first index for bond rule
      integer :: i1

      ! position of the site xx+1
      integer :: xx1

      ! prefactor considering boundary effects in PBC/OPC
      real(KIND=rKind), dimension(2) :: pre

      ! temporary matrix to calculate the next hamiltonian contribution
      type(tensor) :: Tmp

      !if(present(errst)) errst = 0

      ! [local site]
      ! ------------

      if(Rs%pbc) then
          ! Periodic boundary condition - every local term appears twice
          pre = 0.5_rKind
      elseif((xx == 1) .and. (xx == ll - 1)) then
          ! Open boundary conditions - system consists of two sites
          pre = 1.0_rKind
      elseif(xx == 1) then
          ! Open boundary conditions - left border
          pre = [1.0_rKind, 0.5_rKind]
      elseif(xx == ll - 1) then
          ! Open boundary conditions - right border
          pre = [0.5_rKind, 1.0_rKind]
      else
          pre = 0.5_rKind
      end if

      if(xx + 1 > ll) then
          if(Rs%pbc .and. (xx == ll)) then
              xx1 = 1
          else
              errst = raise_error('ruleset_to_ham_2site_tensorlist_tensor'//&
                                  ' : site xx not valid.', 99, errst=errst)
              return
          end if
      else
          xx1 = xx + 1
      end if

      ! First site rule - initialize Ham
      if(Rs%nsite > 0) then
          call kron(Ham, Ops%Li(Rs%s(1)%o), Ops%Li(iop), 1, 1, 'N', 'N', 'N')
          call scale(pre(1) * Rs%S(1)%w * get_coupl(Hparams, Rs%S(1)%h, xx), Ham)

          call kron(Tmp, Ops%Li(iop), Ops%Li(Rs%s(1)%o), 1, 1, 'N', 'N', 'N')
          call gaxpy(Ham, pre(2) * Rs%S(1)%w * get_coupl(Hparams, Rs%S(1)%h, xx1), Tmp, &
                     errst=errst)
          !if(prop_error('ruleset_to_ham_2site_tensorlist_tensor'//&
          !              ' : gaxpy (1) failed.', errst=errst)) return

          call destroy(Tmp)
      end if

      do ii = 2, Rs%nsite
          call kron(Tmp, Ops%Li(Rs%s(ii)%o), Ops%Li(iop), 1, 1, 'N', 'N', 'N')
          call gaxpy(Ham, pre(1) * Rs%S(ii)%w * get_coupl(Hparams, Rs%S(ii)%h, xx), Tmp, &
                     errst=errst)
          !if(prop_error('ruleset_to_ham_2site_tensorlist_tensor'//&
          !              ' : gaxpy (2) failed.', errst=errst)) return

          call destroy(Tmp)

          call kron(Tmp, Ops%Li(iop), Ops%Li(Rs%s(ii)%o), 1, 1, 'N', 'N', 'N')
          call gaxpy(Ham, pre(2) * Rs%S(ii)%w * get_coupl(Hparams, Rs%S(ii)%h, xx1), Tmp, &
                     errst=errst)
          !if(prop_error('ruleset_to_ham_2site_tensorlist_tensor'//&
          !              ' : gaxpy (3) failed.', errst=errst)) return

          call destroy(Tmp)
      end do

      ! [bond]
      ! ------

      if((Rs%nsite == 0) .and. (Rs%nbond > 0)) then
          ! Initialize Ham
          call kron(Ham, Ops%Li(Rs%B(1)%ol), Ops%Li(Rs%B(1)%or), 1, 1, &
                    'N', 'N', 'N')
          call scale(Rs%B(1)%w * get_coupl(Hparams, Rs%B(1)%h, xx), Ham)

          i1 = 2
      else
          i1 = 1
      end if

      do ii = i1, Rs%nbond
          call kron(Tmp, Ops%Li(Rs%B(ii)%ol), Ops%Li(Rs%B(ii)%or), 1, 1, &
                    'N', 'N', 'N')
          call gaxpy(Ham, Rs%B(ii)%w * get_coupl(Hparams, Rs%B(ii)%h, xx), Tmp, &
                     errst=errst)
          !if(prop_error('ruleset_to_ham_2site_tensorlist_tensor'//&
          !              ' : gaxpy (4) failed.', errst=errst)) return

          call destroy(Tmp)
      end do

      ! For symmetric tensor, we have to add the diagonal blocks with
      ! zero values (zero block => identity in the exponential)
      if(.false.) then
          call kron(Tmp, Ops%Li(iop), Ops%Li(iop), 1, 1, 'N', 'N', 'N')
          call gaxpy(Ham, 0.0_rKind, Tmp, errst=errst)
          !if(prop_error('ruleset_to_ham_2site_tensorlist_tensor'//&
          !              ' : gaxpy (5) failed.', 'MPOOps_include.f90:2911', &
          !              errst=errst)) return

          call destroy(Tmp)
      end if

  end subroutine ruleset_to_ham_2site_tensorlist_tensor

MPOOps_f90.ruleset_to_ham_2site_tensorlist_tensorc()

fortran-subroutine - May 2017 (dj, update) Extract the 2-site Hamiltonian for a Trotter decomposition from the Rule Set.

Arguments

HamTYPE(tensorc), out

Contains on exit the two-site Hamiltonian as rank four tensor. The weight of the local Hamiltonians is equally 0.5 for PBC and on sites 2 .. (ll-1) for the bulk in OBC. Sites 1 and ll have weight 1.0 in OPC.

xxINTEGER, in

Get hamiltonian for sites xx, xx+1

RsTYPE(MPORuleSet), in

Contains the rule set to build up the MPO. For the 2-site Hamiltonian only site-rules and bond-rules are considered.

OpsTYPE(tensorlist), in

List containing all operators for the evolution

HparamsTYPE(HamiltonianParameters), in

containing the couplings for each operator

iopINTEGER, in

The index of the identity in the operator list.

Source Code

show / hide f90 code

  subroutine ruleset_to_ham_2site_tensorlist_tensorc(Ham, xx, ll, Rs, &
       Ops, Hparams, iop, errst)
      type(tensorc), intent(inout) :: Ham
      integer, intent(in) :: xx, ll
      type(MPORuleSet), intent(in) :: Rs
      type(tensorlist), intent(in) :: Ops
      type(HamiltonianParameters), pointer, intent(in) :: Hparams(:)
      integer, intent(in) :: iop
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! first index for bond rule
      integer :: i1

      ! position of the site xx+1
      integer :: xx1

      ! prefactor considering boundary effects in PBC/OPC
      real(KIND=rKind), dimension(2) :: pre

      ! temporary matrix to calculate the next hamiltonian contribution
      type(tensorc) :: Tmp

      !if(present(errst)) errst = 0

      ! [local site]
      ! ------------

      if(Rs%pbc) then
          ! Periodic boundary condition - every local term appears twice
          pre = 0.5_rKind
      elseif((xx == 1) .and. (xx == ll - 1)) then
          ! Open boundary conditions - system consists of two sites
          pre = 1.0_rKind
      elseif(xx == 1) then
          ! Open boundary conditions - left border
          pre = [1.0_rKind, 0.5_rKind]
      elseif(xx == ll - 1) then
          ! Open boundary conditions - right border
          pre = [0.5_rKind, 1.0_rKind]
      else
          pre = 0.5_rKind
      end if

      if(xx + 1 > ll) then
          if(Rs%pbc .and. (xx == ll)) then
              xx1 = 1
          else
              errst = raise_error('ruleset_to_ham_2site_tensorlist_tensorc'//&
                                  ' : site xx not valid.', 99, errst=errst)
              return
          end if
      else
          xx1 = xx + 1
      end if

      ! First site rule - initialize Ham
      if(Rs%nsite > 0) then
          call kron(Ham, Ops%Li(Rs%s(1)%o), Ops%Li(iop), 1, 1, 'N', 'N', 'N')
          call scale(pre(1) * Rs%S(1)%w * get_coupl(Hparams, Rs%S(1)%h, xx), Ham)

          call kron(Tmp, Ops%Li(iop), Ops%Li(Rs%s(1)%o), 1, 1, 'N', 'N', 'N')
          call gaxpy(Ham, pre(2) * Rs%S(1)%w * get_coupl(Hparams, Rs%S(1)%h, xx1), Tmp, &
                     errst=errst)
          !if(prop_error('ruleset_to_ham_2site_tensorlist_tensorc'//&
          !              ' : gaxpy (1) failed.', errst=errst)) return

          call destroy(Tmp)
      end if

      do ii = 2, Rs%nsite
          call kron(Tmp, Ops%Li(Rs%s(ii)%o), Ops%Li(iop), 1, 1, 'N', 'N', 'N')
          call gaxpy(Ham, pre(1) * Rs%S(ii)%w * get_coupl(Hparams, Rs%S(ii)%h, xx), Tmp, &
                     errst=errst)
          !if(prop_error('ruleset_to_ham_2site_tensorlist_tensorc'//&
          !              ' : gaxpy (2) failed.', errst=errst)) return

          call destroy(Tmp)

          call kron(Tmp, Ops%Li(iop), Ops%Li(Rs%s(ii)%o), 1, 1, 'N', 'N', 'N')
          call gaxpy(Ham, pre(2) * Rs%S(ii)%w * get_coupl(Hparams, Rs%S(ii)%h, xx1), Tmp, &
                     errst=errst)
          !if(prop_error('ruleset_to_ham_2site_tensorlist_tensorc'//&
          !              ' : gaxpy (3) failed.', errst=errst)) return

          call destroy(Tmp)
      end do

      ! [bond]
      ! ------

      if((Rs%nsite == 0) .and. (Rs%nbond > 0)) then
          ! Initialize Ham
          call kron(Ham, Ops%Li(Rs%B(1)%ol), Ops%Li(Rs%B(1)%or), 1, 1, &
                    'N', 'N', 'N')
          call scale(Rs%B(1)%w * get_coupl(Hparams, Rs%B(1)%h, xx), Ham)

          i1 = 2
      else
          i1 = 1
      end if

      do ii = i1, Rs%nbond
          call kron(Tmp, Ops%Li(Rs%B(ii)%ol), Ops%Li(Rs%B(ii)%or), 1, 1, &
                    'N', 'N', 'N')
          call gaxpy(Ham, Rs%B(ii)%w * get_coupl(Hparams, Rs%B(ii)%h, xx), Tmp, &
                     errst=errst)
          !if(prop_error('ruleset_to_ham_2site_tensorlist_tensorc'//&
          !              ' : gaxpy (4) failed.', errst=errst)) return

          call destroy(Tmp)
      end do

      ! For symmetric tensor, we have to add the diagonal blocks with
      ! zero values (zero block => identity in the exponential)
      if(.false.) then
          call kron(Tmp, Ops%Li(iop), Ops%Li(iop), 1, 1, 'N', 'N', 'N')
          call gaxpy(Ham, 0.0_rKind, Tmp, errst=errst)
          !if(prop_error('ruleset_to_ham_2site_tensorlist_tensorc'//&
          !              ' : gaxpy (5) failed.', 'MPOOps_include.f90:2911', &
          !              errst=errst)) return

          call destroy(Tmp)
      end if

  end subroutine ruleset_to_ham_2site_tensorlist_tensorc

MPOOps_f90.ruleset_to_ham_2site_tensorlistc_tensorc()

fortran-subroutine - May 2017 (dj, update) Extract the 2-site Hamiltonian for a Trotter decomposition from the Rule Set.

Arguments

HamTYPE(tensorc), out

Contains on exit the two-site Hamiltonian as rank four tensor. The weight of the local Hamiltonians is equally 0.5 for PBC and on sites 2 .. (ll-1) for the bulk in OBC. Sites 1 and ll have weight 1.0 in OPC.

xxINTEGER, in

Get hamiltonian for sites xx, xx+1

RsTYPE(MPORuleSet), in

Contains the rule set to build up the MPO. For the 2-site Hamiltonian only site-rules and bond-rules are considered.

OpsTYPE(tensorlistc), in

List containing all operators for the evolution

HparamsTYPE(HamiltonianParameters), in

containing the couplings for each operator

iopINTEGER, in

The index of the identity in the operator list.

Source Code

show / hide f90 code

  subroutine ruleset_to_ham_2site_tensorlistc_tensorc(Ham, xx, ll, Rs, &
       Ops, Hparams, iop, errst)
      type(tensorc), intent(inout) :: Ham
      integer, intent(in) :: xx, ll
      type(MPORuleSet), intent(in) :: Rs
      type(tensorlistc), intent(in) :: Ops
      type(HamiltonianParameters), pointer, intent(in) :: Hparams(:)
      integer, intent(in) :: iop
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! first index for bond rule
      integer :: i1

      ! position of the site xx+1
      integer :: xx1

      ! prefactor considering boundary effects in PBC/OPC
      real(KIND=rKind), dimension(2) :: pre

      ! temporary matrix to calculate the next hamiltonian contribution
      type(tensorc) :: Tmp

      !if(present(errst)) errst = 0

      ! [local site]
      ! ------------

      if(Rs%pbc) then
          ! Periodic boundary condition - every local term appears twice
          pre = 0.5_rKind
      elseif((xx == 1) .and. (xx == ll - 1)) then
          ! Open boundary conditions - system consists of two sites
          pre = 1.0_rKind
      elseif(xx == 1) then
          ! Open boundary conditions - left border
          pre = [1.0_rKind, 0.5_rKind]
      elseif(xx == ll - 1) then
          ! Open boundary conditions - right border
          pre = [0.5_rKind, 1.0_rKind]
      else
          pre = 0.5_rKind
      end if

      if(xx + 1 > ll) then
          if(Rs%pbc .and. (xx == ll)) then
              xx1 = 1
          else
              errst = raise_error('ruleset_to_ham_2site_tensorlistc_tensorc'//&
                                  ' : site xx not valid.', 99, errst=errst)
              return
          end if
      else
          xx1 = xx + 1
      end if

      ! First site rule - initialize Ham
      if(Rs%nsite > 0) then
          call kron(Ham, Ops%Li(Rs%s(1)%o), Ops%Li(iop), 1, 1, 'N', 'N', 'N')
          call scale(pre(1) * Rs%S(1)%w * get_coupl(Hparams, Rs%S(1)%h, xx), Ham)

          call kron(Tmp, Ops%Li(iop), Ops%Li(Rs%s(1)%o), 1, 1, 'N', 'N', 'N')
          call gaxpy(Ham, pre(2) * Rs%S(1)%w * get_coupl(Hparams, Rs%S(1)%h, xx1), Tmp, &
                     errst=errst)
          !if(prop_error('ruleset_to_ham_2site_tensorlistc_tensorc'//&
          !              ' : gaxpy (1) failed.', errst=errst)) return

          call destroy(Tmp)
      end if

      do ii = 2, Rs%nsite
          call kron(Tmp, Ops%Li(Rs%s(ii)%o), Ops%Li(iop), 1, 1, 'N', 'N', 'N')
          call gaxpy(Ham, pre(1) * Rs%S(ii)%w * get_coupl(Hparams, Rs%S(ii)%h, xx), Tmp, &
                     errst=errst)
          !if(prop_error('ruleset_to_ham_2site_tensorlistc_tensorc'//&
          !              ' : gaxpy (2) failed.', errst=errst)) return

          call destroy(Tmp)

          call kron(Tmp, Ops%Li(iop), Ops%Li(Rs%s(ii)%o), 1, 1, 'N', 'N', 'N')
          call gaxpy(Ham, pre(2) * Rs%S(ii)%w * get_coupl(Hparams, Rs%S(ii)%h, xx1), Tmp, &
                     errst=errst)
          !if(prop_error('ruleset_to_ham_2site_tensorlistc_tensorc'//&
          !              ' : gaxpy (3) failed.', errst=errst)) return

          call destroy(Tmp)
      end do

      ! [bond]
      ! ------

      if((Rs%nsite == 0) .and. (Rs%nbond > 0)) then
          ! Initialize Ham
          call kron(Ham, Ops%Li(Rs%B(1)%ol), Ops%Li(Rs%B(1)%or), 1, 1, &
                    'N', 'N', 'N')
          call scale(Rs%B(1)%w * get_coupl(Hparams, Rs%B(1)%h, xx), Ham)

          i1 = 2
      else
          i1 = 1
      end if

      do ii = i1, Rs%nbond
          call kron(Tmp, Ops%Li(Rs%B(ii)%ol), Ops%Li(Rs%B(ii)%or), 1, 1, &
                    'N', 'N', 'N')
          call gaxpy(Ham, Rs%B(ii)%w * get_coupl(Hparams, Rs%B(ii)%h, xx), Tmp, &
                     errst=errst)
          !if(prop_error('ruleset_to_ham_2site_tensorlistc_tensorc'//&
          !              ' : gaxpy (4) failed.', errst=errst)) return

          call destroy(Tmp)
      end do

      ! For symmetric tensor, we have to add the diagonal blocks with
      ! zero values (zero block => identity in the exponential)
      if(.false.) then
          call kron(Tmp, Ops%Li(iop), Ops%Li(iop), 1, 1, 'N', 'N', 'N')
          call gaxpy(Ham, 0.0_rKind, Tmp, errst=errst)
          !if(prop_error('ruleset_to_ham_2site_tensorlistc_tensorc'//&
          !              ' : gaxpy (5) failed.', 'MPOOps_include.f90:2911', &
          !              errst=errst)) return

          call destroy(Tmp)
      end if

  end subroutine ruleset_to_ham_2site_tensorlistc_tensorc

MPOOps_f90.ruleset_to_ham_2site_qtensorlist_qtensor()

fortran-subroutine - May 2017 (dj, update) Extract the 2-site Hamiltonian for a Trotter decomposition from the Rule Set.

Arguments

HamTYPE(qtensor), out

Contains on exit the two-site Hamiltonian as rank four tensor. The weight of the local Hamiltonians is equally 0.5 for PBC and on sites 2 .. (ll-1) for the bulk in OBC. Sites 1 and ll have weight 1.0 in OPC.

xxINTEGER, in

Get hamiltonian for sites xx, xx+1

RsTYPE(MPORuleSet), in

Contains the rule set to build up the MPO. For the 2-site Hamiltonian only site-rules and bond-rules are considered.

OpsTYPE(qtensorlist), in

List containing all operators for the evolution

HparamsTYPE(HamiltonianParameters), in

containing the couplings for each operator

iopINTEGER, in

The index of the identity in the operator list.

Source Code

show / hide f90 code

  subroutine ruleset_to_ham_2site_qtensorlist_qtensor(Ham, xx, ll, Rs, &
       Ops, Hparams, iop, errst)
      type(qtensor), intent(inout) :: Ham
      integer, intent(in) :: xx, ll
      type(MPORuleSet), intent(in) :: Rs
      type(qtensorlist), intent(in) :: Ops
      type(HamiltonianParameters), pointer, intent(in) :: Hparams(:)
      integer, intent(in) :: iop
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! first index for bond rule
      integer :: i1

      ! position of the site xx+1
      integer :: xx1

      ! prefactor considering boundary effects in PBC/OPC
      real(KIND=rKind), dimension(2) :: pre

      ! temporary matrix to calculate the next hamiltonian contribution
      type(qtensor) :: Tmp

      !if(present(errst)) errst = 0

      ! [local site]
      ! ------------

      if(Rs%pbc) then
          ! Periodic boundary condition - every local term appears twice
          pre = 0.5_rKind
      elseif((xx == 1) .and. (xx == ll - 1)) then
          ! Open boundary conditions - system consists of two sites
          pre = 1.0_rKind
      elseif(xx == 1) then
          ! Open boundary conditions - left border
          pre = [1.0_rKind, 0.5_rKind]
      elseif(xx == ll - 1) then
          ! Open boundary conditions - right border
          pre = [0.5_rKind, 1.0_rKind]
      else
          pre = 0.5_rKind
      end if

      if(xx + 1 > ll) then
          if(Rs%pbc .and. (xx == ll)) then
              xx1 = 1
          else
              errst = raise_error('ruleset_to_ham_2site_qtensorlist_qtensor'//&
                                  ' : site xx not valid.', 99, errst=errst)
              return
          end if
      else
          xx1 = xx + 1
      end if

      ! First site rule - initialize Ham
      if(Rs%nsite > 0) then
          call kron(Ham, Ops%Li(Rs%s(1)%o), Ops%Li(iop), 1, 1, 'N', 'N', 'N')
          call scale(pre(1) * Rs%S(1)%w * get_coupl(Hparams, Rs%S(1)%h, xx), Ham)

          call kron(Tmp, Ops%Li(iop), Ops%Li(Rs%s(1)%o), 1, 1, 'N', 'N', 'N')
          call gaxpy(Ham, pre(2) * Rs%S(1)%w * get_coupl(Hparams, Rs%S(1)%h, xx1), Tmp, &
                     errst=errst)
          !if(prop_error('ruleset_to_ham_2site_qtensorlist_qtensor'//&
          !              ' : gaxpy (1) failed.', errst=errst)) return

          call destroy(Tmp)
      end if

      do ii = 2, Rs%nsite
          call kron(Tmp, Ops%Li(Rs%s(ii)%o), Ops%Li(iop), 1, 1, 'N', 'N', 'N')
          call gaxpy(Ham, pre(1) * Rs%S(ii)%w * get_coupl(Hparams, Rs%S(ii)%h, xx), Tmp, &
                     errst=errst)
          !if(prop_error('ruleset_to_ham_2site_qtensorlist_qtensor'//&
          !              ' : gaxpy (2) failed.', errst=errst)) return

          call destroy(Tmp)

          call kron(Tmp, Ops%Li(iop), Ops%Li(Rs%s(ii)%o), 1, 1, 'N', 'N', 'N')
          call gaxpy(Ham, pre(2) * Rs%S(ii)%w * get_coupl(Hparams, Rs%S(ii)%h, xx1), Tmp, &
                     errst=errst)
          !if(prop_error('ruleset_to_ham_2site_qtensorlist_qtensor'//&
          !              ' : gaxpy (3) failed.', errst=errst)) return

          call destroy(Tmp)
      end do

      ! [bond]
      ! ------

      if((Rs%nsite == 0) .and. (Rs%nbond > 0)) then
          ! Initialize Ham
          call kron(Ham, Ops%Li(Rs%B(1)%ol), Ops%Li(Rs%B(1)%or), 1, 1, &
                    'N', 'N', 'N')
          call scale(Rs%B(1)%w * get_coupl(Hparams, Rs%B(1)%h, xx), Ham)

          i1 = 2
      else
          i1 = 1
      end if

      do ii = i1, Rs%nbond
          call kron(Tmp, Ops%Li(Rs%B(ii)%ol), Ops%Li(Rs%B(ii)%or), 1, 1, &
                    'N', 'N', 'N')
          call gaxpy(Ham, Rs%B(ii)%w * get_coupl(Hparams, Rs%B(ii)%h, xx), Tmp, &
                     errst=errst)
          !if(prop_error('ruleset_to_ham_2site_qtensorlist_qtensor'//&
          !              ' : gaxpy (4) failed.', errst=errst)) return

          call destroy(Tmp)
      end do

      ! For symmetric tensor, we have to add the diagonal blocks with
      ! zero values (zero block => identity in the exponential)
      if(.true.) then
          call kron(Tmp, Ops%Li(iop), Ops%Li(iop), 1, 1, 'N', 'N', 'N')
          call gaxpy(Ham, 0.0_rKind, Tmp, errst=errst)
          !if(prop_error('ruleset_to_ham_2site_qtensorlist_qtensor'//&
          !              ' : gaxpy (5) failed.', 'MPOOps_include.f90:2911', &
          !              errst=errst)) return

          call destroy(Tmp)
      end if

  end subroutine ruleset_to_ham_2site_qtensorlist_qtensor

MPOOps_f90.ruleset_to_ham_2site_qtensorlist_qtensorc()

fortran-subroutine - May 2017 (dj, update) Extract the 2-site Hamiltonian for a Trotter decomposition from the Rule Set.

Arguments

HamTYPE(qtensorc), out

Contains on exit the two-site Hamiltonian as rank four tensor. The weight of the local Hamiltonians is equally 0.5 for PBC and on sites 2 .. (ll-1) for the bulk in OBC. Sites 1 and ll have weight 1.0 in OPC.

xxINTEGER, in

Get hamiltonian for sites xx, xx+1

RsTYPE(MPORuleSet), in

Contains the rule set to build up the MPO. For the 2-site Hamiltonian only site-rules and bond-rules are considered.

OpsTYPE(qtensorlist), in

List containing all operators for the evolution

HparamsTYPE(HamiltonianParameters), in

containing the couplings for each operator

iopINTEGER, in

The index of the identity in the operator list.

Source Code

show / hide f90 code

  subroutine ruleset_to_ham_2site_qtensorlist_qtensorc(Ham, xx, ll, Rs, &
       Ops, Hparams, iop, errst)
      type(qtensorc), intent(inout) :: Ham
      integer, intent(in) :: xx, ll
      type(MPORuleSet), intent(in) :: Rs
      type(qtensorlist), intent(in) :: Ops
      type(HamiltonianParameters), pointer, intent(in) :: Hparams(:)
      integer, intent(in) :: iop
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! first index for bond rule
      integer :: i1

      ! position of the site xx+1
      integer :: xx1

      ! prefactor considering boundary effects in PBC/OPC
      real(KIND=rKind), dimension(2) :: pre

      ! temporary matrix to calculate the next hamiltonian contribution
      type(qtensorc) :: Tmp

      !if(present(errst)) errst = 0

      ! [local site]
      ! ------------

      if(Rs%pbc) then
          ! Periodic boundary condition - every local term appears twice
          pre = 0.5_rKind
      elseif((xx == 1) .and. (xx == ll - 1)) then
          ! Open boundary conditions - system consists of two sites
          pre = 1.0_rKind
      elseif(xx == 1) then
          ! Open boundary conditions - left border
          pre = [1.0_rKind, 0.5_rKind]
      elseif(xx == ll - 1) then
          ! Open boundary conditions - right border
          pre = [0.5_rKind, 1.0_rKind]
      else
          pre = 0.5_rKind
      end if

      if(xx + 1 > ll) then
          if(Rs%pbc .and. (xx == ll)) then
              xx1 = 1
          else
              errst = raise_error('ruleset_to_ham_2site_qtensorlist_qtensorc'//&
                                  ' : site xx not valid.', 99, errst=errst)
              return
          end if
      else
          xx1 = xx + 1
      end if

      ! First site rule - initialize Ham
      if(Rs%nsite > 0) then
          call kron(Ham, Ops%Li(Rs%s(1)%o), Ops%Li(iop), 1, 1, 'N', 'N', 'N')
          call scale(pre(1) * Rs%S(1)%w * get_coupl(Hparams, Rs%S(1)%h, xx), Ham)

          call kron(Tmp, Ops%Li(iop), Ops%Li(Rs%s(1)%o), 1, 1, 'N', 'N', 'N')
          call gaxpy(Ham, pre(2) * Rs%S(1)%w * get_coupl(Hparams, Rs%S(1)%h, xx1), Tmp, &
                     errst=errst)
          !if(prop_error('ruleset_to_ham_2site_qtensorlist_qtensorc'//&
          !              ' : gaxpy (1) failed.', errst=errst)) return

          call destroy(Tmp)
      end if

      do ii = 2, Rs%nsite
          call kron(Tmp, Ops%Li(Rs%s(ii)%o), Ops%Li(iop), 1, 1, 'N', 'N', 'N')
          call gaxpy(Ham, pre(1) * Rs%S(ii)%w * get_coupl(Hparams, Rs%S(ii)%h, xx), Tmp, &
                     errst=errst)
          !if(prop_error('ruleset_to_ham_2site_qtensorlist_qtensorc'//&
          !              ' : gaxpy (2) failed.', errst=errst)) return

          call destroy(Tmp)

          call kron(Tmp, Ops%Li(iop), Ops%Li(Rs%s(ii)%o), 1, 1, 'N', 'N', 'N')
          call gaxpy(Ham, pre(2) * Rs%S(ii)%w * get_coupl(Hparams, Rs%S(ii)%h, xx1), Tmp, &
                     errst=errst)
          !if(prop_error('ruleset_to_ham_2site_qtensorlist_qtensorc'//&
          !              ' : gaxpy (3) failed.', errst=errst)) return

          call destroy(Tmp)
      end do

      ! [bond]
      ! ------

      if((Rs%nsite == 0) .and. (Rs%nbond > 0)) then
          ! Initialize Ham
          call kron(Ham, Ops%Li(Rs%B(1)%ol), Ops%Li(Rs%B(1)%or), 1, 1, &
                    'N', 'N', 'N')
          call scale(Rs%B(1)%w * get_coupl(Hparams, Rs%B(1)%h, xx), Ham)

          i1 = 2
      else
          i1 = 1
      end if

      do ii = i1, Rs%nbond
          call kron(Tmp, Ops%Li(Rs%B(ii)%ol), Ops%Li(Rs%B(ii)%or), 1, 1, &
                    'N', 'N', 'N')
          call gaxpy(Ham, Rs%B(ii)%w * get_coupl(Hparams, Rs%B(ii)%h, xx), Tmp, &
                     errst=errst)
          !if(prop_error('ruleset_to_ham_2site_qtensorlist_qtensorc'//&
          !              ' : gaxpy (4) failed.', errst=errst)) return

          call destroy(Tmp)
      end do

      ! For symmetric tensor, we have to add the diagonal blocks with
      ! zero values (zero block => identity in the exponential)
      if(.true.) then
          call kron(Tmp, Ops%Li(iop), Ops%Li(iop), 1, 1, 'N', 'N', 'N')
          call gaxpy(Ham, 0.0_rKind, Tmp, errst=errst)
          !if(prop_error('ruleset_to_ham_2site_qtensorlist_qtensorc'//&
          !              ' : gaxpy (5) failed.', 'MPOOps_include.f90:2911', &
          !              errst=errst)) return

          call destroy(Tmp)
      end if

  end subroutine ruleset_to_ham_2site_qtensorlist_qtensorc

MPOOps_f90.ruleset_to_ham_2site_qtensorclist_qtensorc()

fortran-subroutine - May 2017 (dj, update) Extract the 2-site Hamiltonian for a Trotter decomposition from the Rule Set.

Arguments

HamTYPE(qtensorc), out

Contains on exit the two-site Hamiltonian as rank four tensor. The weight of the local Hamiltonians is equally 0.5 for PBC and on sites 2 .. (ll-1) for the bulk in OBC. Sites 1 and ll have weight 1.0 in OPC.

xxINTEGER, in

Get hamiltonian for sites xx, xx+1

RsTYPE(MPORuleSet), in

Contains the rule set to build up the MPO. For the 2-site Hamiltonian only site-rules and bond-rules are considered.

OpsTYPE(qtensorclist), in

List containing all operators for the evolution

HparamsTYPE(HamiltonianParameters), in

containing the couplings for each operator

iopINTEGER, in

The index of the identity in the operator list.

Source Code

show / hide f90 code

  subroutine ruleset_to_ham_2site_qtensorclist_qtensorc(Ham, xx, ll, Rs, &
       Ops, Hparams, iop, errst)
      type(qtensorc), intent(inout) :: Ham
      integer, intent(in) :: xx, ll
      type(MPORuleSet), intent(in) :: Rs
      type(qtensorclist), intent(in) :: Ops
      type(HamiltonianParameters), pointer, intent(in) :: Hparams(:)
      integer, intent(in) :: iop
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! first index for bond rule
      integer :: i1

      ! position of the site xx+1
      integer :: xx1

      ! prefactor considering boundary effects in PBC/OPC
      real(KIND=rKind), dimension(2) :: pre

      ! temporary matrix to calculate the next hamiltonian contribution
      type(qtensorc) :: Tmp

      !if(present(errst)) errst = 0

      ! [local site]
      ! ------------

      if(Rs%pbc) then
          ! Periodic boundary condition - every local term appears twice
          pre = 0.5_rKind
      elseif((xx == 1) .and. (xx == ll - 1)) then
          ! Open boundary conditions - system consists of two sites
          pre = 1.0_rKind
      elseif(xx == 1) then
          ! Open boundary conditions - left border
          pre = [1.0_rKind, 0.5_rKind]
      elseif(xx == ll - 1) then
          ! Open boundary conditions - right border
          pre = [0.5_rKind, 1.0_rKind]
      else
          pre = 0.5_rKind
      end if

      if(xx + 1 > ll) then
          if(Rs%pbc .and. (xx == ll)) then
              xx1 = 1
          else
              errst = raise_error('ruleset_to_ham_2site_qtensorclist_qtensorc'//&
                                  ' : site xx not valid.', 99, errst=errst)
              return
          end if
      else
          xx1 = xx + 1
      end if

      ! First site rule - initialize Ham
      if(Rs%nsite > 0) then
          call kron(Ham, Ops%Li(Rs%s(1)%o), Ops%Li(iop), 1, 1, 'N', 'N', 'N')
          call scale(pre(1) * Rs%S(1)%w * get_coupl(Hparams, Rs%S(1)%h, xx), Ham)

          call kron(Tmp, Ops%Li(iop), Ops%Li(Rs%s(1)%o), 1, 1, 'N', 'N', 'N')
          call gaxpy(Ham, pre(2) * Rs%S(1)%w * get_coupl(Hparams, Rs%S(1)%h, xx1), Tmp, &
                     errst=errst)
          !if(prop_error('ruleset_to_ham_2site_qtensorclist_qtensorc'//&
          !              ' : gaxpy (1) failed.', errst=errst)) return

          call destroy(Tmp)
      end if

      do ii = 2, Rs%nsite
          call kron(Tmp, Ops%Li(Rs%s(ii)%o), Ops%Li(iop), 1, 1, 'N', 'N', 'N')
          call gaxpy(Ham, pre(1) * Rs%S(ii)%w * get_coupl(Hparams, Rs%S(ii)%h, xx), Tmp, &
                     errst=errst)
          !if(prop_error('ruleset_to_ham_2site_qtensorclist_qtensorc'//&
          !              ' : gaxpy (2) failed.', errst=errst)) return

          call destroy(Tmp)

          call kron(Tmp, Ops%Li(iop), Ops%Li(Rs%s(ii)%o), 1, 1, 'N', 'N', 'N')
          call gaxpy(Ham, pre(2) * Rs%S(ii)%w * get_coupl(Hparams, Rs%S(ii)%h, xx1), Tmp, &
                     errst=errst)
          !if(prop_error('ruleset_to_ham_2site_qtensorclist_qtensorc'//&
          !              ' : gaxpy (3) failed.', errst=errst)) return

          call destroy(Tmp)
      end do

      ! [bond]
      ! ------

      if((Rs%nsite == 0) .and. (Rs%nbond > 0)) then
          ! Initialize Ham
          call kron(Ham, Ops%Li(Rs%B(1)%ol), Ops%Li(Rs%B(1)%or), 1, 1, &
                    'N', 'N', 'N')
          call scale(Rs%B(1)%w * get_coupl(Hparams, Rs%B(1)%h, xx), Ham)

          i1 = 2
      else
          i1 = 1
      end if

      do ii = i1, Rs%nbond
          call kron(Tmp, Ops%Li(Rs%B(ii)%ol), Ops%Li(Rs%B(ii)%or), 1, 1, &
                    'N', 'N', 'N')
          call gaxpy(Ham, Rs%B(ii)%w * get_coupl(Hparams, Rs%B(ii)%h, xx), Tmp, &
                     errst=errst)
          !if(prop_error('ruleset_to_ham_2site_qtensorclist_qtensorc'//&
          !              ' : gaxpy (4) failed.', errst=errst)) return

          call destroy(Tmp)
      end do

      ! For symmetric tensor, we have to add the diagonal blocks with
      ! zero values (zero block => identity in the exponential)
      if(.true.) then
          call kron(Tmp, Ops%Li(iop), Ops%Li(iop), 1, 1, 'N', 'N', 'N')
          call gaxpy(Ham, 0.0_rKind, Tmp, errst=errst)
          !if(prop_error('ruleset_to_ham_2site_qtensorclist_qtensorc'//&
          !              ' : gaxpy (5) failed.', 'MPOOps_include.f90:2911', &
          !              errst=errst)) return

          call destroy(Tmp)
      end if

  end subroutine ruleset_to_ham_2site_qtensorclist_qtensorc

MPOOps_f90.ruleset_to_effham_2site_tensorlist()

fortran-subroutine - May 2017 (dj, update) Extract the 2-site effective Hamiltonian for a Trotter decomposition from the Rule Set for quantum trajectories.

Arguments

HamTYPE(tensorc), out

Contains on exit the two-site effective Hamiltonian as rank four tensor. The weight of the local Hamiltonians is equally 0.5 for PBC and on sites 2 .. (ll-1) for the bulk in OBC. Sites 1 and ll have weight 1.0 in OPC.

xxINTEGER, in

Get hamiltonian for sites xx, xx+1

RsTYPE(MPORuleSet), in

Contains the rule set to build up the MPO. For the 2-site Hamiltonian only site-rules and bond-rules are considered. The dissipative part includes the local Lindblad terms.

OpsTYPE(tensorlist), inout

List containing all operators for the evolution

HparamsTYPE(HamiltonianParameters), in

containing the couplings for each operator

iopINTEGER, in

The index of the identity in the operator list.

Source Code

show / hide f90 code

  subroutine ruleset_to_effham_2site_tensorlist(Ham, xx, ll, Rs, Ops, &
                                               Hparams, iop, errst)
      type(tensorc), intent(inout) :: Ham
      integer, intent(in) :: xx, ll
      type(MPORuleSet), intent(in) :: Rs
      type(tensorlist), intent(inout) :: Ops
      type(HamiltonianParameters), pointer, intent(in) :: Hparams(:)
      integer, intent(in) :: iop
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! first index for bond rule
      integer :: i1

      ! position of the site xx+1
      integer :: xx1

      ! Offset for MBSLXY rule
      integer :: os

      ! coupling for Lindblad terms
      real(KIND=rKind) :: coupl

      ! prefactor considering boundary effects in PBC/OPC
      real(KIND=rKind), dimension(2) :: pre

      ! temporary matrix to calculate the next hamiltonian contribution
      type(tensor) :: Tmp, Tmpa, Tmpb

      !if(present(errst)) errst = 0

      ! Get the Hamiltonian from the pure state evolution implementation
      call ruleset_to_ham_2site(Ham, xx, ll, Rs, Ops, Hparams, iop, &
                                errst=errst)

      ! [local lindblad terms]
      ! ----------------------

      if(Rs%pbc) then
          ! Periodic boundary condition - every local term appears twice
          pre = 0.5_rKind
      elseif((xx == 1) .and. (xx == ll - 1)) then
          ! Open boundary conditions - system consists of two sites
          pre = 1.0_rKind
      elseif(xx == 1) then
          ! Open boundary conditions - left border
          pre = [1.0_rKind, 0.5_rKind]
      elseif(xx == ll - 1) then
          ! Open boundary conditions - right border
          pre = [0.5_rKind, 1.0_rKind]
      else
          pre = 0.5_rKind
      end if

      if(xx + 1 > ll) then
          if(Rs%pbc .and. (xx == ll)) then
              xx1 = 1
          else
              errst = raise_error('ruleset_to_ham_2site_MATRIXtensorlist'//&
                                  ' : site xx not valid.', 99, errst=errst)
              return
          end if
      else
          xx1 = xx + 1
      end if

      do ii = 1, Rs%nlxx
          ! Build L^dagger L
          call contr(Tmp, Ops%Li(Rs%Lxx(ii)%o), Ops%Li(Rs%Lxx(ii)%o), &
                     [1], [1], transl='C', errst=errst)
          !if(prop_error('set_first_effmpo_MATRIXtensorlist_MPO_TYPE'//&
          !              ': contr failed.', 'MPOOps_include.f90:3053', &
          !              errst=errst)) return

          coupl = pre(1) * Rs%Lxx(ii)%w * get_coupl(Hparams, Rs%Lxx(ii)%h, xx)

          call kron(Tmpb, Tmp, Ops%Li(iop), 1, 1, 'N', 'N', 'N')
          call gaxpy(Ham, -0.5_rkInd * eye * coupl, Tmpb, errst=errst)
          !if(prop_error('ruleset_to_ham_2site_MATRIXtensorlist'//&
          !              ' : gaxpy failed.', 'MPOOps_include.f90:3061', &
          !              errst=errst)) return

          call destroy(Tmpb)

          coupl = pre(2) * Rs%Lxx(ii)%w * get_coupl(Hparams, Rs%Lxx(ii)%h, xx1)

          call kron(Tmpb, Ops%Li(iop), Tmp, 1, 1, 'N', 'N', 'N')
          call gaxpy(Ham, -0.5_rkInd * eye * coupl, Tmpb, errst=errst)
          !if(prop_error('ruleset_to_ham_2site_MATRIXtensorlist'//&
          !              ' : gaxpy failed.', 'MPOOps_include.f90:3071', &
          !              errst=errst)) return

          call destroy(Tmp)
          call destroy(Tmpb)

      end do

      ! [many-body string lindblad terms (if length is 2)]
      ! --------------------------------------------------

      do ii = 1, Rs%nmbsl
          if(Rs%Mbsl(ii)%n /= 2) cycle

          ! Build L^dagger L on both sites
          call contr(Tmpa, Ops%Li(Rs%Mbsl(ii)%o(1)), &
                     Ops%Li(Rs%Mbsl(ii)%o(1)), [1], [1], transl='C', &
                     errst=errst)
          !if(prop_error('ruleset_to_effham_2site_tensorlist : '//&
          !              'contr failed.', 'MPOOps_include.f90:3090', &
          !              errst=errst)) return

          call contr(Tmpb, Ops%Li(Rs%Mbsl(ii)%o(2)), &
                     Ops%Li(Rs%Mbsl(ii)%o(2)), [1], [1], transl='C', &
                     errst=errst)
          !if(prop_error('ruleset_to_effham_2site_tensorlist : '//&
          !              'contr failed.', 'MPOOps_include.f90:3097', &
          !              errst=errst)) return

          coupl = Rs%Mbsl(ii)%w * get_coupl(Hparams, Rs%Mbsl(ii)%h, xx)

          call kron(Tmp, Tmpa, Tmpb, 1, 1, 'N', 'N', 'N')
          call gaxpy(Ham, -0.5_rKind * eye * coupl, Tmp, errst=errst)
          !if(prop_error('ruleset_to_effham_2site_tensorlist : '//&
          !              'gaxpy failed.', 'MPOOps_include.f90:3105', &
          !              errst=errst)) return

          call destroy(Tmp)
          call destroy(Tmpa)
          call destroy(Tmpb)
      end do

      ! [many-body string Lindblad XY terms] (if length is 2)
      ! ------------------------------------

      do ii = 1, Rs%nmbslxy
          errst = raise_error('ruleset_to_effham_2site_tensorlist : '//&
                              'no MBSLXY possible.', 99, &
                              'MPOOps_include.f90:3119', errst=errst)
          ! The idea of calculating <A| Ldagger L |A> is violated
          ! here since single term do not hold this relation. Thus,
          ! the next term should be wrong ...

          os = Rs%Mbslxy(ii)%n
          if(os /= 2) cycle

          ! Build L^dagger L on both sites
          call contr(Tmpa, Ops%Li(Rs%Mbslxy(ii)%o(os + 1)), &
                     Ops%Li(Rs%Mbslxy(ii)%o(1)), [1], [1], transl='C', &
                     errst=errst)
          !if(prop_error('ruleset_to_effham_2site_tensorlist : '//&
          !              'contr failed.', 'MPOOps_include.f90:3132', &
          !              errst=errst)) return

          call contr(Tmpb, Ops%Li(Rs%Mbslxy(ii)%o(os + 2)), &
                     Ops%Li(Rs%Mbslxy(ii)%o(2)), [1], [1], transl='C', &
                     errst=errst)
          !if(prop_error('ruleset_to_effham_2site_tensorlist : '//&
          !              'contr failed.', 'MPOOps_include.f90:3139', &
          !              errst=errst)) return

          coupl = Rs%Mbslxy(ii)%w * get_coupl(Hparams, Rs%Mbslxy(ii)%h, xx)

          call kron(Tmp, Tmpa, Tmpb, 1, 1, 'N', 'N', 'N')
          call gaxpy(Ham, -0.5_rKind * eye * coupl, Tmp, errst=errst)
          !if(prop_error('ruleset_to_effham_2site_tensorlist : '//&
          !              'gaxpy failed.', 'MPOOps_include.f90:3147', &
          !              errst=errst)) return

          call destroy(Tmp)
          call destroy(Tmpa)
          call destroy(Tmpb)
      end do

  end subroutine ruleset_to_effham_2site_tensorlist

MPOOps_f90.ruleset_to_effham_2site_tensorlistc()

fortran-subroutine - May 2017 (dj, update) Extract the 2-site effective Hamiltonian for a Trotter decomposition from the Rule Set for quantum trajectories.

Arguments

HamTYPE(tensorc), out

Contains on exit the two-site effective Hamiltonian as rank four tensor. The weight of the local Hamiltonians is equally 0.5 for PBC and on sites 2 .. (ll-1) for the bulk in OBC. Sites 1 and ll have weight 1.0 in OPC.

xxINTEGER, in

Get hamiltonian for sites xx, xx+1

RsTYPE(MPORuleSet), in

Contains the rule set to build up the MPO. For the 2-site Hamiltonian only site-rules and bond-rules are considered. The dissipative part includes the local Lindblad terms.

OpsTYPE(tensorlistc), inout

List containing all operators for the evolution

HparamsTYPE(HamiltonianParameters), in

containing the couplings for each operator

iopINTEGER, in

The index of the identity in the operator list.

Source Code

show / hide f90 code

  subroutine ruleset_to_effham_2site_tensorlistc(Ham, xx, ll, Rs, Ops, &
                                               Hparams, iop, errst)
      type(tensorc), intent(inout) :: Ham
      integer, intent(in) :: xx, ll
      type(MPORuleSet), intent(in) :: Rs
      type(tensorlistc), intent(inout) :: Ops
      type(HamiltonianParameters), pointer, intent(in) :: Hparams(:)
      integer, intent(in) :: iop
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! first index for bond rule
      integer :: i1

      ! position of the site xx+1
      integer :: xx1

      ! Offset for MBSLXY rule
      integer :: os

      ! coupling for Lindblad terms
      real(KIND=rKind) :: coupl

      ! prefactor considering boundary effects in PBC/OPC
      real(KIND=rKind), dimension(2) :: pre

      ! temporary matrix to calculate the next hamiltonian contribution
      type(tensorc) :: Tmp, Tmpa, Tmpb

      !if(present(errst)) errst = 0

      ! Get the Hamiltonian from the pure state evolution implementation
      call ruleset_to_ham_2site(Ham, xx, ll, Rs, Ops, Hparams, iop, &
                                errst=errst)

      ! [local lindblad terms]
      ! ----------------------

      if(Rs%pbc) then
          ! Periodic boundary condition - every local term appears twice
          pre = 0.5_rKind
      elseif((xx == 1) .and. (xx == ll - 1)) then
          ! Open boundary conditions - system consists of two sites
          pre = 1.0_rKind
      elseif(xx == 1) then
          ! Open boundary conditions - left border
          pre = [1.0_rKind, 0.5_rKind]
      elseif(xx == ll - 1) then
          ! Open boundary conditions - right border
          pre = [0.5_rKind, 1.0_rKind]
      else
          pre = 0.5_rKind
      end if

      if(xx + 1 > ll) then
          if(Rs%pbc .and. (xx == ll)) then
              xx1 = 1
          else
              errst = raise_error('ruleset_to_ham_2site_MATRIXtensorlistc'//&
                                  ' : site xx not valid.', 99, errst=errst)
              return
          end if
      else
          xx1 = xx + 1
      end if

      do ii = 1, Rs%nlxx
          ! Build L^dagger L
          call contr(Tmp, Ops%Li(Rs%Lxx(ii)%o), Ops%Li(Rs%Lxx(ii)%o), &
                     [1], [1], transl='C', errst=errst)
          !if(prop_error('set_first_effmpo_MATRIXtensorlistc_MPO_TYPE'//&
          !              ': contr failed.', 'MPOOps_include.f90:3053', &
          !              errst=errst)) return

          coupl = pre(1) * Rs%Lxx(ii)%w * get_coupl(Hparams, Rs%Lxx(ii)%h, xx)

          call kron(Tmpb, Tmp, Ops%Li(iop), 1, 1, 'N', 'N', 'N')
          call gaxpy(Ham, -0.5_rkInd * eye * coupl, Tmpb, errst=errst)
          !if(prop_error('ruleset_to_ham_2site_MATRIXtensorlistc'//&
          !              ' : gaxpy failed.', 'MPOOps_include.f90:3061', &
          !              errst=errst)) return

          call destroy(Tmpb)

          coupl = pre(2) * Rs%Lxx(ii)%w * get_coupl(Hparams, Rs%Lxx(ii)%h, xx1)

          call kron(Tmpb, Ops%Li(iop), Tmp, 1, 1, 'N', 'N', 'N')
          call gaxpy(Ham, -0.5_rkInd * eye * coupl, Tmpb, errst=errst)
          !if(prop_error('ruleset_to_ham_2site_MATRIXtensorlistc'//&
          !              ' : gaxpy failed.', 'MPOOps_include.f90:3071', &
          !              errst=errst)) return

          call destroy(Tmp)
          call destroy(Tmpb)

      end do

      ! [many-body string lindblad terms (if length is 2)]
      ! --------------------------------------------------

      do ii = 1, Rs%nmbsl
          if(Rs%Mbsl(ii)%n /= 2) cycle

          ! Build L^dagger L on both sites
          call contr(Tmpa, Ops%Li(Rs%Mbsl(ii)%o(1)), &
                     Ops%Li(Rs%Mbsl(ii)%o(1)), [1], [1], transl='C', &
                     errst=errst)
          !if(prop_error('ruleset_to_effham_2site_tensorlistc : '//&
          !              'contr failed.', 'MPOOps_include.f90:3090', &
          !              errst=errst)) return

          call contr(Tmpb, Ops%Li(Rs%Mbsl(ii)%o(2)), &
                     Ops%Li(Rs%Mbsl(ii)%o(2)), [1], [1], transl='C', &
                     errst=errst)
          !if(prop_error('ruleset_to_effham_2site_tensorlistc : '//&
          !              'contr failed.', 'MPOOps_include.f90:3097', &
          !              errst=errst)) return

          coupl = Rs%Mbsl(ii)%w * get_coupl(Hparams, Rs%Mbsl(ii)%h, xx)

          call kron(Tmp, Tmpa, Tmpb, 1, 1, 'N', 'N', 'N')
          call gaxpy(Ham, -0.5_rKind * eye * coupl, Tmp, errst=errst)
          !if(prop_error('ruleset_to_effham_2site_tensorlistc : '//&
          !              'gaxpy failed.', 'MPOOps_include.f90:3105', &
          !              errst=errst)) return

          call destroy(Tmp)
          call destroy(Tmpa)
          call destroy(Tmpb)
      end do

      ! [many-body string Lindblad XY terms] (if length is 2)
      ! ------------------------------------

      do ii = 1, Rs%nmbslxy
          errst = raise_error('ruleset_to_effham_2site_tensorlistc : '//&
                              'no MBSLXY possible.', 99, &
                              'MPOOps_include.f90:3119', errst=errst)
          ! The idea of calculating <A| Ldagger L |A> is violated
          ! here since single term do not hold this relation. Thus,
          ! the next term should be wrong ...

          os = Rs%Mbslxy(ii)%n
          if(os /= 2) cycle

          ! Build L^dagger L on both sites
          call contr(Tmpa, Ops%Li(Rs%Mbslxy(ii)%o(os + 1)), &
                     Ops%Li(Rs%Mbslxy(ii)%o(1)), [1], [1], transl='C', &
                     errst=errst)
          !if(prop_error('ruleset_to_effham_2site_tensorlistc : '//&
          !              'contr failed.', 'MPOOps_include.f90:3132', &
          !              errst=errst)) return

          call contr(Tmpb, Ops%Li(Rs%Mbslxy(ii)%o(os + 2)), &
                     Ops%Li(Rs%Mbslxy(ii)%o(2)), [1], [1], transl='C', &
                     errst=errst)
          !if(prop_error('ruleset_to_effham_2site_tensorlistc : '//&
          !              'contr failed.', 'MPOOps_include.f90:3139', &
          !              errst=errst)) return

          coupl = Rs%Mbslxy(ii)%w * get_coupl(Hparams, Rs%Mbslxy(ii)%h, xx)

          call kron(Tmp, Tmpa, Tmpb, 1, 1, 'N', 'N', 'N')
          call gaxpy(Ham, -0.5_rKind * eye * coupl, Tmp, errst=errst)
          !if(prop_error('ruleset_to_effham_2site_tensorlistc : '//&
          !              'gaxpy failed.', 'MPOOps_include.f90:3147', &
          !              errst=errst)) return

          call destroy(Tmp)
          call destroy(Tmpa)
          call destroy(Tmpb)
      end do

  end subroutine ruleset_to_effham_2site_tensorlistc

MPOOps_f90.ruleset_to_effham_2site_qtensorlist()

fortran-subroutine - May 2017 (dj, update) Extract the 2-site effective Hamiltonian for a Trotter decomposition from the Rule Set for quantum trajectories.

Arguments

HamTYPE(qtensorc), out

Contains on exit the two-site effective Hamiltonian as rank four tensor. The weight of the local Hamiltonians is equally 0.5 for PBC and on sites 2 .. (ll-1) for the bulk in OBC. Sites 1 and ll have weight 1.0 in OPC.

xxINTEGER, in

Get hamiltonian for sites xx, xx+1

RsTYPE(MPORuleSet), in

Contains the rule set to build up the MPO. For the 2-site Hamiltonian only site-rules and bond-rules are considered. The dissipative part includes the local Lindblad terms.

OpsTYPE(qtensorlist), inout

List containing all operators for the evolution

HparamsTYPE(HamiltonianParameters), in

containing the couplings for each operator

iopINTEGER, in

The index of the identity in the operator list.

Source Code

show / hide f90 code

  subroutine ruleset_to_effham_2site_qtensorlist(Ham, xx, ll, Rs, Ops, &
                                               Hparams, iop, errst)
      type(qtensorc), intent(inout) :: Ham
      integer, intent(in) :: xx, ll
      type(MPORuleSet), intent(in) :: Rs
      type(qtensorlist), intent(inout) :: Ops
      type(HamiltonianParameters), pointer, intent(in) :: Hparams(:)
      integer, intent(in) :: iop
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! first index for bond rule
      integer :: i1

      ! position of the site xx+1
      integer :: xx1

      ! Offset for MBSLXY rule
      integer :: os

      ! coupling for Lindblad terms
      real(KIND=rKind) :: coupl

      ! prefactor considering boundary effects in PBC/OPC
      real(KIND=rKind), dimension(2) :: pre

      ! temporary matrix to calculate the next hamiltonian contribution
      type(qtensor) :: Tmp, Tmpa, Tmpb

      !if(present(errst)) errst = 0

      ! Get the Hamiltonian from the pure state evolution implementation
      call ruleset_to_ham_2site(Ham, xx, ll, Rs, Ops, Hparams, iop, &
                                errst=errst)

      ! [local lindblad terms]
      ! ----------------------

      if(Rs%pbc) then
          ! Periodic boundary condition - every local term appears twice
          pre = 0.5_rKind
      elseif((xx == 1) .and. (xx == ll - 1)) then
          ! Open boundary conditions - system consists of two sites
          pre = 1.0_rKind
      elseif(xx == 1) then
          ! Open boundary conditions - left border
          pre = [1.0_rKind, 0.5_rKind]
      elseif(xx == ll - 1) then
          ! Open boundary conditions - right border
          pre = [0.5_rKind, 1.0_rKind]
      else
          pre = 0.5_rKind
      end if

      if(xx + 1 > ll) then
          if(Rs%pbc .and. (xx == ll)) then
              xx1 = 1
          else
              errst = raise_error('ruleset_to_ham_2site_MATRIXqtensorlist'//&
                                  ' : site xx not valid.', 99, errst=errst)
              return
          end if
      else
          xx1 = xx + 1
      end if

      do ii = 1, Rs%nlxx
          ! Build L^dagger L
          call contr(Tmp, Ops%Li(Rs%Lxx(ii)%o), Ops%Li(Rs%Lxx(ii)%o), &
                     [1], [1], transl='C', errst=errst)
          !if(prop_error('set_first_effmpo_MATRIXqtensorlist_MPO_TYPE'//&
          !              ': contr failed.', 'MPOOps_include.f90:3053', &
          !              errst=errst)) return

          coupl = pre(1) * Rs%Lxx(ii)%w * get_coupl(Hparams, Rs%Lxx(ii)%h, xx)

          call kron(Tmpb, Tmp, Ops%Li(iop), 1, 1, 'N', 'N', 'N')
          call gaxpy(Ham, -0.5_rkInd * eye * coupl, Tmpb, errst=errst)
          !if(prop_error('ruleset_to_ham_2site_MATRIXqtensorlist'//&
          !              ' : gaxpy failed.', 'MPOOps_include.f90:3061', &
          !              errst=errst)) return

          call destroy(Tmpb)

          coupl = pre(2) * Rs%Lxx(ii)%w * get_coupl(Hparams, Rs%Lxx(ii)%h, xx1)

          call kron(Tmpb, Ops%Li(iop), Tmp, 1, 1, 'N', 'N', 'N')
          call gaxpy(Ham, -0.5_rkInd * eye * coupl, Tmpb, errst=errst)
          !if(prop_error('ruleset_to_ham_2site_MATRIXqtensorlist'//&
          !              ' : gaxpy failed.', 'MPOOps_include.f90:3071', &
          !              errst=errst)) return

          call destroy(Tmp)
          call destroy(Tmpb)

      end do

      ! [many-body string lindblad terms (if length is 2)]
      ! --------------------------------------------------

      do ii = 1, Rs%nmbsl
          if(Rs%Mbsl(ii)%n /= 2) cycle

          ! Build L^dagger L on both sites
          call contr(Tmpa, Ops%Li(Rs%Mbsl(ii)%o(1)), &
                     Ops%Li(Rs%Mbsl(ii)%o(1)), [1], [1], transl='C', &
                     errst=errst)
          !if(prop_error('ruleset_to_effham_2site_qtensorlist : '//&
          !              'contr failed.', 'MPOOps_include.f90:3090', &
          !              errst=errst)) return

          call contr(Tmpb, Ops%Li(Rs%Mbsl(ii)%o(2)), &
                     Ops%Li(Rs%Mbsl(ii)%o(2)), [1], [1], transl='C', &
                     errst=errst)
          !if(prop_error('ruleset_to_effham_2site_qtensorlist : '//&
          !              'contr failed.', 'MPOOps_include.f90:3097', &
          !              errst=errst)) return

          coupl = Rs%Mbsl(ii)%w * get_coupl(Hparams, Rs%Mbsl(ii)%h, xx)

          call kron(Tmp, Tmpa, Tmpb, 1, 1, 'N', 'N', 'N')
          call gaxpy(Ham, -0.5_rKind * eye * coupl, Tmp, errst=errst)
          !if(prop_error('ruleset_to_effham_2site_qtensorlist : '//&
          !              'gaxpy failed.', 'MPOOps_include.f90:3105', &
          !              errst=errst)) return

          call destroy(Tmp)
          call destroy(Tmpa)
          call destroy(Tmpb)
      end do

      ! [many-body string Lindblad XY terms] (if length is 2)
      ! ------------------------------------

      do ii = 1, Rs%nmbslxy
          errst = raise_error('ruleset_to_effham_2site_qtensorlist : '//&
                              'no MBSLXY possible.', 99, &
                              'MPOOps_include.f90:3119', errst=errst)
          ! The idea of calculating <A| Ldagger L |A> is violated
          ! here since single term do not hold this relation. Thus,
          ! the next term should be wrong ...

          os = Rs%Mbslxy(ii)%n
          if(os /= 2) cycle

          ! Build L^dagger L on both sites
          call contr(Tmpa, Ops%Li(Rs%Mbslxy(ii)%o(os + 1)), &
                     Ops%Li(Rs%Mbslxy(ii)%o(1)), [1], [1], transl='C', &
                     errst=errst)
          !if(prop_error('ruleset_to_effham_2site_qtensorlist : '//&
          !              'contr failed.', 'MPOOps_include.f90:3132', &
          !              errst=errst)) return

          call contr(Tmpb, Ops%Li(Rs%Mbslxy(ii)%o(os + 2)), &
                     Ops%Li(Rs%Mbslxy(ii)%o(2)), [1], [1], transl='C', &
                     errst=errst)
          !if(prop_error('ruleset_to_effham_2site_qtensorlist : '//&
          !              'contr failed.', 'MPOOps_include.f90:3139', &
          !              errst=errst)) return

          coupl = Rs%Mbslxy(ii)%w * get_coupl(Hparams, Rs%Mbslxy(ii)%h, xx)

          call kron(Tmp, Tmpa, Tmpb, 1, 1, 'N', 'N', 'N')
          call gaxpy(Ham, -0.5_rKind * eye * coupl, Tmp, errst=errst)
          !if(prop_error('ruleset_to_effham_2site_qtensorlist : '//&
          !              'gaxpy failed.', 'MPOOps_include.f90:3147', &
          !              errst=errst)) return

          call destroy(Tmp)
          call destroy(Tmpa)
          call destroy(Tmpb)
      end do

  end subroutine ruleset_to_effham_2site_qtensorlist

MPOOps_f90.ruleset_to_effham_2site_qtensorclist()

fortran-subroutine - May 2017 (dj, update) Extract the 2-site effective Hamiltonian for a Trotter decomposition from the Rule Set for quantum trajectories.

Arguments

HamTYPE(qtensorc), out

Contains on exit the two-site effective Hamiltonian as rank four tensor. The weight of the local Hamiltonians is equally 0.5 for PBC and on sites 2 .. (ll-1) for the bulk in OBC. Sites 1 and ll have weight 1.0 in OPC.

xxINTEGER, in

Get hamiltonian for sites xx, xx+1

RsTYPE(MPORuleSet), in

Contains the rule set to build up the MPO. For the 2-site Hamiltonian only site-rules and bond-rules are considered. The dissipative part includes the local Lindblad terms.

OpsTYPE(qtensorclist), inout

List containing all operators for the evolution

HparamsTYPE(HamiltonianParameters), in

containing the couplings for each operator

iopINTEGER, in

The index of the identity in the operator list.

Source Code

show / hide f90 code

  subroutine ruleset_to_effham_2site_qtensorclist(Ham, xx, ll, Rs, Ops, &
                                               Hparams, iop, errst)
      type(qtensorc), intent(inout) :: Ham
      integer, intent(in) :: xx, ll
      type(MPORuleSet), intent(in) :: Rs
      type(qtensorclist), intent(inout) :: Ops
      type(HamiltonianParameters), pointer, intent(in) :: Hparams(:)
      integer, intent(in) :: iop
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! first index for bond rule
      integer :: i1

      ! position of the site xx+1
      integer :: xx1

      ! Offset for MBSLXY rule
      integer :: os

      ! coupling for Lindblad terms
      real(KIND=rKind) :: coupl

      ! prefactor considering boundary effects in PBC/OPC
      real(KIND=rKind), dimension(2) :: pre

      ! temporary matrix to calculate the next hamiltonian contribution
      type(qtensorc) :: Tmp, Tmpa, Tmpb

      !if(present(errst)) errst = 0

      ! Get the Hamiltonian from the pure state evolution implementation
      call ruleset_to_ham_2site(Ham, xx, ll, Rs, Ops, Hparams, iop, &
                                errst=errst)

      ! [local lindblad terms]
      ! ----------------------

      if(Rs%pbc) then
          ! Periodic boundary condition - every local term appears twice
          pre = 0.5_rKind
      elseif((xx == 1) .and. (xx == ll - 1)) then
          ! Open boundary conditions - system consists of two sites
          pre = 1.0_rKind
      elseif(xx == 1) then
          ! Open boundary conditions - left border
          pre = [1.0_rKind, 0.5_rKind]
      elseif(xx == ll - 1) then
          ! Open boundary conditions - right border
          pre = [0.5_rKind, 1.0_rKind]
      else
          pre = 0.5_rKind
      end if

      if(xx + 1 > ll) then
          if(Rs%pbc .and. (xx == ll)) then
              xx1 = 1
          else
              errst = raise_error('ruleset_to_ham_2site_MATRIXqtensorclist'//&
                                  ' : site xx not valid.', 99, errst=errst)
              return
          end if
      else
          xx1 = xx + 1
      end if

      do ii = 1, Rs%nlxx
          ! Build L^dagger L
          call contr(Tmp, Ops%Li(Rs%Lxx(ii)%o), Ops%Li(Rs%Lxx(ii)%o), &
                     [1], [1], transl='C', errst=errst)
          !if(prop_error('set_first_effmpo_MATRIXqtensorclist_MPO_TYPE'//&
          !              ': contr failed.', 'MPOOps_include.f90:3053', &
          !              errst=errst)) return

          coupl = pre(1) * Rs%Lxx(ii)%w * get_coupl(Hparams, Rs%Lxx(ii)%h, xx)

          call kron(Tmpb, Tmp, Ops%Li(iop), 1, 1, 'N', 'N', 'N')
          call gaxpy(Ham, -0.5_rkInd * eye * coupl, Tmpb, errst=errst)
          !if(prop_error('ruleset_to_ham_2site_MATRIXqtensorclist'//&
          !              ' : gaxpy failed.', 'MPOOps_include.f90:3061', &
          !              errst=errst)) return

          call destroy(Tmpb)

          coupl = pre(2) * Rs%Lxx(ii)%w * get_coupl(Hparams, Rs%Lxx(ii)%h, xx1)

          call kron(Tmpb, Ops%Li(iop), Tmp, 1, 1, 'N', 'N', 'N')
          call gaxpy(Ham, -0.5_rkInd * eye * coupl, Tmpb, errst=errst)
          !if(prop_error('ruleset_to_ham_2site_MATRIXqtensorclist'//&
          !              ' : gaxpy failed.', 'MPOOps_include.f90:3071', &
          !              errst=errst)) return

          call destroy(Tmp)
          call destroy(Tmpb)

      end do

      ! [many-body string lindblad terms (if length is 2)]
      ! --------------------------------------------------

      do ii = 1, Rs%nmbsl
          if(Rs%Mbsl(ii)%n /= 2) cycle

          ! Build L^dagger L on both sites
          call contr(Tmpa, Ops%Li(Rs%Mbsl(ii)%o(1)), &
                     Ops%Li(Rs%Mbsl(ii)%o(1)), [1], [1], transl='C', &
                     errst=errst)
          !if(prop_error('ruleset_to_effham_2site_qtensorclist : '//&
          !              'contr failed.', 'MPOOps_include.f90:3090', &
          !              errst=errst)) return

          call contr(Tmpb, Ops%Li(Rs%Mbsl(ii)%o(2)), &
                     Ops%Li(Rs%Mbsl(ii)%o(2)), [1], [1], transl='C', &
                     errst=errst)
          !if(prop_error('ruleset_to_effham_2site_qtensorclist : '//&
          !              'contr failed.', 'MPOOps_include.f90:3097', &
          !              errst=errst)) return

          coupl = Rs%Mbsl(ii)%w * get_coupl(Hparams, Rs%Mbsl(ii)%h, xx)

          call kron(Tmp, Tmpa, Tmpb, 1, 1, 'N', 'N', 'N')
          call gaxpy(Ham, -0.5_rKind * eye * coupl, Tmp, errst=errst)
          !if(prop_error('ruleset_to_effham_2site_qtensorclist : '//&
          !              'gaxpy failed.', 'MPOOps_include.f90:3105', &
          !              errst=errst)) return

          call destroy(Tmp)
          call destroy(Tmpa)
          call destroy(Tmpb)
      end do

      ! [many-body string Lindblad XY terms] (if length is 2)
      ! ------------------------------------

      do ii = 1, Rs%nmbslxy
          errst = raise_error('ruleset_to_effham_2site_qtensorclist : '//&
                              'no MBSLXY possible.', 99, &
                              'MPOOps_include.f90:3119', errst=errst)
          ! The idea of calculating <A| Ldagger L |A> is violated
          ! here since single term do not hold this relation. Thus,
          ! the next term should be wrong ...

          os = Rs%Mbslxy(ii)%n
          if(os /= 2) cycle

          ! Build L^dagger L on both sites
          call contr(Tmpa, Ops%Li(Rs%Mbslxy(ii)%o(os + 1)), &
                     Ops%Li(Rs%Mbslxy(ii)%o(1)), [1], [1], transl='C', &
                     errst=errst)
          !if(prop_error('ruleset_to_effham_2site_qtensorclist : '//&
          !              'contr failed.', 'MPOOps_include.f90:3132', &
          !              errst=errst)) return

          call contr(Tmpb, Ops%Li(Rs%Mbslxy(ii)%o(os + 2)), &
                     Ops%Li(Rs%Mbslxy(ii)%o(2)), [1], [1], transl='C', &
                     errst=errst)
          !if(prop_error('ruleset_to_effham_2site_qtensorclist : '//&
          !              'contr failed.', 'MPOOps_include.f90:3139', &
          !              errst=errst)) return

          coupl = Rs%Mbslxy(ii)%w * get_coupl(Hparams, Rs%Mbslxy(ii)%h, xx)

          call kron(Tmp, Tmpa, Tmpb, 1, 1, 'N', 'N', 'N')
          call gaxpy(Ham, -0.5_rKind * eye * coupl, Tmp, errst=errst)
          !if(prop_error('ruleset_to_effham_2site_qtensorclist : '//&
          !              'gaxpy failed.', 'MPOOps_include.f90:3147', &
          !              errst=errst)) return

          call destroy(Tmp)
          call destroy(Tmpa)
          call destroy(Tmpb)
      end do

  end subroutine ruleset_to_effham_2site_qtensorclist

MPOOps_f90.ruleset_to_clliou_2site_tensor_tensorlist()

fortran-subroutine - September 2017 (dj) Build a two-site Liouville operator for Liouville space (closed system, Hamiltonian only).

Arguments

LiouTYPE(tensor), inout

On exit, the Liouville operator as rank-4 tensor.

xxINTEGER, in

Get Liouville operator for sites xx, xx+1

RsTYPE(MPORuleSet), in

Contains the rule set to build up the MPO.

OpsTYPE(tensorlist), in

List containing all operators for the evolution

HparamsTYPE(HamiltonianParameters), in

containing the couplings for each operator

iopINTEGER, in

The index of the identity in the operator list.

is_initLOGICAL, OPTIONAL, out

If true, Liou has already been initialized. If false, no terms were added up to now.

scconjspaceREAL, OPTIONAL, in

Scalar to be multplied with conjugate space. Default to 1.0 for imaginary time evolution. Set to -1.0 for Hamiltonian evolution.

Details

The following rules are considered : site rules for the Hamiltonian, bond rules for the Hamiltonian, site rules for Lindblad operators.

Source Code

show / hide f90 code

  subroutine ruleset_to_clliou_2site_tensor_tensorlist(Liou, xx, ll, &
       Rs, Ops, Hparams, iop, is_init, scconjspace, errst)
      type(tensor), intent(inout) :: Liou
      integer, intent(in) :: xx, ll
      type(MPORuleSet), intent(in) :: Rs
      type(tensorlist), intent(in) :: Ops
      type(HamiltonianParameters), pointer, intent(in) :: Hparams(:)
      integer, intent(in) :: iop
      logical, intent(out), optional :: is_init
      real(KIND=rKind), intent(in), optional :: scconjspace
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! first index for lindblads / bond rule
      integer :: i1

      ! position of the site xx+1
      integer :: xx1

      ! Flag if operator already initialized
      logical :: is_init_

      ! scalar to be multiplied with conjugated Hilbert space
      real(KIND=rKind) :: cstar

      ! indices for fusing
      integer, dimension(2, 2) :: fidx

      ! couplings including weight, hparams etc
      real(KIND=rKind) :: coupl1, coupl2

      ! prefactor considering boundary effects in PBC/OPC
      real(KIND=rKind), dimension(2) :: pre

      ! temporary matrix to calculate the next hamiltonian contribution
      type(tensor) :: Tmpa, Tmpb, Tmpc, Leye

      !if(present(errst)) errst = 0

      is_init_ = .false.

      if(present(scconjspace)) then
          cstar = scconjspace
      else
          cstar = 1.0_rKind
      end if

      ! generate identity in Liouville space
      call kron(Leye, Ops%Li(iop), Ops%Li(iop), 1, 1, 'N', 'N', 'N')

      fidx = reshape([1, 2, 3, 4], [2, 2])
      call fuse(Leye, fidx, '0', errst=errst)
      !if(prop_error('ruleset_to_clliou_2site_tensor_tensorlist: '//&
      !              'fuse (1) failed.', 'MPOOps_include.f90:3290', errst=errst)) return

      ! [local site]
      ! ------------

      if(Rs%pbc) then
          ! Periodic boundary condition - every local term appears twice
          pre = 0.5_rKind
      elseif((xx == 1) .and. (xx == ll - 1)) then
          ! Open boundary conditions - system consists of two sites
          pre = 1.0_rKind
      elseif(xx == 1) then
          ! Open boundary conditions - left border
          pre = [1.0_rKind, 0.5_rKind]
      elseif(xx == ll - 1) then
          ! Open boundary conditions - right border
          pre = [0.5_rKind, 1.0_rKind]
      else
          pre = 0.5_rKind
      end if

      if(xx + 1 > ll) then
          if(Rs%pbc .and. (xx == ll)) then
              xx1 = 1
          else
              errst = raise_error('ruleset_to_ham_2site_tensorlist'//&
                                  ' : site xx not valid.', 99, errst=errst)
              return
          end if
      else
          xx1 = xx + 1
      end if

      do ii = 1, Rs%nsite
          coupl1 = pre(1) * Rs%S(ii)%w * get_coupl(Hparams, Rs%S(ii)%h, xx)
          coupl2 = pre(2) * Rs%S(ii)%w * get_coupl(Hparams, Rs%S(ii)%h, xx1)

          ! (H_1 x I_1) x (I_2 x I_2)
          call kron(Tmpa, Ops%Li(Rs%S(ii)%o), Ops%Li(iop), 1, 1, 'N', 'N', 'N')
          call fuse(Tmpa, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_clliou_2site_tensor_tensorlist: '//&
          !              'fuse (2) failed.', 'MPOOps_include.f90:3331', &
          !              errst=errst)) return

          if(ii == 1) then
              call kron(Liou, Tmpa, Leye, 1, 1, 'N', 'N', 'N')
              call scale(coupl1, Liou)
              is_init_ = .true.
          else
              call kron(Tmpb, Tmpa, Leye, 1, 1, 'N', 'N', 'N')
              call gaxpy(Liou, coupl1, Tmpb)
              call destroy(Tmpb)
          end if

          ! (I_1 x I_1) x (H_2 x I_2)
          call kron(Tmpb, Leye, Tmpa, 1, 1, 'N', 'N', 'N')
          call gaxpy(Liou, coupl2, Tmpb)
          call destroy(Tmpa)
          call destroy(Tmpb)

          ! (I_1 x H_1^T) x (I_2 x I_2)
          call kron(Tmpa, Ops%Li(iop), Ops%Li(Rs%S(ii)%o), 1, 1, 'N', 'T', 'N')
          call fuse(Tmpa, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_clliou_2site_tensor_tensorlist: '//&
          !              'fuse (3) failed.', 'MPOOps_include.f90:3354', &
          !              errst=errst)) return

          call kron(Tmpb, Tmpa, Leye, 1, 1, 'N', 'N', 'N')
          call gaxpy(Liou, cstar * coupl1, Tmpb)
          call destroy(Tmpb)

          ! (I_1 x I_1) x (I_2 x H_2^T)
          call kron(Tmpb, Leye, Tmpa, 1, 1, 'N', 'N', 'N')
          call gaxpy(Liou, cstar * coupl2, Tmpb)
          call destroy(Tmpa)
          call destroy(Tmpb)
      end do

      ! [bond rules]
      ! ------------

      do ii = 1, Rs%nbond
          coupl1 = Rs%B(ii)%w * get_coupl(Hparams, Rs%B(ii)%h, xx)

          ! (H_1 x I_1) x (H_2 x I_2)
          call kron(Tmpa, Ops%Li(Rs%B(ii)%ol), Ops%Li(iop), 1, 1, 'N', 'N', 'N')
          call fuse(Tmpa, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_clliou_2site_tensor_tensorlist: '//&
          !              'fuse (4) failed.', 'MPOOps_include.f90:3378', &
          !              errst=errst)) return

          call kron(Tmpb, Ops%Li(Rs%B(ii)%or), Ops%Li(iop), 1, 1, 'N', 'N', 'N')
          call fuse(Tmpb, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_clliou_2site_tensor_tensorlist: '//&
          !              'fuse (5) failed.', 'MPOOps_include.f90:3384', &
          !              errst=errst)) return

          if(is_init_) then
              call kron(Tmpc, Tmpa, Tmpb, 1, 1, 'N', 'N', 'N')
              call gaxpy(Liou, coupl1, Tmpc)
              call destroy(Tmpc)
          else
              call kron(Liou, Tmpa, Tmpb, 1, 1, 'N', 'N', 'N')
              call scale(coupl1, Liou)
              is_init_ = .true.
          end if

          call destroy(Tmpa)
          call destroy(Tmpb)

          ! (I_1 x H_1^T) x (I_2 x H_2^T)
          call kron(Tmpa, Ops%Li(iop), Ops%Li(Rs%B(ii)%ol), 1, 1, 'N', 'T', 'N')
          call fuse(Tmpa, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_clliou_2site_tensor_tensorlist: '//&
          !              'fuse (6) failed.', 'MPOOps_include.f90:3404', &
          !              errst=errst)) return

          call kron(Tmpb, Ops%Li(iop), Ops%Li(Rs%B(ii)%or), 1, 1, 'N', 'T', 'N')
          call fuse(Tmpb, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_clliou_2site_tensor_tensorlist: '//&
          !              'fuse (7) failed.', 'MPOOps_include.f90:3410', &
          !              errst=errst)) return

          call kron(Tmpc, Tmpa, Tmpb, 1, 1, 'N', 'N', 'N')
          call gaxpy(Liou, cstar * coupl1, Tmpc)

          call destroy(Tmpa)
          call destroy(Tmpb)
          call destroy(Tmpc)
      end do

      ! For symmetric tensor, we have to add the diagonal blocks with
      ! zero values (zero block => identity in the exponential)
      if(.false.) then
          call kron(Tmpa, Leye, Leye, 1, 1, 'N', 'N', 'N')
          if(is_init_) then
              call gaxpy(Liou, 0.0_rKind, Tmpa, errst=errst)
              !if(prop_error('ruleset_to_clliou_2site_tensor_tensorlist'//&
              !              ' : gaxpy failed.', 'MPOOps_include.f90:3428', &
              !              errst=errst)) return
          else
              call copy(Liou, Tmpa, scalar=dzero)
              is_init_ = .true.
          end if

          call destroy(Tmpa)
      end if

      call destroy(Leye)

      if(present(is_init)) is_init = is_init_

  end subroutine ruleset_to_clliou_2site_tensor_tensorlist

MPOOps_f90.ruleset_to_clliou_2site_tensorc_tensorlist()

fortran-subroutine - September 2017 (dj) Build a two-site Liouville operator for Liouville space (closed system, Hamiltonian only).

Arguments

LiouTYPE(tensorc), inout

On exit, the Liouville operator as rank-4 tensor.

xxINTEGER, in

Get Liouville operator for sites xx, xx+1

RsTYPE(MPORuleSet), in

Contains the rule set to build up the MPO.

OpsTYPE(tensorlist), in

List containing all operators for the evolution

HparamsTYPE(HamiltonianParameters), in

containing the couplings for each operator

iopINTEGER, in

The index of the identity in the operator list.

is_initLOGICAL, OPTIONAL, out

If true, Liou has already been initialized. If false, no terms were added up to now.

scconjspaceREAL, OPTIONAL, in

Scalar to be multplied with conjugate space. Default to 1.0 for imaginary time evolution. Set to -1.0 for Hamiltonian evolution.

Details

The following rules are considered : site rules for the Hamiltonian, bond rules for the Hamiltonian, site rules for Lindblad operators.

Source Code

show / hide f90 code

  subroutine ruleset_to_clliou_2site_tensorc_tensorlist(Liou, xx, ll, &
       Rs, Ops, Hparams, iop, is_init, scconjspace, errst)
      type(tensorc), intent(inout) :: Liou
      integer, intent(in) :: xx, ll
      type(MPORuleSet), intent(in) :: Rs
      type(tensorlist), intent(in) :: Ops
      type(HamiltonianParameters), pointer, intent(in) :: Hparams(:)
      integer, intent(in) :: iop
      logical, intent(out), optional :: is_init
      real(KIND=rKind), intent(in), optional :: scconjspace
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! first index for lindblads / bond rule
      integer :: i1

      ! position of the site xx+1
      integer :: xx1

      ! Flag if operator already initialized
      logical :: is_init_

      ! scalar to be multiplied with conjugated Hilbert space
      real(KIND=rKind) :: cstar

      ! indices for fusing
      integer, dimension(2, 2) :: fidx

      ! couplings including weight, hparams etc
      real(KIND=rKind) :: coupl1, coupl2

      ! prefactor considering boundary effects in PBC/OPC
      real(KIND=rKind), dimension(2) :: pre

      ! temporary matrix to calculate the next hamiltonian contribution
      type(tensor) :: Tmpa, Tmpb, Tmpc, Leye

      !if(present(errst)) errst = 0

      is_init_ = .false.

      if(present(scconjspace)) then
          cstar = scconjspace
      else
          cstar = 1.0_rKind
      end if

      ! generate identity in Liouville space
      call kron(Leye, Ops%Li(iop), Ops%Li(iop), 1, 1, 'N', 'N', 'N')

      fidx = reshape([1, 2, 3, 4], [2, 2])
      call fuse(Leye, fidx, '0', errst=errst)
      !if(prop_error('ruleset_to_clliou_2site_tensorc_tensorlist: '//&
      !              'fuse (1) failed.', 'MPOOps_include.f90:3290', errst=errst)) return

      ! [local site]
      ! ------------

      if(Rs%pbc) then
          ! Periodic boundary condition - every local term appears twice
          pre = 0.5_rKind
      elseif((xx == 1) .and. (xx == ll - 1)) then
          ! Open boundary conditions - system consists of two sites
          pre = 1.0_rKind
      elseif(xx == 1) then
          ! Open boundary conditions - left border
          pre = [1.0_rKind, 0.5_rKind]
      elseif(xx == ll - 1) then
          ! Open boundary conditions - right border
          pre = [0.5_rKind, 1.0_rKind]
      else
          pre = 0.5_rKind
      end if

      if(xx + 1 > ll) then
          if(Rs%pbc .and. (xx == ll)) then
              xx1 = 1
          else
              errst = raise_error('ruleset_to_ham_2site_tensorlist'//&
                                  ' : site xx not valid.', 99, errst=errst)
              return
          end if
      else
          xx1 = xx + 1
      end if

      do ii = 1, Rs%nsite
          coupl1 = pre(1) * Rs%S(ii)%w * get_coupl(Hparams, Rs%S(ii)%h, xx)
          coupl2 = pre(2) * Rs%S(ii)%w * get_coupl(Hparams, Rs%S(ii)%h, xx1)

          ! (H_1 x I_1) x (I_2 x I_2)
          call kron(Tmpa, Ops%Li(Rs%S(ii)%o), Ops%Li(iop), 1, 1, 'N', 'N', 'N')
          call fuse(Tmpa, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_clliou_2site_tensorc_tensorlist: '//&
          !              'fuse (2) failed.', 'MPOOps_include.f90:3331', &
          !              errst=errst)) return

          if(ii == 1) then
              call kron(Liou, Tmpa, Leye, 1, 1, 'N', 'N', 'N')
              call scale(coupl1, Liou)
              is_init_ = .true.
          else
              call kron(Tmpb, Tmpa, Leye, 1, 1, 'N', 'N', 'N')
              call gaxpy(Liou, coupl1, Tmpb)
              call destroy(Tmpb)
          end if

          ! (I_1 x I_1) x (H_2 x I_2)
          call kron(Tmpb, Leye, Tmpa, 1, 1, 'N', 'N', 'N')
          call gaxpy(Liou, coupl2, Tmpb)
          call destroy(Tmpa)
          call destroy(Tmpb)

          ! (I_1 x H_1^T) x (I_2 x I_2)
          call kron(Tmpa, Ops%Li(iop), Ops%Li(Rs%S(ii)%o), 1, 1, 'N', 'T', 'N')
          call fuse(Tmpa, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_clliou_2site_tensorc_tensorlist: '//&
          !              'fuse (3) failed.', 'MPOOps_include.f90:3354', &
          !              errst=errst)) return

          call kron(Tmpb, Tmpa, Leye, 1, 1, 'N', 'N', 'N')
          call gaxpy(Liou, cstar * coupl1, Tmpb)
          call destroy(Tmpb)

          ! (I_1 x I_1) x (I_2 x H_2^T)
          call kron(Tmpb, Leye, Tmpa, 1, 1, 'N', 'N', 'N')
          call gaxpy(Liou, cstar * coupl2, Tmpb)
          call destroy(Tmpa)
          call destroy(Tmpb)
      end do

      ! [bond rules]
      ! ------------

      do ii = 1, Rs%nbond
          coupl1 = Rs%B(ii)%w * get_coupl(Hparams, Rs%B(ii)%h, xx)

          ! (H_1 x I_1) x (H_2 x I_2)
          call kron(Tmpa, Ops%Li(Rs%B(ii)%ol), Ops%Li(iop), 1, 1, 'N', 'N', 'N')
          call fuse(Tmpa, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_clliou_2site_tensorc_tensorlist: '//&
          !              'fuse (4) failed.', 'MPOOps_include.f90:3378', &
          !              errst=errst)) return

          call kron(Tmpb, Ops%Li(Rs%B(ii)%or), Ops%Li(iop), 1, 1, 'N', 'N', 'N')
          call fuse(Tmpb, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_clliou_2site_tensorc_tensorlist: '//&
          !              'fuse (5) failed.', 'MPOOps_include.f90:3384', &
          !              errst=errst)) return

          if(is_init_) then
              call kron(Tmpc, Tmpa, Tmpb, 1, 1, 'N', 'N', 'N')
              call gaxpy(Liou, coupl1, Tmpc)
              call destroy(Tmpc)
          else
              call kron(Liou, Tmpa, Tmpb, 1, 1, 'N', 'N', 'N')
              call scale(coupl1, Liou)
              is_init_ = .true.
          end if

          call destroy(Tmpa)
          call destroy(Tmpb)

          ! (I_1 x H_1^T) x (I_2 x H_2^T)
          call kron(Tmpa, Ops%Li(iop), Ops%Li(Rs%B(ii)%ol), 1, 1, 'N', 'T', 'N')
          call fuse(Tmpa, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_clliou_2site_tensorc_tensorlist: '//&
          !              'fuse (6) failed.', 'MPOOps_include.f90:3404', &
          !              errst=errst)) return

          call kron(Tmpb, Ops%Li(iop), Ops%Li(Rs%B(ii)%or), 1, 1, 'N', 'T', 'N')
          call fuse(Tmpb, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_clliou_2site_tensorc_tensorlist: '//&
          !              'fuse (7) failed.', 'MPOOps_include.f90:3410', &
          !              errst=errst)) return

          call kron(Tmpc, Tmpa, Tmpb, 1, 1, 'N', 'N', 'N')
          call gaxpy(Liou, cstar * coupl1, Tmpc)

          call destroy(Tmpa)
          call destroy(Tmpb)
          call destroy(Tmpc)
      end do

      ! For symmetric tensor, we have to add the diagonal blocks with
      ! zero values (zero block => identity in the exponential)
      if(.false.) then
          call kron(Tmpa, Leye, Leye, 1, 1, 'N', 'N', 'N')
          if(is_init_) then
              call gaxpy(Liou, 0.0_rKind, Tmpa, errst=errst)
              !if(prop_error('ruleset_to_clliou_2site_tensorc_tensorlist'//&
              !              ' : gaxpy failed.', 'MPOOps_include.f90:3428', &
              !              errst=errst)) return
          else
              call copy(Liou, Tmpa, scalar=zzero)
              is_init_ = .true.
          end if

          call destroy(Tmpa)
      end if

      call destroy(Leye)

      if(present(is_init)) is_init = is_init_

  end subroutine ruleset_to_clliou_2site_tensorc_tensorlist

MPOOps_f90.ruleset_to_clliou_2site_tensorc_tensorlistc()

fortran-subroutine - September 2017 (dj) Build a two-site Liouville operator for Liouville space (closed system, Hamiltonian only).

Arguments

LiouTYPE(tensorc), inout

On exit, the Liouville operator as rank-4 tensor.

xxINTEGER, in

Get Liouville operator for sites xx, xx+1

RsTYPE(MPORuleSet), in

Contains the rule set to build up the MPO.

OpsTYPE(tensorlistc), in

List containing all operators for the evolution

HparamsTYPE(HamiltonianParameters), in

containing the couplings for each operator

iopINTEGER, in

The index of the identity in the operator list.

is_initLOGICAL, OPTIONAL, out

If true, Liou has already been initialized. If false, no terms were added up to now.

scconjspaceREAL, OPTIONAL, in

Scalar to be multplied with conjugate space. Default to 1.0 for imaginary time evolution. Set to -1.0 for Hamiltonian evolution.

Details

The following rules are considered : site rules for the Hamiltonian, bond rules for the Hamiltonian, site rules for Lindblad operators.

Source Code

show / hide f90 code

  subroutine ruleset_to_clliou_2site_tensorc_tensorlistc(Liou, xx, ll, &
       Rs, Ops, Hparams, iop, is_init, scconjspace, errst)
      type(tensorc), intent(inout) :: Liou
      integer, intent(in) :: xx, ll
      type(MPORuleSet), intent(in) :: Rs
      type(tensorlistc), intent(in) :: Ops
      type(HamiltonianParameters), pointer, intent(in) :: Hparams(:)
      integer, intent(in) :: iop
      logical, intent(out), optional :: is_init
      real(KIND=rKind), intent(in), optional :: scconjspace
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! first index for lindblads / bond rule
      integer :: i1

      ! position of the site xx+1
      integer :: xx1

      ! Flag if operator already initialized
      logical :: is_init_

      ! scalar to be multiplied with conjugated Hilbert space
      real(KIND=rKind) :: cstar

      ! indices for fusing
      integer, dimension(2, 2) :: fidx

      ! couplings including weight, hparams etc
      real(KIND=rKind) :: coupl1, coupl2

      ! prefactor considering boundary effects in PBC/OPC
      real(KIND=rKind), dimension(2) :: pre

      ! temporary matrix to calculate the next hamiltonian contribution
      type(tensorc) :: Tmpa, Tmpb, Tmpc, Leye

      !if(present(errst)) errst = 0

      is_init_ = .false.

      if(present(scconjspace)) then
          cstar = scconjspace
      else
          cstar = 1.0_rKind
      end if

      ! generate identity in Liouville space
      call kron(Leye, Ops%Li(iop), Ops%Li(iop), 1, 1, 'N', 'N', 'N')

      fidx = reshape([1, 2, 3, 4], [2, 2])
      call fuse(Leye, fidx, '0', errst=errst)
      !if(prop_error('ruleset_to_clliou_2site_tensorc_tensorlistc: '//&
      !              'fuse (1) failed.', 'MPOOps_include.f90:3290', errst=errst)) return

      ! [local site]
      ! ------------

      if(Rs%pbc) then
          ! Periodic boundary condition - every local term appears twice
          pre = 0.5_rKind
      elseif((xx == 1) .and. (xx == ll - 1)) then
          ! Open boundary conditions - system consists of two sites
          pre = 1.0_rKind
      elseif(xx == 1) then
          ! Open boundary conditions - left border
          pre = [1.0_rKind, 0.5_rKind]
      elseif(xx == ll - 1) then
          ! Open boundary conditions - right border
          pre = [0.5_rKind, 1.0_rKind]
      else
          pre = 0.5_rKind
      end if

      if(xx + 1 > ll) then
          if(Rs%pbc .and. (xx == ll)) then
              xx1 = 1
          else
              errst = raise_error('ruleset_to_ham_2site_tensorlistc'//&
                                  ' : site xx not valid.', 99, errst=errst)
              return
          end if
      else
          xx1 = xx + 1
      end if

      do ii = 1, Rs%nsite
          coupl1 = pre(1) * Rs%S(ii)%w * get_coupl(Hparams, Rs%S(ii)%h, xx)
          coupl2 = pre(2) * Rs%S(ii)%w * get_coupl(Hparams, Rs%S(ii)%h, xx1)

          ! (H_1 x I_1) x (I_2 x I_2)
          call kron(Tmpa, Ops%Li(Rs%S(ii)%o), Ops%Li(iop), 1, 1, 'N', 'N', 'N')
          call fuse(Tmpa, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_clliou_2site_tensorc_tensorlistc: '//&
          !              'fuse (2) failed.', 'MPOOps_include.f90:3331', &
          !              errst=errst)) return

          if(ii == 1) then
              call kron(Liou, Tmpa, Leye, 1, 1, 'N', 'N', 'N')
              call scale(coupl1, Liou)
              is_init_ = .true.
          else
              call kron(Tmpb, Tmpa, Leye, 1, 1, 'N', 'N', 'N')
              call gaxpy(Liou, coupl1, Tmpb)
              call destroy(Tmpb)
          end if

          ! (I_1 x I_1) x (H_2 x I_2)
          call kron(Tmpb, Leye, Tmpa, 1, 1, 'N', 'N', 'N')
          call gaxpy(Liou, coupl2, Tmpb)
          call destroy(Tmpa)
          call destroy(Tmpb)

          ! (I_1 x H_1^T) x (I_2 x I_2)
          call kron(Tmpa, Ops%Li(iop), Ops%Li(Rs%S(ii)%o), 1, 1, 'N', 'T', 'N')
          call fuse(Tmpa, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_clliou_2site_tensorc_tensorlistc: '//&
          !              'fuse (3) failed.', 'MPOOps_include.f90:3354', &
          !              errst=errst)) return

          call kron(Tmpb, Tmpa, Leye, 1, 1, 'N', 'N', 'N')
          call gaxpy(Liou, cstar * coupl1, Tmpb)
          call destroy(Tmpb)

          ! (I_1 x I_1) x (I_2 x H_2^T)
          call kron(Tmpb, Leye, Tmpa, 1, 1, 'N', 'N', 'N')
          call gaxpy(Liou, cstar * coupl2, Tmpb)
          call destroy(Tmpa)
          call destroy(Tmpb)
      end do

      ! [bond rules]
      ! ------------

      do ii = 1, Rs%nbond
          coupl1 = Rs%B(ii)%w * get_coupl(Hparams, Rs%B(ii)%h, xx)

          ! (H_1 x I_1) x (H_2 x I_2)
          call kron(Tmpa, Ops%Li(Rs%B(ii)%ol), Ops%Li(iop), 1, 1, 'N', 'N', 'N')
          call fuse(Tmpa, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_clliou_2site_tensorc_tensorlistc: '//&
          !              'fuse (4) failed.', 'MPOOps_include.f90:3378', &
          !              errst=errst)) return

          call kron(Tmpb, Ops%Li(Rs%B(ii)%or), Ops%Li(iop), 1, 1, 'N', 'N', 'N')
          call fuse(Tmpb, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_clliou_2site_tensorc_tensorlistc: '//&
          !              'fuse (5) failed.', 'MPOOps_include.f90:3384', &
          !              errst=errst)) return

          if(is_init_) then
              call kron(Tmpc, Tmpa, Tmpb, 1, 1, 'N', 'N', 'N')
              call gaxpy(Liou, coupl1, Tmpc)
              call destroy(Tmpc)
          else
              call kron(Liou, Tmpa, Tmpb, 1, 1, 'N', 'N', 'N')
              call scale(coupl1, Liou)
              is_init_ = .true.
          end if

          call destroy(Tmpa)
          call destroy(Tmpb)

          ! (I_1 x H_1^T) x (I_2 x H_2^T)
          call kron(Tmpa, Ops%Li(iop), Ops%Li(Rs%B(ii)%ol), 1, 1, 'N', 'T', 'N')
          call fuse(Tmpa, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_clliou_2site_tensorc_tensorlistc: '//&
          !              'fuse (6) failed.', 'MPOOps_include.f90:3404', &
          !              errst=errst)) return

          call kron(Tmpb, Ops%Li(iop), Ops%Li(Rs%B(ii)%or), 1, 1, 'N', 'T', 'N')
          call fuse(Tmpb, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_clliou_2site_tensorc_tensorlistc: '//&
          !              'fuse (7) failed.', 'MPOOps_include.f90:3410', &
          !              errst=errst)) return

          call kron(Tmpc, Tmpa, Tmpb, 1, 1, 'N', 'N', 'N')
          call gaxpy(Liou, cstar * coupl1, Tmpc)

          call destroy(Tmpa)
          call destroy(Tmpb)
          call destroy(Tmpc)
      end do

      ! For symmetric tensor, we have to add the diagonal blocks with
      ! zero values (zero block => identity in the exponential)
      if(.false.) then
          call kron(Tmpa, Leye, Leye, 1, 1, 'N', 'N', 'N')
          if(is_init_) then
              call gaxpy(Liou, 0.0_rKind, Tmpa, errst=errst)
              !if(prop_error('ruleset_to_clliou_2site_tensorc_tensorlistc'//&
              !              ' : gaxpy failed.', 'MPOOps_include.f90:3428', &
              !              errst=errst)) return
          else
              call copy(Liou, Tmpa, scalar=zzero)
              is_init_ = .true.
          end if

          call destroy(Tmpa)
      end if

      call destroy(Leye)

      if(present(is_init)) is_init = is_init_

  end subroutine ruleset_to_clliou_2site_tensorc_tensorlistc

MPOOps_f90.ruleset_to_clliou_2site_qtensor_qtensorlist()

fortran-subroutine - September 2017 (dj) Build a two-site Liouville operator for Liouville space (closed system, Hamiltonian only).

Arguments

LiouTYPE(qtensor), inout

On exit, the Liouville operator as rank-4 tensor.

xxINTEGER, in

Get Liouville operator for sites xx, xx+1

RsTYPE(MPORuleSet), in

Contains the rule set to build up the MPO.

OpsTYPE(qtensorlist), in

List containing all operators for the evolution

HparamsTYPE(HamiltonianParameters), in

containing the couplings for each operator

iopINTEGER, in

The index of the identity in the operator list.

is_initLOGICAL, OPTIONAL, out

If true, Liou has already been initialized. If false, no terms were added up to now.

scconjspaceREAL, OPTIONAL, in

Scalar to be multplied with conjugate space. Default to 1.0 for imaginary time evolution. Set to -1.0 for Hamiltonian evolution.

Details

The following rules are considered : site rules for the Hamiltonian, bond rules for the Hamiltonian, site rules for Lindblad operators.

Source Code

show / hide f90 code

  subroutine ruleset_to_clliou_2site_qtensor_qtensorlist(Liou, xx, ll, &
       Rs, Ops, Hparams, iop, is_init, scconjspace, errst)
      type(qtensor), intent(inout) :: Liou
      integer, intent(in) :: xx, ll
      type(MPORuleSet), intent(in) :: Rs
      type(qtensorlist), intent(in) :: Ops
      type(HamiltonianParameters), pointer, intent(in) :: Hparams(:)
      integer, intent(in) :: iop
      logical, intent(out), optional :: is_init
      real(KIND=rKind), intent(in), optional :: scconjspace
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! first index for lindblads / bond rule
      integer :: i1

      ! position of the site xx+1
      integer :: xx1

      ! Flag if operator already initialized
      logical :: is_init_

      ! scalar to be multiplied with conjugated Hilbert space
      real(KIND=rKind) :: cstar

      ! indices for fusing
      integer, dimension(2, 2) :: fidx

      ! couplings including weight, hparams etc
      real(KIND=rKind) :: coupl1, coupl2

      ! prefactor considering boundary effects in PBC/OPC
      real(KIND=rKind), dimension(2) :: pre

      ! temporary matrix to calculate the next hamiltonian contribution
      type(qtensor) :: Tmpa, Tmpb, Tmpc, Leye

      !if(present(errst)) errst = 0

      is_init_ = .false.

      if(present(scconjspace)) then
          cstar = scconjspace
      else
          cstar = 1.0_rKind
      end if

      ! generate identity in Liouville space
      call kron(Leye, Ops%Li(iop), Ops%Li(iop), 1, 1, 'N', 'N', 'N')

      fidx = reshape([1, 2, 3, 4], [2, 2])
      call fuse(Leye, fidx, '0', errst=errst)
      !if(prop_error('ruleset_to_clliou_2site_qtensor_qtensorlist: '//&
      !              'fuse (1) failed.', 'MPOOps_include.f90:3290', errst=errst)) return

      ! [local site]
      ! ------------

      if(Rs%pbc) then
          ! Periodic boundary condition - every local term appears twice
          pre = 0.5_rKind
      elseif((xx == 1) .and. (xx == ll - 1)) then
          ! Open boundary conditions - system consists of two sites
          pre = 1.0_rKind
      elseif(xx == 1) then
          ! Open boundary conditions - left border
          pre = [1.0_rKind, 0.5_rKind]
      elseif(xx == ll - 1) then
          ! Open boundary conditions - right border
          pre = [0.5_rKind, 1.0_rKind]
      else
          pre = 0.5_rKind
      end if

      if(xx + 1 > ll) then
          if(Rs%pbc .and. (xx == ll)) then
              xx1 = 1
          else
              errst = raise_error('ruleset_to_ham_2site_qtensorlist'//&
                                  ' : site xx not valid.', 99, errst=errst)
              return
          end if
      else
          xx1 = xx + 1
      end if

      do ii = 1, Rs%nsite
          coupl1 = pre(1) * Rs%S(ii)%w * get_coupl(Hparams, Rs%S(ii)%h, xx)
          coupl2 = pre(2) * Rs%S(ii)%w * get_coupl(Hparams, Rs%S(ii)%h, xx1)

          ! (H_1 x I_1) x (I_2 x I_2)
          call kron(Tmpa, Ops%Li(Rs%S(ii)%o), Ops%Li(iop), 1, 1, 'N', 'N', 'N')
          call fuse(Tmpa, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_clliou_2site_qtensor_qtensorlist: '//&
          !              'fuse (2) failed.', 'MPOOps_include.f90:3331', &
          !              errst=errst)) return

          if(ii == 1) then
              call kron(Liou, Tmpa, Leye, 1, 1, 'N', 'N', 'N')
              call scale(coupl1, Liou)
              is_init_ = .true.
          else
              call kron(Tmpb, Tmpa, Leye, 1, 1, 'N', 'N', 'N')
              call gaxpy(Liou, coupl1, Tmpb)
              call destroy(Tmpb)
          end if

          ! (I_1 x I_1) x (H_2 x I_2)
          call kron(Tmpb, Leye, Tmpa, 1, 1, 'N', 'N', 'N')
          call gaxpy(Liou, coupl2, Tmpb)
          call destroy(Tmpa)
          call destroy(Tmpb)

          ! (I_1 x H_1^T) x (I_2 x I_2)
          call kron(Tmpa, Ops%Li(iop), Ops%Li(Rs%S(ii)%o), 1, 1, 'N', 'T', 'N')
          call fuse(Tmpa, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_clliou_2site_qtensor_qtensorlist: '//&
          !              'fuse (3) failed.', 'MPOOps_include.f90:3354', &
          !              errst=errst)) return

          call kron(Tmpb, Tmpa, Leye, 1, 1, 'N', 'N', 'N')
          call gaxpy(Liou, cstar * coupl1, Tmpb)
          call destroy(Tmpb)

          ! (I_1 x I_1) x (I_2 x H_2^T)
          call kron(Tmpb, Leye, Tmpa, 1, 1, 'N', 'N', 'N')
          call gaxpy(Liou, cstar * coupl2, Tmpb)
          call destroy(Tmpa)
          call destroy(Tmpb)
      end do

      ! [bond rules]
      ! ------------

      do ii = 1, Rs%nbond
          coupl1 = Rs%B(ii)%w * get_coupl(Hparams, Rs%B(ii)%h, xx)

          ! (H_1 x I_1) x (H_2 x I_2)
          call kron(Tmpa, Ops%Li(Rs%B(ii)%ol), Ops%Li(iop), 1, 1, 'N', 'N', 'N')
          call fuse(Tmpa, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_clliou_2site_qtensor_qtensorlist: '//&
          !              'fuse (4) failed.', 'MPOOps_include.f90:3378', &
          !              errst=errst)) return

          call kron(Tmpb, Ops%Li(Rs%B(ii)%or), Ops%Li(iop), 1, 1, 'N', 'N', 'N')
          call fuse(Tmpb, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_clliou_2site_qtensor_qtensorlist: '//&
          !              'fuse (5) failed.', 'MPOOps_include.f90:3384', &
          !              errst=errst)) return

          if(is_init_) then
              call kron(Tmpc, Tmpa, Tmpb, 1, 1, 'N', 'N', 'N')
              call gaxpy(Liou, coupl1, Tmpc)
              call destroy(Tmpc)
          else
              call kron(Liou, Tmpa, Tmpb, 1, 1, 'N', 'N', 'N')
              call scale(coupl1, Liou)
              is_init_ = .true.
          end if

          call destroy(Tmpa)
          call destroy(Tmpb)

          ! (I_1 x H_1^T) x (I_2 x H_2^T)
          call kron(Tmpa, Ops%Li(iop), Ops%Li(Rs%B(ii)%ol), 1, 1, 'N', 'T', 'N')
          call fuse(Tmpa, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_clliou_2site_qtensor_qtensorlist: '//&
          !              'fuse (6) failed.', 'MPOOps_include.f90:3404', &
          !              errst=errst)) return

          call kron(Tmpb, Ops%Li(iop), Ops%Li(Rs%B(ii)%or), 1, 1, 'N', 'T', 'N')
          call fuse(Tmpb, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_clliou_2site_qtensor_qtensorlist: '//&
          !              'fuse (7) failed.', 'MPOOps_include.f90:3410', &
          !              errst=errst)) return

          call kron(Tmpc, Tmpa, Tmpb, 1, 1, 'N', 'N', 'N')
          call gaxpy(Liou, cstar * coupl1, Tmpc)

          call destroy(Tmpa)
          call destroy(Tmpb)
          call destroy(Tmpc)
      end do

      ! For symmetric tensor, we have to add the diagonal blocks with
      ! zero values (zero block => identity in the exponential)
      if(.true.) then
          call kron(Tmpa, Leye, Leye, 1, 1, 'N', 'N', 'N')
          if(is_init_) then
              call gaxpy(Liou, 0.0_rKind, Tmpa, errst=errst)
              !if(prop_error('ruleset_to_clliou_2site_qtensor_qtensorlist'//&
              !              ' : gaxpy failed.', 'MPOOps_include.f90:3428', &
              !              errst=errst)) return
          else
              call copy(Liou, Tmpa, scalar=dzero)
              is_init_ = .true.
          end if

          call destroy(Tmpa)
      end if

      call destroy(Leye)

      if(present(is_init)) is_init = is_init_

  end subroutine ruleset_to_clliou_2site_qtensor_qtensorlist

MPOOps_f90.ruleset_to_clliou_2site_qtensorc_qtensorlist()

fortran-subroutine - September 2017 (dj) Build a two-site Liouville operator for Liouville space (closed system, Hamiltonian only).

Arguments

LiouTYPE(qtensorc), inout

On exit, the Liouville operator as rank-4 tensor.

xxINTEGER, in

Get Liouville operator for sites xx, xx+1

RsTYPE(MPORuleSet), in

Contains the rule set to build up the MPO.

OpsTYPE(qtensorlist), in

List containing all operators for the evolution

HparamsTYPE(HamiltonianParameters), in

containing the couplings for each operator

iopINTEGER, in

The index of the identity in the operator list.

is_initLOGICAL, OPTIONAL, out

If true, Liou has already been initialized. If false, no terms were added up to now.

scconjspaceREAL, OPTIONAL, in

Scalar to be multplied with conjugate space. Default to 1.0 for imaginary time evolution. Set to -1.0 for Hamiltonian evolution.

Details

The following rules are considered : site rules for the Hamiltonian, bond rules for the Hamiltonian, site rules for Lindblad operators.

Source Code

show / hide f90 code

  subroutine ruleset_to_clliou_2site_qtensorc_qtensorlist(Liou, xx, ll, &
       Rs, Ops, Hparams, iop, is_init, scconjspace, errst)
      type(qtensorc), intent(inout) :: Liou
      integer, intent(in) :: xx, ll
      type(MPORuleSet), intent(in) :: Rs
      type(qtensorlist), intent(in) :: Ops
      type(HamiltonianParameters), pointer, intent(in) :: Hparams(:)
      integer, intent(in) :: iop
      logical, intent(out), optional :: is_init
      real(KIND=rKind), intent(in), optional :: scconjspace
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! first index for lindblads / bond rule
      integer :: i1

      ! position of the site xx+1
      integer :: xx1

      ! Flag if operator already initialized
      logical :: is_init_

      ! scalar to be multiplied with conjugated Hilbert space
      real(KIND=rKind) :: cstar

      ! indices for fusing
      integer, dimension(2, 2) :: fidx

      ! couplings including weight, hparams etc
      real(KIND=rKind) :: coupl1, coupl2

      ! prefactor considering boundary effects in PBC/OPC
      real(KIND=rKind), dimension(2) :: pre

      ! temporary matrix to calculate the next hamiltonian contribution
      type(qtensor) :: Tmpa, Tmpb, Tmpc, Leye

      !if(present(errst)) errst = 0

      is_init_ = .false.

      if(present(scconjspace)) then
          cstar = scconjspace
      else
          cstar = 1.0_rKind
      end if

      ! generate identity in Liouville space
      call kron(Leye, Ops%Li(iop), Ops%Li(iop), 1, 1, 'N', 'N', 'N')

      fidx = reshape([1, 2, 3, 4], [2, 2])
      call fuse(Leye, fidx, '0', errst=errst)
      !if(prop_error('ruleset_to_clliou_2site_qtensorc_qtensorlist: '//&
      !              'fuse (1) failed.', 'MPOOps_include.f90:3290', errst=errst)) return

      ! [local site]
      ! ------------

      if(Rs%pbc) then
          ! Periodic boundary condition - every local term appears twice
          pre = 0.5_rKind
      elseif((xx == 1) .and. (xx == ll - 1)) then
          ! Open boundary conditions - system consists of two sites
          pre = 1.0_rKind
      elseif(xx == 1) then
          ! Open boundary conditions - left border
          pre = [1.0_rKind, 0.5_rKind]
      elseif(xx == ll - 1) then
          ! Open boundary conditions - right border
          pre = [0.5_rKind, 1.0_rKind]
      else
          pre = 0.5_rKind
      end if

      if(xx + 1 > ll) then
          if(Rs%pbc .and. (xx == ll)) then
              xx1 = 1
          else
              errst = raise_error('ruleset_to_ham_2site_qtensorlist'//&
                                  ' : site xx not valid.', 99, errst=errst)
              return
          end if
      else
          xx1 = xx + 1
      end if

      do ii = 1, Rs%nsite
          coupl1 = pre(1) * Rs%S(ii)%w * get_coupl(Hparams, Rs%S(ii)%h, xx)
          coupl2 = pre(2) * Rs%S(ii)%w * get_coupl(Hparams, Rs%S(ii)%h, xx1)

          ! (H_1 x I_1) x (I_2 x I_2)
          call kron(Tmpa, Ops%Li(Rs%S(ii)%o), Ops%Li(iop), 1, 1, 'N', 'N', 'N')
          call fuse(Tmpa, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_clliou_2site_qtensorc_qtensorlist: '//&
          !              'fuse (2) failed.', 'MPOOps_include.f90:3331', &
          !              errst=errst)) return

          if(ii == 1) then
              call kron(Liou, Tmpa, Leye, 1, 1, 'N', 'N', 'N')
              call scale(coupl1, Liou)
              is_init_ = .true.
          else
              call kron(Tmpb, Tmpa, Leye, 1, 1, 'N', 'N', 'N')
              call gaxpy(Liou, coupl1, Tmpb)
              call destroy(Tmpb)
          end if

          ! (I_1 x I_1) x (H_2 x I_2)
          call kron(Tmpb, Leye, Tmpa, 1, 1, 'N', 'N', 'N')
          call gaxpy(Liou, coupl2, Tmpb)
          call destroy(Tmpa)
          call destroy(Tmpb)

          ! (I_1 x H_1^T) x (I_2 x I_2)
          call kron(Tmpa, Ops%Li(iop), Ops%Li(Rs%S(ii)%o), 1, 1, 'N', 'T', 'N')
          call fuse(Tmpa, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_clliou_2site_qtensorc_qtensorlist: '//&
          !              'fuse (3) failed.', 'MPOOps_include.f90:3354', &
          !              errst=errst)) return

          call kron(Tmpb, Tmpa, Leye, 1, 1, 'N', 'N', 'N')
          call gaxpy(Liou, cstar * coupl1, Tmpb)
          call destroy(Tmpb)

          ! (I_1 x I_1) x (I_2 x H_2^T)
          call kron(Tmpb, Leye, Tmpa, 1, 1, 'N', 'N', 'N')
          call gaxpy(Liou, cstar * coupl2, Tmpb)
          call destroy(Tmpa)
          call destroy(Tmpb)
      end do

      ! [bond rules]
      ! ------------

      do ii = 1, Rs%nbond
          coupl1 = Rs%B(ii)%w * get_coupl(Hparams, Rs%B(ii)%h, xx)

          ! (H_1 x I_1) x (H_2 x I_2)
          call kron(Tmpa, Ops%Li(Rs%B(ii)%ol), Ops%Li(iop), 1, 1, 'N', 'N', 'N')
          call fuse(Tmpa, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_clliou_2site_qtensorc_qtensorlist: '//&
          !              'fuse (4) failed.', 'MPOOps_include.f90:3378', &
          !              errst=errst)) return

          call kron(Tmpb, Ops%Li(Rs%B(ii)%or), Ops%Li(iop), 1, 1, 'N', 'N', 'N')
          call fuse(Tmpb, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_clliou_2site_qtensorc_qtensorlist: '//&
          !              'fuse (5) failed.', 'MPOOps_include.f90:3384', &
          !              errst=errst)) return

          if(is_init_) then
              call kron(Tmpc, Tmpa, Tmpb, 1, 1, 'N', 'N', 'N')
              call gaxpy(Liou, coupl1, Tmpc)
              call destroy(Tmpc)
          else
              call kron(Liou, Tmpa, Tmpb, 1, 1, 'N', 'N', 'N')
              call scale(coupl1, Liou)
              is_init_ = .true.
          end if

          call destroy(Tmpa)
          call destroy(Tmpb)

          ! (I_1 x H_1^T) x (I_2 x H_2^T)
          call kron(Tmpa, Ops%Li(iop), Ops%Li(Rs%B(ii)%ol), 1, 1, 'N', 'T', 'N')
          call fuse(Tmpa, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_clliou_2site_qtensorc_qtensorlist: '//&
          !              'fuse (6) failed.', 'MPOOps_include.f90:3404', &
          !              errst=errst)) return

          call kron(Tmpb, Ops%Li(iop), Ops%Li(Rs%B(ii)%or), 1, 1, 'N', 'T', 'N')
          call fuse(Tmpb, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_clliou_2site_qtensorc_qtensorlist: '//&
          !              'fuse (7) failed.', 'MPOOps_include.f90:3410', &
          !              errst=errst)) return

          call kron(Tmpc, Tmpa, Tmpb, 1, 1, 'N', 'N', 'N')
          call gaxpy(Liou, cstar * coupl1, Tmpc)

          call destroy(Tmpa)
          call destroy(Tmpb)
          call destroy(Tmpc)
      end do

      ! For symmetric tensor, we have to add the diagonal blocks with
      ! zero values (zero block => identity in the exponential)
      if(.true.) then
          call kron(Tmpa, Leye, Leye, 1, 1, 'N', 'N', 'N')
          if(is_init_) then
              call gaxpy(Liou, 0.0_rKind, Tmpa, errst=errst)
              !if(prop_error('ruleset_to_clliou_2site_qtensorc_qtensorlist'//&
              !              ' : gaxpy failed.', 'MPOOps_include.f90:3428', &
              !              errst=errst)) return
          else
              call copy(Liou, Tmpa, scalar=zzero)
              is_init_ = .true.
          end if

          call destroy(Tmpa)
      end if

      call destroy(Leye)

      if(present(is_init)) is_init = is_init_

  end subroutine ruleset_to_clliou_2site_qtensorc_qtensorlist

MPOOps_f90.ruleset_to_clliou_2site_qtensorc_qtensorclist()

fortran-subroutine - September 2017 (dj) Build a two-site Liouville operator for Liouville space (closed system, Hamiltonian only).

Arguments

LiouTYPE(qtensorc), inout

On exit, the Liouville operator as rank-4 tensor.

xxINTEGER, in

Get Liouville operator for sites xx, xx+1

RsTYPE(MPORuleSet), in

Contains the rule set to build up the MPO.

OpsTYPE(qtensorclist), in

List containing all operators for the evolution

HparamsTYPE(HamiltonianParameters), in

containing the couplings for each operator

iopINTEGER, in

The index of the identity in the operator list.

is_initLOGICAL, OPTIONAL, out

If true, Liou has already been initialized. If false, no terms were added up to now.

scconjspaceREAL, OPTIONAL, in

Scalar to be multplied with conjugate space. Default to 1.0 for imaginary time evolution. Set to -1.0 for Hamiltonian evolution.

Details

The following rules are considered : site rules for the Hamiltonian, bond rules for the Hamiltonian, site rules for Lindblad operators.

Source Code

show / hide f90 code

  subroutine ruleset_to_clliou_2site_qtensorc_qtensorclist(Liou, xx, ll, &
       Rs, Ops, Hparams, iop, is_init, scconjspace, errst)
      type(qtensorc), intent(inout) :: Liou
      integer, intent(in) :: xx, ll
      type(MPORuleSet), intent(in) :: Rs
      type(qtensorclist), intent(in) :: Ops
      type(HamiltonianParameters), pointer, intent(in) :: Hparams(:)
      integer, intent(in) :: iop
      logical, intent(out), optional :: is_init
      real(KIND=rKind), intent(in), optional :: scconjspace
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! first index for lindblads / bond rule
      integer :: i1

      ! position of the site xx+1
      integer :: xx1

      ! Flag if operator already initialized
      logical :: is_init_

      ! scalar to be multiplied with conjugated Hilbert space
      real(KIND=rKind) :: cstar

      ! indices for fusing
      integer, dimension(2, 2) :: fidx

      ! couplings including weight, hparams etc
      real(KIND=rKind) :: coupl1, coupl2

      ! prefactor considering boundary effects in PBC/OPC
      real(KIND=rKind), dimension(2) :: pre

      ! temporary matrix to calculate the next hamiltonian contribution
      type(qtensorc) :: Tmpa, Tmpb, Tmpc, Leye

      !if(present(errst)) errst = 0

      is_init_ = .false.

      if(present(scconjspace)) then
          cstar = scconjspace
      else
          cstar = 1.0_rKind
      end if

      ! generate identity in Liouville space
      call kron(Leye, Ops%Li(iop), Ops%Li(iop), 1, 1, 'N', 'N', 'N')

      fidx = reshape([1, 2, 3, 4], [2, 2])
      call fuse(Leye, fidx, '0', errst=errst)
      !if(prop_error('ruleset_to_clliou_2site_qtensorc_qtensorclist: '//&
      !              'fuse (1) failed.', 'MPOOps_include.f90:3290', errst=errst)) return

      ! [local site]
      ! ------------

      if(Rs%pbc) then
          ! Periodic boundary condition - every local term appears twice
          pre = 0.5_rKind
      elseif((xx == 1) .and. (xx == ll - 1)) then
          ! Open boundary conditions - system consists of two sites
          pre = 1.0_rKind
      elseif(xx == 1) then
          ! Open boundary conditions - left border
          pre = [1.0_rKind, 0.5_rKind]
      elseif(xx == ll - 1) then
          ! Open boundary conditions - right border
          pre = [0.5_rKind, 1.0_rKind]
      else
          pre = 0.5_rKind
      end if

      if(xx + 1 > ll) then
          if(Rs%pbc .and. (xx == ll)) then
              xx1 = 1
          else
              errst = raise_error('ruleset_to_ham_2site_qtensorclist'//&
                                  ' : site xx not valid.', 99, errst=errst)
              return
          end if
      else
          xx1 = xx + 1
      end if

      do ii = 1, Rs%nsite
          coupl1 = pre(1) * Rs%S(ii)%w * get_coupl(Hparams, Rs%S(ii)%h, xx)
          coupl2 = pre(2) * Rs%S(ii)%w * get_coupl(Hparams, Rs%S(ii)%h, xx1)

          ! (H_1 x I_1) x (I_2 x I_2)
          call kron(Tmpa, Ops%Li(Rs%S(ii)%o), Ops%Li(iop), 1, 1, 'N', 'N', 'N')
          call fuse(Tmpa, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_clliou_2site_qtensorc_qtensorclist: '//&
          !              'fuse (2) failed.', 'MPOOps_include.f90:3331', &
          !              errst=errst)) return

          if(ii == 1) then
              call kron(Liou, Tmpa, Leye, 1, 1, 'N', 'N', 'N')
              call scale(coupl1, Liou)
              is_init_ = .true.
          else
              call kron(Tmpb, Tmpa, Leye, 1, 1, 'N', 'N', 'N')
              call gaxpy(Liou, coupl1, Tmpb)
              call destroy(Tmpb)
          end if

          ! (I_1 x I_1) x (H_2 x I_2)
          call kron(Tmpb, Leye, Tmpa, 1, 1, 'N', 'N', 'N')
          call gaxpy(Liou, coupl2, Tmpb)
          call destroy(Tmpa)
          call destroy(Tmpb)

          ! (I_1 x H_1^T) x (I_2 x I_2)
          call kron(Tmpa, Ops%Li(iop), Ops%Li(Rs%S(ii)%o), 1, 1, 'N', 'T', 'N')
          call fuse(Tmpa, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_clliou_2site_qtensorc_qtensorclist: '//&
          !              'fuse (3) failed.', 'MPOOps_include.f90:3354', &
          !              errst=errst)) return

          call kron(Tmpb, Tmpa, Leye, 1, 1, 'N', 'N', 'N')
          call gaxpy(Liou, cstar * coupl1, Tmpb)
          call destroy(Tmpb)

          ! (I_1 x I_1) x (I_2 x H_2^T)
          call kron(Tmpb, Leye, Tmpa, 1, 1, 'N', 'N', 'N')
          call gaxpy(Liou, cstar * coupl2, Tmpb)
          call destroy(Tmpa)
          call destroy(Tmpb)
      end do

      ! [bond rules]
      ! ------------

      do ii = 1, Rs%nbond
          coupl1 = Rs%B(ii)%w * get_coupl(Hparams, Rs%B(ii)%h, xx)

          ! (H_1 x I_1) x (H_2 x I_2)
          call kron(Tmpa, Ops%Li(Rs%B(ii)%ol), Ops%Li(iop), 1, 1, 'N', 'N', 'N')
          call fuse(Tmpa, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_clliou_2site_qtensorc_qtensorclist: '//&
          !              'fuse (4) failed.', 'MPOOps_include.f90:3378', &
          !              errst=errst)) return

          call kron(Tmpb, Ops%Li(Rs%B(ii)%or), Ops%Li(iop), 1, 1, 'N', 'N', 'N')
          call fuse(Tmpb, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_clliou_2site_qtensorc_qtensorclist: '//&
          !              'fuse (5) failed.', 'MPOOps_include.f90:3384', &
          !              errst=errst)) return

          if(is_init_) then
              call kron(Tmpc, Tmpa, Tmpb, 1, 1, 'N', 'N', 'N')
              call gaxpy(Liou, coupl1, Tmpc)
              call destroy(Tmpc)
          else
              call kron(Liou, Tmpa, Tmpb, 1, 1, 'N', 'N', 'N')
              call scale(coupl1, Liou)
              is_init_ = .true.
          end if

          call destroy(Tmpa)
          call destroy(Tmpb)

          ! (I_1 x H_1^T) x (I_2 x H_2^T)
          call kron(Tmpa, Ops%Li(iop), Ops%Li(Rs%B(ii)%ol), 1, 1, 'N', 'T', 'N')
          call fuse(Tmpa, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_clliou_2site_qtensorc_qtensorclist: '//&
          !              'fuse (6) failed.', 'MPOOps_include.f90:3404', &
          !              errst=errst)) return

          call kron(Tmpb, Ops%Li(iop), Ops%Li(Rs%B(ii)%or), 1, 1, 'N', 'T', 'N')
          call fuse(Tmpb, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_clliou_2site_qtensorc_qtensorclist: '//&
          !              'fuse (7) failed.', 'MPOOps_include.f90:3410', &
          !              errst=errst)) return

          call kron(Tmpc, Tmpa, Tmpb, 1, 1, 'N', 'N', 'N')
          call gaxpy(Liou, cstar * coupl1, Tmpc)

          call destroy(Tmpa)
          call destroy(Tmpb)
          call destroy(Tmpc)
      end do

      ! For symmetric tensor, we have to add the diagonal blocks with
      ! zero values (zero block => identity in the exponential)
      if(.true.) then
          call kron(Tmpa, Leye, Leye, 1, 1, 'N', 'N', 'N')
          if(is_init_) then
              call gaxpy(Liou, 0.0_rKind, Tmpa, errst=errst)
              !if(prop_error('ruleset_to_clliou_2site_qtensorc_qtensorclist'//&
              !              ' : gaxpy failed.', 'MPOOps_include.f90:3428', &
              !              errst=errst)) return
          else
              call copy(Liou, Tmpa, scalar=zzero)
              is_init_ = .true.
          end if

          call destroy(Tmpa)
      end if

      call destroy(Leye)

      if(present(is_init)) is_init = is_init_

  end subroutine ruleset_to_clliou_2site_qtensorc_qtensorclist

MPOOps_f90.ruleset_to_liou_2site_tensorlist()

fortran-subroutine - September 2017 (dj) Build a two-site Liouville operator for a Lindblad master equation.

Arguments

LiouTYPE(tensorc), inout

On exit, the Liouville operator as rank-4 tensor.

xxINTEGER, in

Get Liouville operator for sites xx, xx+1

RsTYPE(MPORuleSet), in

Contains the rule set to build up the MPO.

OpsTYPE(tensorlist), inout

List containing all operators for the evolution

HparamsTYPE(HamiltonianParameters), in

containing the couplings for each operator

iopINTEGER, in

The index of the identity in the operator list.

Details

The following rules are considered : site rules for the Hamiltonian, bond rules for the Hamiltonian, site rules for Lindblad operators.

Source Code

show / hide f90 code

  subroutine ruleset_to_liou_2site_tensorlist(Liou, xx, ll, Rs, Ops, &
                                                   Hparams, iop, errst)
      type(tensorc), intent(inout) :: Liou
      integer, intent(in) :: xx, ll
      type(MPORuleSet), intent(in) :: Rs
      type(tensorlist), intent(inout) :: Ops
      type(HamiltonianParameters), pointer, intent(in) :: Hparams(:)
      integer, intent(in) :: iop
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! first index for lindblads / bond rule
      integer :: i1

      ! position of the site xx+1
      integer :: xx1

      ! Offset for MBSLXY rule
      integer :: os

      ! Flag if operator already initialized
      logical :: is_init

      ! indices for fusing
      integer, dimension(2, 2) :: fidx

      ! couplings including weight, hparams etc
      real(KIND=rKind) :: coupl1, coupl2

      ! prefactor considering boundary effects in PBC/OPC
      real(KIND=rKind), dimension(2) :: pre

      ! temporary matrix to calculate the next hamiltonian contribution
      type(tensor) :: Tmpa, Tmpb, Tmpc, Tmpd, Tmpe, Leye

      !if(present(errst)) errst = 0

      is_init = .false.

      ! generate identity in Liouville space
      call kron(Leye, Ops%Li(iop), Ops%Li(iop), 1, 1, 'N', 'N', 'N')

      fidx = reshape([1, 2, 3, 4], [2, 2])
      call fuse(Leye, fidx, '0', errst=errst)
      !if(prop_error('ruleset_to_liou_2site_tensorlist: '//&
      !              'fuse (1) failed.', 'MPOOps_include.f90:3553', errst=errst)) return

      ! [local site]
      ! ------------

      if(Rs%pbc) then
          ! Periodic boundary condition - every local term appears twice
          pre = 0.5_rKind
      elseif((xx == 1) .and. (xx == ll - 1)) then
          ! Open boundary conditions - system consists of two sites
          pre = 1.0_rKind
      elseif(xx == 1) then
          ! Open boundary conditions - left border
          pre = [1.0_rKind, 0.5_rKind]
      elseif(xx == ll - 1) then
          ! Open boundary conditions - right border
          pre = [0.5_rKind, 1.0_rKind]
      else
          pre = 0.5_rKind
      end if

      if(xx + 1 > ll) then
          if(Rs%pbc .and. (xx == ll)) then
              xx1 = 1
          else
              errst = raise_error('ruleset_to_ham_2site_tensorlist'//&
                                  ' : site xx not valid.', 99, errst=errst)
              return
          end if
      else
          xx1 = xx + 1
      end if

      call ruleset_to_clliou_2site(Liou, xx, ll, Rs, Ops, &
           Hparams, iop, is_init=is_init, scconjspace=-1.0_rKind, &
           errst=errst)
      !if(prop_error('ruleset_to_liou_2site_tensorlist: '//&
      !              'ruleset_to_clliou_2site failed.', 'MPOOps_include.f90:3590', &
      !              errst=errst)) return

      ! [local lindblads]
      ! -----------------

      do ii = 1, Rs%nlxx
          coupl1 = pre(1) * Rs%Lxx(ii)%w * get_coupl(Hparams, Rs%Lxx(ii)%h, xx)
          coupl2 = pre(2) * Rs%Lxx(ii)%w * get_coupl(Hparams, Rs%Lxx(ii)%h, xx1)

          ! (L_1 x L_1*) x (I_2 x I_2)
          call copy(Tmpa, Ops%Li(Rs%Lxx(ii)%o), trans='C')
          call kron(Tmpb, Ops%Li(Rs%Lxx(ii)%o), Tmpa, 1, 1, 'N', 'N', 'N', &
                    errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3605', &
          !              errst=errst)) return

          call fuse(Tmpb, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlist: '//&
          !              'fuse (8) failed.', 'MPOOps_include.f90:3610', &
          !              errst=errst)) return

          if(is_init) then
              call kron(Tmpc, Tmpb, Leye, 1, 1, 'N', 'N', 'N', errst=errst)
              !if(prop_error('ruleset_to_liou_2site_tensorlist: '//&
              !              'kron failed.', 'MPOOps_include.f90:3616', &
              !              errst=errst)) return

              call gaxpy(Liou, eye * coupl1, Tmpc)
              call destroy(Tmpc)
          else
              call kron(Liou, Tmpb, Leye, 1, 1, 'N', 'N', 'N', errst=errst)
              !if(prop_error('ruleset_to_liou_2site_tensorlist: '//&
              !              'kron failed.', 'MPOOps_include.f90:3624', &
              !              errst=errst)) return

              call scale(eye * coupl1, Liou)
              is_init = .true.
          end if

          ! (I_1 x I_1) x (L_2 x L_2*)
          call kron(Tmpc, Leye, Tmpb, 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3634', &
          !              errst=errst)) return

          call gaxpy(Liou, eye * coupl2, Tmpc)

          call destroy(Tmpb)
          call destroy(Tmpc)

          ! Build (L^dagger L)
          call contr(Tmpb, Tmpa, Ops%Li(Rs%Lxx(ii)%o), [1], [1])
          call destroy(Tmpa)

          ! Consider 0.5
          coupl1 = -0.5_rKind * coupl1
          coupl2 = -0.5_rKind * coupl2

          ! (Ldagger_1 L_1 x I_1) x (I_2 x I_2)
          call kron(Tmpa, Tmpb, Ops%Li(iop), 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3653', &
          !              errst=errst)) return

          call fuse(Tmpa, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlist: '//&
          !              'fuse (9) failed.', 'MPOOps_include.f90:3658', &
          !              errst=errst)) return

          call kron(Tmpc, Tmpa, Leye, 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3663', &
          !              errst=errst)) return

          call gaxpy(Liou, eye * coupl1, Tmpc)
          call destroy(Tmpc)

          ! (I_1 x I_1) x (Ldagger_2 L_2 x I_2)
          call kron(Tmpc, Leye, Tmpa, 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3672', &
          !              errst=errst)) return

          call gaxpy(Liou, eye * coupl2, Tmpc)
          call destroy(Tmpc)

          ! (I_1 (Ldagger_1 L_1)^T) x (I_2 x I_2)
          call kron(Tmpa, Ops%Li(iop), Tmpb, 1, 1, 'N', 'T', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3681', &
          !              errst=errst)) return

          call fuse(Tmpa, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlist: '//&
          !              'fuse (10) failed.', 'MPOOps_include.f90:3686', &
          !              errst=errst)) return

          call kron(Tmpc, Tmpa, Leye, 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3691', &
          !              errst=errst)) return

          call gaxpy(Liou, eye * coupl1, Tmpc)
          call destroy(Tmpc)

          ! (I_1 x I_1) x (I_2 x (Ldagger_2 L_2)^T)
          call kron(Tmpc, Leye, Tmpa, 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3700', &
          !              errst=errst)) return

          call gaxpy(Liou, eye * coupl2, Tmpc)

          call destroy(Tmpa)
          call destroy(Tmpb)
          call destroy(Tmpc)

      end do

      ! [many-body string lindblad terms (if length is 2)]
      ! --------------------------------------------------

      do ii = 1, Rs%nmbsl
          if(Rs%Mbsl(ii)%n /= 2) cycle

          coupl1 = Rs%Mbsl(ii)%w * get_coupl(Hparams, Rs%Mbsl(ii)%h, xx)

          ! (L_1 x L_1*) x (L_2 x L_2*)
          ! ...........................

          call copy(Tmpc, Ops%Li(Rs%Mbsl(ii)%o(1)), trans='C')
          call kron(Tmpa, Ops%Li(Rs%Mbsl(ii)%o(1)), Tmpc, 1, 1, &
                    'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3726', &
          !              errst=errst)) return

          call fuse(Tmpa, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlist: '//&
          !              'fuse failed.', 'MPOOps_include.f90:3731', &
          !              errst=errst)) return

          call destroy(Tmpc)

          call copy(Tmpc, Ops%Li(Rs%Mbsl(ii)%o(2)), trans='C')
          call kron(Tmpb, Ops%Li(Rs%Mbsl(ii)%o(2)), Tmpc, 1, 1, &
                    'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3740', &
          !              errst=errst)) return

          call fuse(Tmpb, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlist: '//&
          !              'fuse failed.', 'MPOOps_include.f90:3745', &
          !              errst=errst)) return

          call destroy(Tmpc)

          call kron(Tmpc, Tmpa, Tmpb, 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3752', &
          !              errst=errst)) return

          call gaxpy(Liou, eye * coupl1, Tmpc)

          call destroy(Tmpa)
          call destroy(Tmpb)
          call destroy(Tmpc)

          ! (Ldag_1 L_1 x I_1) x (Ldag_2 L_2 x I_2)
          ! .......................................

          ! Consider 0.5
          coupl1 = -0.5_rKind * coupl1

          ! L^dagger L
          call contr(Tmpa, Ops%Li(Rs%Mbsl(ii)%o(1)), &
                     Ops%Li(Rs%Mbsl(ii)%o(1)), [1], [1], transl='C')
          call contr(Tmpb, Ops%Li(Rs%Mbsl(ii)%o(2)), &
                     Ops%Li(Rs%Mbsl(ii)%o(2)), [1], [1], transl='C')

          call kron(Tmpc, Tmpa, Ops%Li(iop), 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3775', &
          !              errst=errst)) return

          call fuse(Tmpc, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlist: '//&
          !              'fuse (8) failed.', 'MPOOps_include.f90:3780', &
          !              errst=errst)) return

          call kron(Tmpd, Tmpb, Ops%Li(iop), 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3785', &
          !              errst=errst)) return

          call fuse(Tmpd, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlist: '//&
          !              'fuse (8) failed.', 'MPOOps_include.f90:3790', &
          !              errst=errst)) return

          call kron(Tmpe, Tmpc, Tmpd, 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3795', &
          !              errst=errst)) return

          call gaxpy(Liou, eye * coupl1, Tmpe)

          call destroy(Tmpc)
          call destroy(Tmpd)
          call destroy(Tmpe)

          ! (I_1 x (Ldag_1 L_1)^T) x (I_2 x (Ldag_2 L_2)^T)
          ! ...............................................

          call kron(Tmpc, Ops%Li(iop), Tmpa, 1, 1, 'N', 'T', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3809', &
          !              errst=errst)) return

          call fuse(Tmpc, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlist: '//&
          !              'fuse (8) failed.', 'MPOOps_include.f90:3814', &
          !              errst=errst)) return

          call kron(Tmpd, Ops%Li(iop), Tmpb, 1, 1, 'N', 'T', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3819', &
          !              errst=errst)) return

          call fuse(Tmpd, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlist: '//&
          !              'fuse (8) failed.', 'MPOOps_include.f90:3824', &
          !              errst=errst)) return

          call kron(Tmpe, Tmpc, Tmpd, 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3829', &
          !              errst=errst)) return

          call gaxpy(Liou, eye * coupl1, Tmpe)

          call destroy(Tmpa)
          call destroy(Tmpb)
          call destroy(Tmpc)
          call destroy(Tmpd)
          call destroy(Tmpe)
      end do

      ! [many-body string lindblad XY terms] (if length is 2)
      ! ------------------------------------

      do ii = 1, Rs%nmbslxy
          os = Rs%Mbslxy(ii)%n
          if(os /= 2) cycle

          coupl1 = Rs%Mbslxy(ii)%w * get_coupl(Hparams, Rs%Mbslxy(ii)%h, xx)

          ! (L_1 x L_1*) x (L_2 x L_2*)
          ! ...........................

          call copy(Tmpc, Ops%Li(Rs%Mbslxy(ii)%o(os + 1)), trans='C')
          call kron(Tmpa, Ops%Li(Rs%Mbslxy(ii)%o(1)), Tmpc, 1, 1, &
                    'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3857', &
          !              errst=errst)) return

          call fuse(Tmpa, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlist: '//&
          !              'fuse failed.', 'MPOOps_include.f90:3862', &
          !              errst=errst)) return

          call destroy(Tmpc)

          call copy(Tmpc, Ops%Li(Rs%Mbslxy(ii)%o(os + 2)), trans='C')
          call kron(Tmpb, Ops%Li(Rs%Mbslxy(ii)%o(2)), Tmpc, 1, 1, &
                    'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3871', &
          !              errst=errst)) return

          call fuse(Tmpb, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlist: '//&
          !              'fuse failed.', 'MPOOps_include.f90:3876', &
          !              errst=errst)) return

          call destroy(Tmpc)

          call kron(Tmpc, Tmpa, Tmpb, 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3883', &
          !              errst=errst)) return

          call gaxpy(Liou, eye * coupl1, Tmpc)

          call destroy(Tmpa)
          call destroy(Tmpb)
          call destroy(Tmpc)

          ! (Ldag_1 L_1 x I_1) x (Ldag_2 L_2 x I_2)
          ! .......................................

          ! Consider 0.5
          coupl1 = -0.5_rKind * coupl1

          ! L^dagger L
          call contr(Tmpa, Ops%Li(Rs%Mbslxy(ii)%o(os + 1)), &
                     Ops%Li(Rs%Mbslxy(ii)%o(1)), [1], [1], transl='C')
          call contr(Tmpb, Ops%Li(Rs%Mbslxy(ii)%o(os + 2)), &
                     Ops%Li(Rs%Mbslxy(ii)%o(2)), [1], [1], transl='C')

          call kron(Tmpc, Tmpa, Ops%Li(iop), 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3906', &
          !              errst=errst)) return

          call fuse(Tmpc, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlist: '//&
          !              'fuse (8) failed.', 'MPOOps_include.f90:3911', &
          !              errst=errst)) return

          call kron(Tmpd, Tmpb, Ops%Li(iop), 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3916', &
          !              errst=errst)) return

          call fuse(Tmpd, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlist: '//&
          !              'fuse (8) failed.', 'MPOOps_include.f90:3921', &
          !              errst=errst)) return

          call kron(Tmpe, Tmpc, Tmpd, 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3926', &
          !              errst=errst)) return

          call gaxpy(Liou, eye * coupl1, Tmpe)

          call destroy(Tmpc)
          call destroy(Tmpd)
          call destroy(Tmpe)

          ! (I_1 x (Ldag_1 L_1)^T) x (I_2 x (Ldag_2 L_2)^T)
          ! ...............................................

          call kron(Tmpc, Ops%Li(iop), Tmpa, 1, 1, 'N', 'T', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3940', &
          !              errst=errst)) return

          call fuse(Tmpc, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlist: '//&
          !              'fuse (8) failed.', 'MPOOps_include.f90:3945', &
          !              errst=errst)) return

          call kron(Tmpd, Ops%Li(iop), Tmpb, 1, 1, 'N', 'T', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3950', &
          !              errst=errst)) return

          call fuse(Tmpd, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlist: '//&
          !              'fuse (8) failed.', 'MPOOps_include.f90:3955', &
          !              errst=errst)) return

          call kron(Tmpe, Tmpc, Tmpd, 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3960', &
          !              errst=errst)) return

          call gaxpy(Liou, eye * coupl1, Tmpe)

          call destroy(Tmpa)
          call destroy(Tmpb)
          call destroy(Tmpc)
          call destroy(Tmpd)
          call destroy(Tmpe)
      end do

      ! For symmetric tensor, we have to add the diagonal blocks with
      ! zero values (zero block => identity in the exponential)
      if(.false.) then
          call kron(Tmpa, Leye, Leye, 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3977', &
          !              errst=errst)) return

          call gaxpy(Liou, 0.0_rKind, Tmpa, errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlist'//&
          !              ' : gaxpy failed.', 'MPOOps_include.f90:3982', &
          !              errst=errst)) return

          call destroy(Tmpa)
      end if

      call destroy(Leye)

  end subroutine ruleset_to_liou_2site_tensorlist

MPOOps_f90.ruleset_to_liou_2site_tensorlistc()

fortran-subroutine - September 2017 (dj) Build a two-site Liouville operator for a Lindblad master equation.

Arguments

LiouTYPE(tensorc), inout

On exit, the Liouville operator as rank-4 tensor.

xxINTEGER, in

Get Liouville operator for sites xx, xx+1

RsTYPE(MPORuleSet), in

Contains the rule set to build up the MPO.

OpsTYPE(tensorlistc), inout

List containing all operators for the evolution

HparamsTYPE(HamiltonianParameters), in

containing the couplings for each operator

iopINTEGER, in

The index of the identity in the operator list.

Details

The following rules are considered : site rules for the Hamiltonian, bond rules for the Hamiltonian, site rules for Lindblad operators.

Source Code

show / hide f90 code

  subroutine ruleset_to_liou_2site_tensorlistc(Liou, xx, ll, Rs, Ops, &
                                                   Hparams, iop, errst)
      type(tensorc), intent(inout) :: Liou
      integer, intent(in) :: xx, ll
      type(MPORuleSet), intent(in) :: Rs
      type(tensorlistc), intent(inout) :: Ops
      type(HamiltonianParameters), pointer, intent(in) :: Hparams(:)
      integer, intent(in) :: iop
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! first index for lindblads / bond rule
      integer :: i1

      ! position of the site xx+1
      integer :: xx1

      ! Offset for MBSLXY rule
      integer :: os

      ! Flag if operator already initialized
      logical :: is_init

      ! indices for fusing
      integer, dimension(2, 2) :: fidx

      ! couplings including weight, hparams etc
      real(KIND=rKind) :: coupl1, coupl2

      ! prefactor considering boundary effects in PBC/OPC
      real(KIND=rKind), dimension(2) :: pre

      ! temporary matrix to calculate the next hamiltonian contribution
      type(tensorc) :: Tmpa, Tmpb, Tmpc, Tmpd, Tmpe, Leye

      !if(present(errst)) errst = 0

      is_init = .false.

      ! generate identity in Liouville space
      call kron(Leye, Ops%Li(iop), Ops%Li(iop), 1, 1, 'N', 'N', 'N')

      fidx = reshape([1, 2, 3, 4], [2, 2])
      call fuse(Leye, fidx, '0', errst=errst)
      !if(prop_error('ruleset_to_liou_2site_tensorlistc: '//&
      !              'fuse (1) failed.', 'MPOOps_include.f90:3553', errst=errst)) return

      ! [local site]
      ! ------------

      if(Rs%pbc) then
          ! Periodic boundary condition - every local term appears twice
          pre = 0.5_rKind
      elseif((xx == 1) .and. (xx == ll - 1)) then
          ! Open boundary conditions - system consists of two sites
          pre = 1.0_rKind
      elseif(xx == 1) then
          ! Open boundary conditions - left border
          pre = [1.0_rKind, 0.5_rKind]
      elseif(xx == ll - 1) then
          ! Open boundary conditions - right border
          pre = [0.5_rKind, 1.0_rKind]
      else
          pre = 0.5_rKind
      end if

      if(xx + 1 > ll) then
          if(Rs%pbc .and. (xx == ll)) then
              xx1 = 1
          else
              errst = raise_error('ruleset_to_ham_2site_tensorlistc'//&
                                  ' : site xx not valid.', 99, errst=errst)
              return
          end if
      else
          xx1 = xx + 1
      end if

      call ruleset_to_clliou_2site(Liou, xx, ll, Rs, Ops, &
           Hparams, iop, is_init=is_init, scconjspace=-1.0_rKind, &
           errst=errst)
      !if(prop_error('ruleset_to_liou_2site_tensorlistc: '//&
      !              'ruleset_to_clliou_2site failed.', 'MPOOps_include.f90:3590', &
      !              errst=errst)) return

      ! [local lindblads]
      ! -----------------

      do ii = 1, Rs%nlxx
          coupl1 = pre(1) * Rs%Lxx(ii)%w * get_coupl(Hparams, Rs%Lxx(ii)%h, xx)
          coupl2 = pre(2) * Rs%Lxx(ii)%w * get_coupl(Hparams, Rs%Lxx(ii)%h, xx1)

          ! (L_1 x L_1*) x (I_2 x I_2)
          call copy(Tmpa, Ops%Li(Rs%Lxx(ii)%o), trans='C')
          call kron(Tmpb, Ops%Li(Rs%Lxx(ii)%o), Tmpa, 1, 1, 'N', 'N', 'N', &
                    errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlistc: '//&
          !              'kron failed.', 'MPOOps_include.f90:3605', &
          !              errst=errst)) return

          call fuse(Tmpb, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlistc: '//&
          !              'fuse (8) failed.', 'MPOOps_include.f90:3610', &
          !              errst=errst)) return

          if(is_init) then
              call kron(Tmpc, Tmpb, Leye, 1, 1, 'N', 'N', 'N', errst=errst)
              !if(prop_error('ruleset_to_liou_2site_tensorlistc: '//&
              !              'kron failed.', 'MPOOps_include.f90:3616', &
              !              errst=errst)) return

              call gaxpy(Liou, eye * coupl1, Tmpc)
              call destroy(Tmpc)
          else
              call kron(Liou, Tmpb, Leye, 1, 1, 'N', 'N', 'N', errst=errst)
              !if(prop_error('ruleset_to_liou_2site_tensorlistc: '//&
              !              'kron failed.', 'MPOOps_include.f90:3624', &
              !              errst=errst)) return

              call scale(eye * coupl1, Liou)
              is_init = .true.
          end if

          ! (I_1 x I_1) x (L_2 x L_2*)
          call kron(Tmpc, Leye, Tmpb, 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlistc: '//&
          !              'kron failed.', 'MPOOps_include.f90:3634', &
          !              errst=errst)) return

          call gaxpy(Liou, eye * coupl2, Tmpc)

          call destroy(Tmpb)
          call destroy(Tmpc)

          ! Build (L^dagger L)
          call contr(Tmpb, Tmpa, Ops%Li(Rs%Lxx(ii)%o), [1], [1])
          call destroy(Tmpa)

          ! Consider 0.5
          coupl1 = -0.5_rKind * coupl1
          coupl2 = -0.5_rKind * coupl2

          ! (Ldagger_1 L_1 x I_1) x (I_2 x I_2)
          call kron(Tmpa, Tmpb, Ops%Li(iop), 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlistc: '//&
          !              'kron failed.', 'MPOOps_include.f90:3653', &
          !              errst=errst)) return

          call fuse(Tmpa, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlistc: '//&
          !              'fuse (9) failed.', 'MPOOps_include.f90:3658', &
          !              errst=errst)) return

          call kron(Tmpc, Tmpa, Leye, 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlistc: '//&
          !              'kron failed.', 'MPOOps_include.f90:3663', &
          !              errst=errst)) return

          call gaxpy(Liou, eye * coupl1, Tmpc)
          call destroy(Tmpc)

          ! (I_1 x I_1) x (Ldagger_2 L_2 x I_2)
          call kron(Tmpc, Leye, Tmpa, 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlistc: '//&
          !              'kron failed.', 'MPOOps_include.f90:3672', &
          !              errst=errst)) return

          call gaxpy(Liou, eye * coupl2, Tmpc)
          call destroy(Tmpc)

          ! (I_1 (Ldagger_1 L_1)^T) x (I_2 x I_2)
          call kron(Tmpa, Ops%Li(iop), Tmpb, 1, 1, 'N', 'T', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlistc: '//&
          !              'kron failed.', 'MPOOps_include.f90:3681', &
          !              errst=errst)) return

          call fuse(Tmpa, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlistc: '//&
          !              'fuse (10) failed.', 'MPOOps_include.f90:3686', &
          !              errst=errst)) return

          call kron(Tmpc, Tmpa, Leye, 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlistc: '//&
          !              'kron failed.', 'MPOOps_include.f90:3691', &
          !              errst=errst)) return

          call gaxpy(Liou, eye * coupl1, Tmpc)
          call destroy(Tmpc)

          ! (I_1 x I_1) x (I_2 x (Ldagger_2 L_2)^T)
          call kron(Tmpc, Leye, Tmpa, 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlistc: '//&
          !              'kron failed.', 'MPOOps_include.f90:3700', &
          !              errst=errst)) return

          call gaxpy(Liou, eye * coupl2, Tmpc)

          call destroy(Tmpa)
          call destroy(Tmpb)
          call destroy(Tmpc)

      end do

      ! [many-body string lindblad terms (if length is 2)]
      ! --------------------------------------------------

      do ii = 1, Rs%nmbsl
          if(Rs%Mbsl(ii)%n /= 2) cycle

          coupl1 = Rs%Mbsl(ii)%w * get_coupl(Hparams, Rs%Mbsl(ii)%h, xx)

          ! (L_1 x L_1*) x (L_2 x L_2*)
          ! ...........................

          call copy(Tmpc, Ops%Li(Rs%Mbsl(ii)%o(1)), trans='C')
          call kron(Tmpa, Ops%Li(Rs%Mbsl(ii)%o(1)), Tmpc, 1, 1, &
                    'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlistc: '//&
          !              'kron failed.', 'MPOOps_include.f90:3726', &
          !              errst=errst)) return

          call fuse(Tmpa, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlistc: '//&
          !              'fuse failed.', 'MPOOps_include.f90:3731', &
          !              errst=errst)) return

          call destroy(Tmpc)

          call copy(Tmpc, Ops%Li(Rs%Mbsl(ii)%o(2)), trans='C')
          call kron(Tmpb, Ops%Li(Rs%Mbsl(ii)%o(2)), Tmpc, 1, 1, &
                    'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlistc: '//&
          !              'kron failed.', 'MPOOps_include.f90:3740', &
          !              errst=errst)) return

          call fuse(Tmpb, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlistc: '//&
          !              'fuse failed.', 'MPOOps_include.f90:3745', &
          !              errst=errst)) return

          call destroy(Tmpc)

          call kron(Tmpc, Tmpa, Tmpb, 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlistc: '//&
          !              'kron failed.', 'MPOOps_include.f90:3752', &
          !              errst=errst)) return

          call gaxpy(Liou, eye * coupl1, Tmpc)

          call destroy(Tmpa)
          call destroy(Tmpb)
          call destroy(Tmpc)

          ! (Ldag_1 L_1 x I_1) x (Ldag_2 L_2 x I_2)
          ! .......................................

          ! Consider 0.5
          coupl1 = -0.5_rKind * coupl1

          ! L^dagger L
          call contr(Tmpa, Ops%Li(Rs%Mbsl(ii)%o(1)), &
                     Ops%Li(Rs%Mbsl(ii)%o(1)), [1], [1], transl='C')
          call contr(Tmpb, Ops%Li(Rs%Mbsl(ii)%o(2)), &
                     Ops%Li(Rs%Mbsl(ii)%o(2)), [1], [1], transl='C')

          call kron(Tmpc, Tmpa, Ops%Li(iop), 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlistc: '//&
          !              'kron failed.', 'MPOOps_include.f90:3775', &
          !              errst=errst)) return

          call fuse(Tmpc, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlistc: '//&
          !              'fuse (8) failed.', 'MPOOps_include.f90:3780', &
          !              errst=errst)) return

          call kron(Tmpd, Tmpb, Ops%Li(iop), 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlistc: '//&
          !              'kron failed.', 'MPOOps_include.f90:3785', &
          !              errst=errst)) return

          call fuse(Tmpd, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlistc: '//&
          !              'fuse (8) failed.', 'MPOOps_include.f90:3790', &
          !              errst=errst)) return

          call kron(Tmpe, Tmpc, Tmpd, 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlistc: '//&
          !              'kron failed.', 'MPOOps_include.f90:3795', &
          !              errst=errst)) return

          call gaxpy(Liou, eye * coupl1, Tmpe)

          call destroy(Tmpc)
          call destroy(Tmpd)
          call destroy(Tmpe)

          ! (I_1 x (Ldag_1 L_1)^T) x (I_2 x (Ldag_2 L_2)^T)
          ! ...............................................

          call kron(Tmpc, Ops%Li(iop), Tmpa, 1, 1, 'N', 'T', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlistc: '//&
          !              'kron failed.', 'MPOOps_include.f90:3809', &
          !              errst=errst)) return

          call fuse(Tmpc, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlistc: '//&
          !              'fuse (8) failed.', 'MPOOps_include.f90:3814', &
          !              errst=errst)) return

          call kron(Tmpd, Ops%Li(iop), Tmpb, 1, 1, 'N', 'T', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlistc: '//&
          !              'kron failed.', 'MPOOps_include.f90:3819', &
          !              errst=errst)) return

          call fuse(Tmpd, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlistc: '//&
          !              'fuse (8) failed.', 'MPOOps_include.f90:3824', &
          !              errst=errst)) return

          call kron(Tmpe, Tmpc, Tmpd, 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlistc: '//&
          !              'kron failed.', 'MPOOps_include.f90:3829', &
          !              errst=errst)) return

          call gaxpy(Liou, eye * coupl1, Tmpe)

          call destroy(Tmpa)
          call destroy(Tmpb)
          call destroy(Tmpc)
          call destroy(Tmpd)
          call destroy(Tmpe)
      end do

      ! [many-body string lindblad XY terms] (if length is 2)
      ! ------------------------------------

      do ii = 1, Rs%nmbslxy
          os = Rs%Mbslxy(ii)%n
          if(os /= 2) cycle

          coupl1 = Rs%Mbslxy(ii)%w * get_coupl(Hparams, Rs%Mbslxy(ii)%h, xx)

          ! (L_1 x L_1*) x (L_2 x L_2*)
          ! ...........................

          call copy(Tmpc, Ops%Li(Rs%Mbslxy(ii)%o(os + 1)), trans='C')
          call kron(Tmpa, Ops%Li(Rs%Mbslxy(ii)%o(1)), Tmpc, 1, 1, &
                    'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlistc: '//&
          !              'kron failed.', 'MPOOps_include.f90:3857', &
          !              errst=errst)) return

          call fuse(Tmpa, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlistc: '//&
          !              'fuse failed.', 'MPOOps_include.f90:3862', &
          !              errst=errst)) return

          call destroy(Tmpc)

          call copy(Tmpc, Ops%Li(Rs%Mbslxy(ii)%o(os + 2)), trans='C')
          call kron(Tmpb, Ops%Li(Rs%Mbslxy(ii)%o(2)), Tmpc, 1, 1, &
                    'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlistc: '//&
          !              'kron failed.', 'MPOOps_include.f90:3871', &
          !              errst=errst)) return

          call fuse(Tmpb, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlistc: '//&
          !              'fuse failed.', 'MPOOps_include.f90:3876', &
          !              errst=errst)) return

          call destroy(Tmpc)

          call kron(Tmpc, Tmpa, Tmpb, 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlistc: '//&
          !              'kron failed.', 'MPOOps_include.f90:3883', &
          !              errst=errst)) return

          call gaxpy(Liou, eye * coupl1, Tmpc)

          call destroy(Tmpa)
          call destroy(Tmpb)
          call destroy(Tmpc)

          ! (Ldag_1 L_1 x I_1) x (Ldag_2 L_2 x I_2)
          ! .......................................

          ! Consider 0.5
          coupl1 = -0.5_rKind * coupl1

          ! L^dagger L
          call contr(Tmpa, Ops%Li(Rs%Mbslxy(ii)%o(os + 1)), &
                     Ops%Li(Rs%Mbslxy(ii)%o(1)), [1], [1], transl='C')
          call contr(Tmpb, Ops%Li(Rs%Mbslxy(ii)%o(os + 2)), &
                     Ops%Li(Rs%Mbslxy(ii)%o(2)), [1], [1], transl='C')

          call kron(Tmpc, Tmpa, Ops%Li(iop), 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlistc: '//&
          !              'kron failed.', 'MPOOps_include.f90:3906', &
          !              errst=errst)) return

          call fuse(Tmpc, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlistc: '//&
          !              'fuse (8) failed.', 'MPOOps_include.f90:3911', &
          !              errst=errst)) return

          call kron(Tmpd, Tmpb, Ops%Li(iop), 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlistc: '//&
          !              'kron failed.', 'MPOOps_include.f90:3916', &
          !              errst=errst)) return

          call fuse(Tmpd, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlistc: '//&
          !              'fuse (8) failed.', 'MPOOps_include.f90:3921', &
          !              errst=errst)) return

          call kron(Tmpe, Tmpc, Tmpd, 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlistc: '//&
          !              'kron failed.', 'MPOOps_include.f90:3926', &
          !              errst=errst)) return

          call gaxpy(Liou, eye * coupl1, Tmpe)

          call destroy(Tmpc)
          call destroy(Tmpd)
          call destroy(Tmpe)

          ! (I_1 x (Ldag_1 L_1)^T) x (I_2 x (Ldag_2 L_2)^T)
          ! ...............................................

          call kron(Tmpc, Ops%Li(iop), Tmpa, 1, 1, 'N', 'T', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlistc: '//&
          !              'kron failed.', 'MPOOps_include.f90:3940', &
          !              errst=errst)) return

          call fuse(Tmpc, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlistc: '//&
          !              'fuse (8) failed.', 'MPOOps_include.f90:3945', &
          !              errst=errst)) return

          call kron(Tmpd, Ops%Li(iop), Tmpb, 1, 1, 'N', 'T', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlistc: '//&
          !              'kron failed.', 'MPOOps_include.f90:3950', &
          !              errst=errst)) return

          call fuse(Tmpd, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlistc: '//&
          !              'fuse (8) failed.', 'MPOOps_include.f90:3955', &
          !              errst=errst)) return

          call kron(Tmpe, Tmpc, Tmpd, 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlistc: '//&
          !              'kron failed.', 'MPOOps_include.f90:3960', &
          !              errst=errst)) return

          call gaxpy(Liou, eye * coupl1, Tmpe)

          call destroy(Tmpa)
          call destroy(Tmpb)
          call destroy(Tmpc)
          call destroy(Tmpd)
          call destroy(Tmpe)
      end do

      ! For symmetric tensor, we have to add the diagonal blocks with
      ! zero values (zero block => identity in the exponential)
      if(.false.) then
          call kron(Tmpa, Leye, Leye, 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlistc: '//&
          !              'kron failed.', 'MPOOps_include.f90:3977', &
          !              errst=errst)) return

          call gaxpy(Liou, 0.0_rKind, Tmpa, errst=errst)
          !if(prop_error('ruleset_to_liou_2site_tensorlistc'//&
          !              ' : gaxpy failed.', 'MPOOps_include.f90:3982', &
          !              errst=errst)) return

          call destroy(Tmpa)
      end if

      call destroy(Leye)

  end subroutine ruleset_to_liou_2site_tensorlistc

MPOOps_f90.ruleset_to_liou_2site_qtensorlist()

fortran-subroutine - September 2017 (dj) Build a two-site Liouville operator for a Lindblad master equation.

Arguments

LiouTYPE(qtensorc), inout

On exit, the Liouville operator as rank-4 tensor.

xxINTEGER, in

Get Liouville operator for sites xx, xx+1

RsTYPE(MPORuleSet), in

Contains the rule set to build up the MPO.

OpsTYPE(qtensorlist), inout

List containing all operators for the evolution

HparamsTYPE(HamiltonianParameters), in

containing the couplings for each operator

iopINTEGER, in

The index of the identity in the operator list.

Details

The following rules are considered : site rules for the Hamiltonian, bond rules for the Hamiltonian, site rules for Lindblad operators.

Source Code

show / hide f90 code

  subroutine ruleset_to_liou_2site_qtensorlist(Liou, xx, ll, Rs, Ops, &
                                                   Hparams, iop, errst)
      type(qtensorc), intent(inout) :: Liou
      integer, intent(in) :: xx, ll
      type(MPORuleSet), intent(in) :: Rs
      type(qtensorlist), intent(inout) :: Ops
      type(HamiltonianParameters), pointer, intent(in) :: Hparams(:)
      integer, intent(in) :: iop
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! first index for lindblads / bond rule
      integer :: i1

      ! position of the site xx+1
      integer :: xx1

      ! Offset for MBSLXY rule
      integer :: os

      ! Flag if operator already initialized
      logical :: is_init

      ! indices for fusing
      integer, dimension(2, 2) :: fidx

      ! couplings including weight, hparams etc
      real(KIND=rKind) :: coupl1, coupl2

      ! prefactor considering boundary effects in PBC/OPC
      real(KIND=rKind), dimension(2) :: pre

      ! temporary matrix to calculate the next hamiltonian contribution
      type(qtensor) :: Tmpa, Tmpb, Tmpc, Tmpd, Tmpe, Leye

      !if(present(errst)) errst = 0

      is_init = .false.

      ! generate identity in Liouville space
      call kron(Leye, Ops%Li(iop), Ops%Li(iop), 1, 1, 'N', 'N', 'N')

      fidx = reshape([1, 2, 3, 4], [2, 2])
      call fuse(Leye, fidx, '0', errst=errst)
      !if(prop_error('ruleset_to_liou_2site_qtensorlist: '//&
      !              'fuse (1) failed.', 'MPOOps_include.f90:3553', errst=errst)) return

      ! [local site]
      ! ------------

      if(Rs%pbc) then
          ! Periodic boundary condition - every local term appears twice
          pre = 0.5_rKind
      elseif((xx == 1) .and. (xx == ll - 1)) then
          ! Open boundary conditions - system consists of two sites
          pre = 1.0_rKind
      elseif(xx == 1) then
          ! Open boundary conditions - left border
          pre = [1.0_rKind, 0.5_rKind]
      elseif(xx == ll - 1) then
          ! Open boundary conditions - right border
          pre = [0.5_rKind, 1.0_rKind]
      else
          pre = 0.5_rKind
      end if

      if(xx + 1 > ll) then
          if(Rs%pbc .and. (xx == ll)) then
              xx1 = 1
          else
              errst = raise_error('ruleset_to_ham_2site_qtensorlist'//&
                                  ' : site xx not valid.', 99, errst=errst)
              return
          end if
      else
          xx1 = xx + 1
      end if

      call ruleset_to_clliou_2site(Liou, xx, ll, Rs, Ops, &
           Hparams, iop, is_init=is_init, scconjspace=-1.0_rKind, &
           errst=errst)
      !if(prop_error('ruleset_to_liou_2site_qtensorlist: '//&
      !              'ruleset_to_clliou_2site failed.', 'MPOOps_include.f90:3590', &
      !              errst=errst)) return

      ! [local lindblads]
      ! -----------------

      do ii = 1, Rs%nlxx
          coupl1 = pre(1) * Rs%Lxx(ii)%w * get_coupl(Hparams, Rs%Lxx(ii)%h, xx)
          coupl2 = pre(2) * Rs%Lxx(ii)%w * get_coupl(Hparams, Rs%Lxx(ii)%h, xx1)

          ! (L_1 x L_1*) x (I_2 x I_2)
          call copy(Tmpa, Ops%Li(Rs%Lxx(ii)%o), trans='C')
          call kron(Tmpb, Ops%Li(Rs%Lxx(ii)%o), Tmpa, 1, 1, 'N', 'N', 'N', &
                    errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3605', &
          !              errst=errst)) return

          call fuse(Tmpb, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorlist: '//&
          !              'fuse (8) failed.', 'MPOOps_include.f90:3610', &
          !              errst=errst)) return

          if(is_init) then
              call kron(Tmpc, Tmpb, Leye, 1, 1, 'N', 'N', 'N', errst=errst)
              !if(prop_error('ruleset_to_liou_2site_qtensorlist: '//&
              !              'kron failed.', 'MPOOps_include.f90:3616', &
              !              errst=errst)) return

              call gaxpy(Liou, eye * coupl1, Tmpc)
              call destroy(Tmpc)
          else
              call kron(Liou, Tmpb, Leye, 1, 1, 'N', 'N', 'N', errst=errst)
              !if(prop_error('ruleset_to_liou_2site_qtensorlist: '//&
              !              'kron failed.', 'MPOOps_include.f90:3624', &
              !              errst=errst)) return

              call scale(eye * coupl1, Liou)
              is_init = .true.
          end if

          ! (I_1 x I_1) x (L_2 x L_2*)
          call kron(Tmpc, Leye, Tmpb, 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3634', &
          !              errst=errst)) return

          call gaxpy(Liou, eye * coupl2, Tmpc)

          call destroy(Tmpb)
          call destroy(Tmpc)

          ! Build (L^dagger L)
          call contr(Tmpb, Tmpa, Ops%Li(Rs%Lxx(ii)%o), [1], [1])
          call destroy(Tmpa)

          ! Consider 0.5
          coupl1 = -0.5_rKind * coupl1
          coupl2 = -0.5_rKind * coupl2

          ! (Ldagger_1 L_1 x I_1) x (I_2 x I_2)
          call kron(Tmpa, Tmpb, Ops%Li(iop), 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3653', &
          !              errst=errst)) return

          call fuse(Tmpa, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorlist: '//&
          !              'fuse (9) failed.', 'MPOOps_include.f90:3658', &
          !              errst=errst)) return

          call kron(Tmpc, Tmpa, Leye, 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3663', &
          !              errst=errst)) return

          call gaxpy(Liou, eye * coupl1, Tmpc)
          call destroy(Tmpc)

          ! (I_1 x I_1) x (Ldagger_2 L_2 x I_2)
          call kron(Tmpc, Leye, Tmpa, 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3672', &
          !              errst=errst)) return

          call gaxpy(Liou, eye * coupl2, Tmpc)
          call destroy(Tmpc)

          ! (I_1 (Ldagger_1 L_1)^T) x (I_2 x I_2)
          call kron(Tmpa, Ops%Li(iop), Tmpb, 1, 1, 'N', 'T', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3681', &
          !              errst=errst)) return

          call fuse(Tmpa, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorlist: '//&
          !              'fuse (10) failed.', 'MPOOps_include.f90:3686', &
          !              errst=errst)) return

          call kron(Tmpc, Tmpa, Leye, 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3691', &
          !              errst=errst)) return

          call gaxpy(Liou, eye * coupl1, Tmpc)
          call destroy(Tmpc)

          ! (I_1 x I_1) x (I_2 x (Ldagger_2 L_2)^T)
          call kron(Tmpc, Leye, Tmpa, 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3700', &
          !              errst=errst)) return

          call gaxpy(Liou, eye * coupl2, Tmpc)

          call destroy(Tmpa)
          call destroy(Tmpb)
          call destroy(Tmpc)

      end do

      ! [many-body string lindblad terms (if length is 2)]
      ! --------------------------------------------------

      do ii = 1, Rs%nmbsl
          if(Rs%Mbsl(ii)%n /= 2) cycle

          coupl1 = Rs%Mbsl(ii)%w * get_coupl(Hparams, Rs%Mbsl(ii)%h, xx)

          ! (L_1 x L_1*) x (L_2 x L_2*)
          ! ...........................

          call copy(Tmpc, Ops%Li(Rs%Mbsl(ii)%o(1)), trans='C')
          call kron(Tmpa, Ops%Li(Rs%Mbsl(ii)%o(1)), Tmpc, 1, 1, &
                    'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3726', &
          !              errst=errst)) return

          call fuse(Tmpa, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorlist: '//&
          !              'fuse failed.', 'MPOOps_include.f90:3731', &
          !              errst=errst)) return

          call destroy(Tmpc)

          call copy(Tmpc, Ops%Li(Rs%Mbsl(ii)%o(2)), trans='C')
          call kron(Tmpb, Ops%Li(Rs%Mbsl(ii)%o(2)), Tmpc, 1, 1, &
                    'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3740', &
          !              errst=errst)) return

          call fuse(Tmpb, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorlist: '//&
          !              'fuse failed.', 'MPOOps_include.f90:3745', &
          !              errst=errst)) return

          call destroy(Tmpc)

          call kron(Tmpc, Tmpa, Tmpb, 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3752', &
          !              errst=errst)) return

          call gaxpy(Liou, eye * coupl1, Tmpc)

          call destroy(Tmpa)
          call destroy(Tmpb)
          call destroy(Tmpc)

          ! (Ldag_1 L_1 x I_1) x (Ldag_2 L_2 x I_2)
          ! .......................................

          ! Consider 0.5
          coupl1 = -0.5_rKind * coupl1

          ! L^dagger L
          call contr(Tmpa, Ops%Li(Rs%Mbsl(ii)%o(1)), &
                     Ops%Li(Rs%Mbsl(ii)%o(1)), [1], [1], transl='C')
          call contr(Tmpb, Ops%Li(Rs%Mbsl(ii)%o(2)), &
                     Ops%Li(Rs%Mbsl(ii)%o(2)), [1], [1], transl='C')

          call kron(Tmpc, Tmpa, Ops%Li(iop), 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3775', &
          !              errst=errst)) return

          call fuse(Tmpc, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorlist: '//&
          !              'fuse (8) failed.', 'MPOOps_include.f90:3780', &
          !              errst=errst)) return

          call kron(Tmpd, Tmpb, Ops%Li(iop), 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3785', &
          !              errst=errst)) return

          call fuse(Tmpd, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorlist: '//&
          !              'fuse (8) failed.', 'MPOOps_include.f90:3790', &
          !              errst=errst)) return

          call kron(Tmpe, Tmpc, Tmpd, 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3795', &
          !              errst=errst)) return

          call gaxpy(Liou, eye * coupl1, Tmpe)

          call destroy(Tmpc)
          call destroy(Tmpd)
          call destroy(Tmpe)

          ! (I_1 x (Ldag_1 L_1)^T) x (I_2 x (Ldag_2 L_2)^T)
          ! ...............................................

          call kron(Tmpc, Ops%Li(iop), Tmpa, 1, 1, 'N', 'T', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3809', &
          !              errst=errst)) return

          call fuse(Tmpc, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorlist: '//&
          !              'fuse (8) failed.', 'MPOOps_include.f90:3814', &
          !              errst=errst)) return

          call kron(Tmpd, Ops%Li(iop), Tmpb, 1, 1, 'N', 'T', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3819', &
          !              errst=errst)) return

          call fuse(Tmpd, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorlist: '//&
          !              'fuse (8) failed.', 'MPOOps_include.f90:3824', &
          !              errst=errst)) return

          call kron(Tmpe, Tmpc, Tmpd, 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3829', &
          !              errst=errst)) return

          call gaxpy(Liou, eye * coupl1, Tmpe)

          call destroy(Tmpa)
          call destroy(Tmpb)
          call destroy(Tmpc)
          call destroy(Tmpd)
          call destroy(Tmpe)
      end do

      ! [many-body string lindblad XY terms] (if length is 2)
      ! ------------------------------------

      do ii = 1, Rs%nmbslxy
          os = Rs%Mbslxy(ii)%n
          if(os /= 2) cycle

          coupl1 = Rs%Mbslxy(ii)%w * get_coupl(Hparams, Rs%Mbslxy(ii)%h, xx)

          ! (L_1 x L_1*) x (L_2 x L_2*)
          ! ...........................

          call copy(Tmpc, Ops%Li(Rs%Mbslxy(ii)%o(os + 1)), trans='C')
          call kron(Tmpa, Ops%Li(Rs%Mbslxy(ii)%o(1)), Tmpc, 1, 1, &
                    'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3857', &
          !              errst=errst)) return

          call fuse(Tmpa, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorlist: '//&
          !              'fuse failed.', 'MPOOps_include.f90:3862', &
          !              errst=errst)) return

          call destroy(Tmpc)

          call copy(Tmpc, Ops%Li(Rs%Mbslxy(ii)%o(os + 2)), trans='C')
          call kron(Tmpb, Ops%Li(Rs%Mbslxy(ii)%o(2)), Tmpc, 1, 1, &
                    'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3871', &
          !              errst=errst)) return

          call fuse(Tmpb, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorlist: '//&
          !              'fuse failed.', 'MPOOps_include.f90:3876', &
          !              errst=errst)) return

          call destroy(Tmpc)

          call kron(Tmpc, Tmpa, Tmpb, 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3883', &
          !              errst=errst)) return

          call gaxpy(Liou, eye * coupl1, Tmpc)

          call destroy(Tmpa)
          call destroy(Tmpb)
          call destroy(Tmpc)

          ! (Ldag_1 L_1 x I_1) x (Ldag_2 L_2 x I_2)
          ! .......................................

          ! Consider 0.5
          coupl1 = -0.5_rKind * coupl1

          ! L^dagger L
          call contr(Tmpa, Ops%Li(Rs%Mbslxy(ii)%o(os + 1)), &
                     Ops%Li(Rs%Mbslxy(ii)%o(1)), [1], [1], transl='C')
          call contr(Tmpb, Ops%Li(Rs%Mbslxy(ii)%o(os + 2)), &
                     Ops%Li(Rs%Mbslxy(ii)%o(2)), [1], [1], transl='C')

          call kron(Tmpc, Tmpa, Ops%Li(iop), 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3906', &
          !              errst=errst)) return

          call fuse(Tmpc, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorlist: '//&
          !              'fuse (8) failed.', 'MPOOps_include.f90:3911', &
          !              errst=errst)) return

          call kron(Tmpd, Tmpb, Ops%Li(iop), 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3916', &
          !              errst=errst)) return

          call fuse(Tmpd, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorlist: '//&
          !              'fuse (8) failed.', 'MPOOps_include.f90:3921', &
          !              errst=errst)) return

          call kron(Tmpe, Tmpc, Tmpd, 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3926', &
          !              errst=errst)) return

          call gaxpy(Liou, eye * coupl1, Tmpe)

          call destroy(Tmpc)
          call destroy(Tmpd)
          call destroy(Tmpe)

          ! (I_1 x (Ldag_1 L_1)^T) x (I_2 x (Ldag_2 L_2)^T)
          ! ...............................................

          call kron(Tmpc, Ops%Li(iop), Tmpa, 1, 1, 'N', 'T', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3940', &
          !              errst=errst)) return

          call fuse(Tmpc, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorlist: '//&
          !              'fuse (8) failed.', 'MPOOps_include.f90:3945', &
          !              errst=errst)) return

          call kron(Tmpd, Ops%Li(iop), Tmpb, 1, 1, 'N', 'T', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3950', &
          !              errst=errst)) return

          call fuse(Tmpd, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorlist: '//&
          !              'fuse (8) failed.', 'MPOOps_include.f90:3955', &
          !              errst=errst)) return

          call kron(Tmpe, Tmpc, Tmpd, 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3960', &
          !              errst=errst)) return

          call gaxpy(Liou, eye * coupl1, Tmpe)

          call destroy(Tmpa)
          call destroy(Tmpb)
          call destroy(Tmpc)
          call destroy(Tmpd)
          call destroy(Tmpe)
      end do

      ! For symmetric tensor, we have to add the diagonal blocks with
      ! zero values (zero block => identity in the exponential)
      if(.true.) then
          call kron(Tmpa, Leye, Leye, 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorlist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3977', &
          !              errst=errst)) return

          call gaxpy(Liou, 0.0_rKind, Tmpa, errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorlist'//&
          !              ' : gaxpy failed.', 'MPOOps_include.f90:3982', &
          !              errst=errst)) return

          call destroy(Tmpa)
      end if

      call destroy(Leye)

  end subroutine ruleset_to_liou_2site_qtensorlist

MPOOps_f90.ruleset_to_liou_2site_qtensorclist()

fortran-subroutine - September 2017 (dj) Build a two-site Liouville operator for a Lindblad master equation.

Arguments

LiouTYPE(qtensorc), inout

On exit, the Liouville operator as rank-4 tensor.

xxINTEGER, in

Get Liouville operator for sites xx, xx+1

RsTYPE(MPORuleSet), in

Contains the rule set to build up the MPO.

OpsTYPE(qtensorclist), inout

List containing all operators for the evolution

HparamsTYPE(HamiltonianParameters), in

containing the couplings for each operator

iopINTEGER, in

The index of the identity in the operator list.

Details

The following rules are considered : site rules for the Hamiltonian, bond rules for the Hamiltonian, site rules for Lindblad operators.

Source Code

show / hide f90 code

  subroutine ruleset_to_liou_2site_qtensorclist(Liou, xx, ll, Rs, Ops, &
                                                   Hparams, iop, errst)
      type(qtensorc), intent(inout) :: Liou
      integer, intent(in) :: xx, ll
      type(MPORuleSet), intent(in) :: Rs
      type(qtensorclist), intent(inout) :: Ops
      type(HamiltonianParameters), pointer, intent(in) :: Hparams(:)
      integer, intent(in) :: iop
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! first index for lindblads / bond rule
      integer :: i1

      ! position of the site xx+1
      integer :: xx1

      ! Offset for MBSLXY rule
      integer :: os

      ! Flag if operator already initialized
      logical :: is_init

      ! indices for fusing
      integer, dimension(2, 2) :: fidx

      ! couplings including weight, hparams etc
      real(KIND=rKind) :: coupl1, coupl2

      ! prefactor considering boundary effects in PBC/OPC
      real(KIND=rKind), dimension(2) :: pre

      ! temporary matrix to calculate the next hamiltonian contribution
      type(qtensorc) :: Tmpa, Tmpb, Tmpc, Tmpd, Tmpe, Leye

      !if(present(errst)) errst = 0

      is_init = .false.

      ! generate identity in Liouville space
      call kron(Leye, Ops%Li(iop), Ops%Li(iop), 1, 1, 'N', 'N', 'N')

      fidx = reshape([1, 2, 3, 4], [2, 2])
      call fuse(Leye, fidx, '0', errst=errst)
      !if(prop_error('ruleset_to_liou_2site_qtensorclist: '//&
      !              'fuse (1) failed.', 'MPOOps_include.f90:3553', errst=errst)) return

      ! [local site]
      ! ------------

      if(Rs%pbc) then
          ! Periodic boundary condition - every local term appears twice
          pre = 0.5_rKind
      elseif((xx == 1) .and. (xx == ll - 1)) then
          ! Open boundary conditions - system consists of two sites
          pre = 1.0_rKind
      elseif(xx == 1) then
          ! Open boundary conditions - left border
          pre = [1.0_rKind, 0.5_rKind]
      elseif(xx == ll - 1) then
          ! Open boundary conditions - right border
          pre = [0.5_rKind, 1.0_rKind]
      else
          pre = 0.5_rKind
      end if

      if(xx + 1 > ll) then
          if(Rs%pbc .and. (xx == ll)) then
              xx1 = 1
          else
              errst = raise_error('ruleset_to_ham_2site_qtensorclist'//&
                                  ' : site xx not valid.', 99, errst=errst)
              return
          end if
      else
          xx1 = xx + 1
      end if

      call ruleset_to_clliou_2site(Liou, xx, ll, Rs, Ops, &
           Hparams, iop, is_init=is_init, scconjspace=-1.0_rKind, &
           errst=errst)
      !if(prop_error('ruleset_to_liou_2site_qtensorclist: '//&
      !              'ruleset_to_clliou_2site failed.', 'MPOOps_include.f90:3590', &
      !              errst=errst)) return

      ! [local lindblads]
      ! -----------------

      do ii = 1, Rs%nlxx
          coupl1 = pre(1) * Rs%Lxx(ii)%w * get_coupl(Hparams, Rs%Lxx(ii)%h, xx)
          coupl2 = pre(2) * Rs%Lxx(ii)%w * get_coupl(Hparams, Rs%Lxx(ii)%h, xx1)

          ! (L_1 x L_1*) x (I_2 x I_2)
          call copy(Tmpa, Ops%Li(Rs%Lxx(ii)%o), trans='C')
          call kron(Tmpb, Ops%Li(Rs%Lxx(ii)%o), Tmpa, 1, 1, 'N', 'N', 'N', &
                    errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorclist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3605', &
          !              errst=errst)) return

          call fuse(Tmpb, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorclist: '//&
          !              'fuse (8) failed.', 'MPOOps_include.f90:3610', &
          !              errst=errst)) return

          if(is_init) then
              call kron(Tmpc, Tmpb, Leye, 1, 1, 'N', 'N', 'N', errst=errst)
              !if(prop_error('ruleset_to_liou_2site_qtensorclist: '//&
              !              'kron failed.', 'MPOOps_include.f90:3616', &
              !              errst=errst)) return

              call gaxpy(Liou, eye * coupl1, Tmpc)
              call destroy(Tmpc)
          else
              call kron(Liou, Tmpb, Leye, 1, 1, 'N', 'N', 'N', errst=errst)
              !if(prop_error('ruleset_to_liou_2site_qtensorclist: '//&
              !              'kron failed.', 'MPOOps_include.f90:3624', &
              !              errst=errst)) return

              call scale(eye * coupl1, Liou)
              is_init = .true.
          end if

          ! (I_1 x I_1) x (L_2 x L_2*)
          call kron(Tmpc, Leye, Tmpb, 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorclist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3634', &
          !              errst=errst)) return

          call gaxpy(Liou, eye * coupl2, Tmpc)

          call destroy(Tmpb)
          call destroy(Tmpc)

          ! Build (L^dagger L)
          call contr(Tmpb, Tmpa, Ops%Li(Rs%Lxx(ii)%o), [1], [1])
          call destroy(Tmpa)

          ! Consider 0.5
          coupl1 = -0.5_rKind * coupl1
          coupl2 = -0.5_rKind * coupl2

          ! (Ldagger_1 L_1 x I_1) x (I_2 x I_2)
          call kron(Tmpa, Tmpb, Ops%Li(iop), 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorclist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3653', &
          !              errst=errst)) return

          call fuse(Tmpa, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorclist: '//&
          !              'fuse (9) failed.', 'MPOOps_include.f90:3658', &
          !              errst=errst)) return

          call kron(Tmpc, Tmpa, Leye, 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorclist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3663', &
          !              errst=errst)) return

          call gaxpy(Liou, eye * coupl1, Tmpc)
          call destroy(Tmpc)

          ! (I_1 x I_1) x (Ldagger_2 L_2 x I_2)
          call kron(Tmpc, Leye, Tmpa, 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorclist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3672', &
          !              errst=errst)) return

          call gaxpy(Liou, eye * coupl2, Tmpc)
          call destroy(Tmpc)

          ! (I_1 (Ldagger_1 L_1)^T) x (I_2 x I_2)
          call kron(Tmpa, Ops%Li(iop), Tmpb, 1, 1, 'N', 'T', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorclist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3681', &
          !              errst=errst)) return

          call fuse(Tmpa, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorclist: '//&
          !              'fuse (10) failed.', 'MPOOps_include.f90:3686', &
          !              errst=errst)) return

          call kron(Tmpc, Tmpa, Leye, 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorclist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3691', &
          !              errst=errst)) return

          call gaxpy(Liou, eye * coupl1, Tmpc)
          call destroy(Tmpc)

          ! (I_1 x I_1) x (I_2 x (Ldagger_2 L_2)^T)
          call kron(Tmpc, Leye, Tmpa, 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorclist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3700', &
          !              errst=errst)) return

          call gaxpy(Liou, eye * coupl2, Tmpc)

          call destroy(Tmpa)
          call destroy(Tmpb)
          call destroy(Tmpc)

      end do

      ! [many-body string lindblad terms (if length is 2)]
      ! --------------------------------------------------

      do ii = 1, Rs%nmbsl
          if(Rs%Mbsl(ii)%n /= 2) cycle

          coupl1 = Rs%Mbsl(ii)%w * get_coupl(Hparams, Rs%Mbsl(ii)%h, xx)

          ! (L_1 x L_1*) x (L_2 x L_2*)
          ! ...........................

          call copy(Tmpc, Ops%Li(Rs%Mbsl(ii)%o(1)), trans='C')
          call kron(Tmpa, Ops%Li(Rs%Mbsl(ii)%o(1)), Tmpc, 1, 1, &
                    'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorclist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3726', &
          !              errst=errst)) return

          call fuse(Tmpa, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorclist: '//&
          !              'fuse failed.', 'MPOOps_include.f90:3731', &
          !              errst=errst)) return

          call destroy(Tmpc)

          call copy(Tmpc, Ops%Li(Rs%Mbsl(ii)%o(2)), trans='C')
          call kron(Tmpb, Ops%Li(Rs%Mbsl(ii)%o(2)), Tmpc, 1, 1, &
                    'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorclist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3740', &
          !              errst=errst)) return

          call fuse(Tmpb, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorclist: '//&
          !              'fuse failed.', 'MPOOps_include.f90:3745', &
          !              errst=errst)) return

          call destroy(Tmpc)

          call kron(Tmpc, Tmpa, Tmpb, 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorclist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3752', &
          !              errst=errst)) return

          call gaxpy(Liou, eye * coupl1, Tmpc)

          call destroy(Tmpa)
          call destroy(Tmpb)
          call destroy(Tmpc)

          ! (Ldag_1 L_1 x I_1) x (Ldag_2 L_2 x I_2)
          ! .......................................

          ! Consider 0.5
          coupl1 = -0.5_rKind * coupl1

          ! L^dagger L
          call contr(Tmpa, Ops%Li(Rs%Mbsl(ii)%o(1)), &
                     Ops%Li(Rs%Mbsl(ii)%o(1)), [1], [1], transl='C')
          call contr(Tmpb, Ops%Li(Rs%Mbsl(ii)%o(2)), &
                     Ops%Li(Rs%Mbsl(ii)%o(2)), [1], [1], transl='C')

          call kron(Tmpc, Tmpa, Ops%Li(iop), 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorclist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3775', &
          !              errst=errst)) return

          call fuse(Tmpc, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorclist: '//&
          !              'fuse (8) failed.', 'MPOOps_include.f90:3780', &
          !              errst=errst)) return

          call kron(Tmpd, Tmpb, Ops%Li(iop), 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorclist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3785', &
          !              errst=errst)) return

          call fuse(Tmpd, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorclist: '//&
          !              'fuse (8) failed.', 'MPOOps_include.f90:3790', &
          !              errst=errst)) return

          call kron(Tmpe, Tmpc, Tmpd, 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorclist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3795', &
          !              errst=errst)) return

          call gaxpy(Liou, eye * coupl1, Tmpe)

          call destroy(Tmpc)
          call destroy(Tmpd)
          call destroy(Tmpe)

          ! (I_1 x (Ldag_1 L_1)^T) x (I_2 x (Ldag_2 L_2)^T)
          ! ...............................................

          call kron(Tmpc, Ops%Li(iop), Tmpa, 1, 1, 'N', 'T', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorclist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3809', &
          !              errst=errst)) return

          call fuse(Tmpc, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorclist: '//&
          !              'fuse (8) failed.', 'MPOOps_include.f90:3814', &
          !              errst=errst)) return

          call kron(Tmpd, Ops%Li(iop), Tmpb, 1, 1, 'N', 'T', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorclist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3819', &
          !              errst=errst)) return

          call fuse(Tmpd, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorclist: '//&
          !              'fuse (8) failed.', 'MPOOps_include.f90:3824', &
          !              errst=errst)) return

          call kron(Tmpe, Tmpc, Tmpd, 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorclist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3829', &
          !              errst=errst)) return

          call gaxpy(Liou, eye * coupl1, Tmpe)

          call destroy(Tmpa)
          call destroy(Tmpb)
          call destroy(Tmpc)
          call destroy(Tmpd)
          call destroy(Tmpe)
      end do

      ! [many-body string lindblad XY terms] (if length is 2)
      ! ------------------------------------

      do ii = 1, Rs%nmbslxy
          os = Rs%Mbslxy(ii)%n
          if(os /= 2) cycle

          coupl1 = Rs%Mbslxy(ii)%w * get_coupl(Hparams, Rs%Mbslxy(ii)%h, xx)

          ! (L_1 x L_1*) x (L_2 x L_2*)
          ! ...........................

          call copy(Tmpc, Ops%Li(Rs%Mbslxy(ii)%o(os + 1)), trans='C')
          call kron(Tmpa, Ops%Li(Rs%Mbslxy(ii)%o(1)), Tmpc, 1, 1, &
                    'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorclist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3857', &
          !              errst=errst)) return

          call fuse(Tmpa, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorclist: '//&
          !              'fuse failed.', 'MPOOps_include.f90:3862', &
          !              errst=errst)) return

          call destroy(Tmpc)

          call copy(Tmpc, Ops%Li(Rs%Mbslxy(ii)%o(os + 2)), trans='C')
          call kron(Tmpb, Ops%Li(Rs%Mbslxy(ii)%o(2)), Tmpc, 1, 1, &
                    'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorclist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3871', &
          !              errst=errst)) return

          call fuse(Tmpb, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorclist: '//&
          !              'fuse failed.', 'MPOOps_include.f90:3876', &
          !              errst=errst)) return

          call destroy(Tmpc)

          call kron(Tmpc, Tmpa, Tmpb, 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorclist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3883', &
          !              errst=errst)) return

          call gaxpy(Liou, eye * coupl1, Tmpc)

          call destroy(Tmpa)
          call destroy(Tmpb)
          call destroy(Tmpc)

          ! (Ldag_1 L_1 x I_1) x (Ldag_2 L_2 x I_2)
          ! .......................................

          ! Consider 0.5
          coupl1 = -0.5_rKind * coupl1

          ! L^dagger L
          call contr(Tmpa, Ops%Li(Rs%Mbslxy(ii)%o(os + 1)), &
                     Ops%Li(Rs%Mbslxy(ii)%o(1)), [1], [1], transl='C')
          call contr(Tmpb, Ops%Li(Rs%Mbslxy(ii)%o(os + 2)), &
                     Ops%Li(Rs%Mbslxy(ii)%o(2)), [1], [1], transl='C')

          call kron(Tmpc, Tmpa, Ops%Li(iop), 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorclist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3906', &
          !              errst=errst)) return

          call fuse(Tmpc, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorclist: '//&
          !              'fuse (8) failed.', 'MPOOps_include.f90:3911', &
          !              errst=errst)) return

          call kron(Tmpd, Tmpb, Ops%Li(iop), 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorclist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3916', &
          !              errst=errst)) return

          call fuse(Tmpd, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorclist: '//&
          !              'fuse (8) failed.', 'MPOOps_include.f90:3921', &
          !              errst=errst)) return

          call kron(Tmpe, Tmpc, Tmpd, 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorclist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3926', &
          !              errst=errst)) return

          call gaxpy(Liou, eye * coupl1, Tmpe)

          call destroy(Tmpc)
          call destroy(Tmpd)
          call destroy(Tmpe)

          ! (I_1 x (Ldag_1 L_1)^T) x (I_2 x (Ldag_2 L_2)^T)
          ! ...............................................

          call kron(Tmpc, Ops%Li(iop), Tmpa, 1, 1, 'N', 'T', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorclist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3940', &
          !              errst=errst)) return

          call fuse(Tmpc, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorclist: '//&
          !              'fuse (8) failed.', 'MPOOps_include.f90:3945', &
          !              errst=errst)) return

          call kron(Tmpd, Ops%Li(iop), Tmpb, 1, 1, 'N', 'T', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorclist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3950', &
          !              errst=errst)) return

          call fuse(Tmpd, fidx, '0', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorclist: '//&
          !              'fuse (8) failed.', 'MPOOps_include.f90:3955', &
          !              errst=errst)) return

          call kron(Tmpe, Tmpc, Tmpd, 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorclist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3960', &
          !              errst=errst)) return

          call gaxpy(Liou, eye * coupl1, Tmpe)

          call destroy(Tmpa)
          call destroy(Tmpb)
          call destroy(Tmpc)
          call destroy(Tmpd)
          call destroy(Tmpe)
      end do

      ! For symmetric tensor, we have to add the diagonal blocks with
      ! zero values (zero block => identity in the exponential)
      if(.true.) then
          call kron(Tmpa, Leye, Leye, 1, 1, 'N', 'N', 'N', errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorclist: '//&
          !              'kron failed.', 'MPOOps_include.f90:3977', &
          !              errst=errst)) return

          call gaxpy(Liou, 0.0_rKind, Tmpa, errst=errst)
          !if(prop_error('ruleset_to_liou_2site_qtensorclist'//&
          !              ' : gaxpy failed.', 'MPOOps_include.f90:3982', &
          !              errst=errst)) return

          call destroy(Tmpa)
      end if

      call destroy(Leye)

  end subroutine ruleset_to_liou_2site_qtensorclist

MPOOps_f90.ruleset_to_ham_mpo_tensorlist_mpo()

fortran-subroutine - May 2017 (dj, updated) Construct an MPO from a set of rules, an alphabet of operators, and a set of hamiltonian parameters (obtained from Python frontend)

Arguments

HamTYPE(Fmpo), inout

initialized during this subroutine.

RsTYPE(MPORuleSet), inout

Rule set for simulation

llINTEGER, inout

number of sites in the system.

OpsTYPE(tensorlist), inout

Operator alphabet contain all operators to build MPO.

HparamsTYPE(HamiltonianParameters)(*), POINTER, in

Hamiltonian parameters contain coupling etc.

iopINTEGER, in

The index of the identity in the operator list.

Source Code

show / hide f90 code

  subroutine ruleset_to_ham_mpo_tensorlist_mpo(Ham, Rs, ll, Ops, &
                                                         Hparams, iop, errst)
      type(mpo), intent(inout) :: Ham
      type(MPORuleSet), intent(in) :: Rs
      integer, intent(in) :: ll
      type(tensorlist), intent(in) :: Ops
      type(HamiltonianParameters), pointer, intent(in) :: Hparams(:)
      integer, intent(in) :: iop
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! looping over sites
      integer :: xx

      ! bond dimension for MPO rules / MPO
      integer :: bd, bdff, bdmb

      !if(present(errst)) errst = 0

      Ham%ti = .true.
      do ii = 1, size(Hparams)
          if(.not. Hparams(ii - 1)%ti) Ham%ti = .false.
      end do

      Ham%ll = ll
      allocate(Ham%Ws(ll))

      ! Preliminary calculations
      ! ------------------------

      ! Count the bond dimension for FF rules and MBString rules
      bdff = 0
      do ii = 1, Rs%nff
          bdff = bdff + Rs%FF(ii)%r_c
      end do

      bdmb = 0
      do ii = 1, Rs%nmb
          bdmb = bdmb + Rs%MB(ii)%n - 1
      end do

      ! Bond dimension is bond dimension of two-site operator
      ! (+2 if on-site terms)
      bd = 2 + Rs%nbond + bdff + Rs%nexp + Rs%nprod + bdmb + Rs%ntterm

      if(Rs%pbc) then
          bd = bd + Rs%nbond
      end if

      ! Set the MPO matrices
      ! --------------------
      !
      ! The order is
      ! [local site] [bond] [prod] [exp] [TT] [ff] [mbstring] [identity]

      if(Ham%ti) then
          ! Translation invariant: Set first, bulk, and last + pointers
          ! ...........................................................

          call set_first_mpo_tensorlist_mpo(Ham%Wl, Rs, Ops, &
               Hparams, bd, 1, iop, errst=errst)
          !if(prop_error('ruleset_to_ham_mpo_tensorlist_'//&
          !              'mpo: set_first_mpo failed.', &
          !              'MPOOps_include.f90:4117', errst=errst)) return

          call set_bulk_mpo_tensorlist_mpo(Ham%Wb, Rs, Ops, &
                                                     Hparams, bd, 2, iop)

          call set_last_mpo_tensorlist_mpo(Ham%Wr, Rs, Ops, &
                                                     Hparams, bd, 3, iop)

          call set_timpo_pointers(Ham)
      else
          ! Spatial dependent couplings: set all individual
          ! ...............................................

          call set_first_mpo_tensorlist_mpo(Ham%Ws(1), Rs, Ops, &
                                                      Hparams, bd, 1, iop)

          do xx = 2, (ll - 1)
              call set_bulk_mpo_tensorlist_mpo(Ham%Ws(xx), Rs, Ops, &
                                                         Hparams, bd, xx, iop)
          end do

          call set_last_mpo_tensorlist_mpo(Ham%Ws(ll), Rs, Ops, &
                                                     Hparams, bd, ll, iop)
      end if

  end subroutine ruleset_to_ham_mpo_tensorlist_mpo

MPOOps_f90.ruleset_to_ham_mpo_tensorlist_mpoc()

fortran-subroutine - May 2017 (dj, updated) Construct an MPO from a set of rules, an alphabet of operators, and a set of hamiltonian parameters (obtained from Python frontend)

Arguments

HamTYPE(Fmpoc), inout

initialized during this subroutine.

RsTYPE(MPORuleSet), inout

Rule set for simulation

llINTEGER, inout

number of sites in the system.

OpsTYPE(tensorlist), inout

Operator alphabet contain all operators to build MPO.

HparamsTYPE(HamiltonianParameters)(*), POINTER, in

Hamiltonian parameters contain coupling etc.

iopINTEGER, in

The index of the identity in the operator list.

Source Code

show / hide f90 code

  subroutine ruleset_to_ham_mpo_tensorlist_mpoc(Ham, Rs, ll, Ops, &
                                                         Hparams, iop, errst)
      type(mpoc), intent(inout) :: Ham
      type(MPORuleSet), intent(in) :: Rs
      integer, intent(in) :: ll
      type(tensorlist), intent(in) :: Ops
      type(HamiltonianParameters), pointer, intent(in) :: Hparams(:)
      integer, intent(in) :: iop
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! looping over sites
      integer :: xx

      ! bond dimension for MPO rules / MPO
      integer :: bd, bdff, bdmb

      !if(present(errst)) errst = 0

      Ham%ti = .true.
      do ii = 1, size(Hparams)
          if(.not. Hparams(ii - 1)%ti) Ham%ti = .false.
      end do

      Ham%ll = ll
      allocate(Ham%Ws(ll))

      ! Preliminary calculations
      ! ------------------------

      ! Count the bond dimension for FF rules and MBString rules
      bdff = 0
      do ii = 1, Rs%nff
          bdff = bdff + Rs%FF(ii)%r_c
      end do

      bdmb = 0
      do ii = 1, Rs%nmb
          bdmb = bdmb + Rs%MB(ii)%n - 1
      end do

      ! Bond dimension is bond dimension of two-site operator
      ! (+2 if on-site terms)
      bd = 2 + Rs%nbond + bdff + Rs%nexp + Rs%nprod + bdmb + Rs%ntterm

      if(Rs%pbc) then
          bd = bd + Rs%nbond
      end if

      ! Set the MPO matrices
      ! --------------------
      !
      ! The order is
      ! [local site] [bond] [prod] [exp] [TT] [ff] [mbstring] [identity]

      if(Ham%ti) then
          ! Translation invariant: Set first, bulk, and last + pointers
          ! ...........................................................

          call set_first_mpo_tensorlist_mpoc(Ham%Wl, Rs, Ops, &
               Hparams, bd, 1, iop, errst=errst)
          !if(prop_error('ruleset_to_ham_mpo_tensorlist_'//&
          !              'mpoc: set_first_mpo failed.', &
          !              'MPOOps_include.f90:4117', errst=errst)) return

          call set_bulk_mpo_tensorlist_mpoc(Ham%Wb, Rs, Ops, &
                                                     Hparams, bd, 2, iop)

          call set_last_mpo_tensorlist_mpoc(Ham%Wr, Rs, Ops, &
                                                     Hparams, bd, 3, iop)

          call set_timpo_pointers(Ham)
      else
          ! Spatial dependent couplings: set all individual
          ! ...............................................

          call set_first_mpo_tensorlist_mpoc(Ham%Ws(1), Rs, Ops, &
                                                      Hparams, bd, 1, iop)

          do xx = 2, (ll - 1)
              call set_bulk_mpo_tensorlist_mpoc(Ham%Ws(xx), Rs, Ops, &
                                                         Hparams, bd, xx, iop)
          end do

          call set_last_mpo_tensorlist_mpoc(Ham%Ws(ll), Rs, Ops, &
                                                     Hparams, bd, ll, iop)
      end if

  end subroutine ruleset_to_ham_mpo_tensorlist_mpoc

MPOOps_f90.ruleset_to_ham_mpo_tensorlistc_mpoc()

fortran-subroutine - May 2017 (dj, updated) Construct an MPO from a set of rules, an alphabet of operators, and a set of hamiltonian parameters (obtained from Python frontend)

Arguments

HamTYPE(Fmpoc), inout

initialized during this subroutine.

RsTYPE(MPORuleSet), inout

Rule set for simulation

llINTEGER, inout

number of sites in the system.

OpsTYPE(tensorlistc), inout

Operator alphabet contain all operators to build MPO.

HparamsTYPE(HamiltonianParameters)(*), POINTER, in

Hamiltonian parameters contain coupling etc.

iopINTEGER, in

The index of the identity in the operator list.

Source Code

show / hide f90 code

  subroutine ruleset_to_ham_mpo_tensorlistc_mpoc(Ham, Rs, ll, Ops, &
                                                         Hparams, iop, errst)
      type(mpoc), intent(inout) :: Ham
      type(MPORuleSet), intent(in) :: Rs
      integer, intent(in) :: ll
      type(tensorlistc), intent(in) :: Ops
      type(HamiltonianParameters), pointer, intent(in) :: Hparams(:)
      integer, intent(in) :: iop
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! looping over sites
      integer :: xx

      ! bond dimension for MPO rules / MPO
      integer :: bd, bdff, bdmb

      !if(present(errst)) errst = 0

      Ham%ti = .true.
      do ii = 1, size(Hparams)
          if(.not. Hparams(ii - 1)%ti) Ham%ti = .false.
      end do

      Ham%ll = ll
      allocate(Ham%Ws(ll))

      ! Preliminary calculations
      ! ------------------------

      ! Count the bond dimension for FF rules and MBString rules
      bdff = 0
      do ii = 1, Rs%nff
          bdff = bdff + Rs%FF(ii)%r_c
      end do

      bdmb = 0
      do ii = 1, Rs%nmb
          bdmb = bdmb + Rs%MB(ii)%n - 1
      end do

      ! Bond dimension is bond dimension of two-site operator
      ! (+2 if on-site terms)
      bd = 2 + Rs%nbond + bdff + Rs%nexp + Rs%nprod + bdmb + Rs%ntterm

      if(Rs%pbc) then
          bd = bd + Rs%nbond
      end if

      ! Set the MPO matrices
      ! --------------------
      !
      ! The order is
      ! [local site] [bond] [prod] [exp] [TT] [ff] [mbstring] [identity]

      if(Ham%ti) then
          ! Translation invariant: Set first, bulk, and last + pointers
          ! ...........................................................

          call set_first_mpo_tensorlistc_mpoc(Ham%Wl, Rs, Ops, &
               Hparams, bd, 1, iop, errst=errst)
          !if(prop_error('ruleset_to_ham_mpo_tensorlistc_'//&
          !              'mpoc: set_first_mpo failed.', &
          !              'MPOOps_include.f90:4117', errst=errst)) return

          call set_bulk_mpo_tensorlistc_mpoc(Ham%Wb, Rs, Ops, &
                                                     Hparams, bd, 2, iop)

          call set_last_mpo_tensorlistc_mpoc(Ham%Wr, Rs, Ops, &
                                                     Hparams, bd, 3, iop)

          call set_timpo_pointers(Ham)
      else
          ! Spatial dependent couplings: set all individual
          ! ...............................................

          call set_first_mpo_tensorlistc_mpoc(Ham%Ws(1), Rs, Ops, &
                                                      Hparams, bd, 1, iop)

          do xx = 2, (ll - 1)
              call set_bulk_mpo_tensorlistc_mpoc(Ham%Ws(xx), Rs, Ops, &
                                                         Hparams, bd, xx, iop)
          end do

          call set_last_mpo_tensorlistc_mpoc(Ham%Ws(ll), Rs, Ops, &
                                                     Hparams, bd, ll, iop)
      end if

  end subroutine ruleset_to_ham_mpo_tensorlistc_mpoc

MPOOps_f90.ruleset_to_ham_mpo_qtensorlist_qmpo()

fortran-subroutine - May 2017 (dj, updated) Construct an MPO from a set of rules, an alphabet of operators, and a set of hamiltonian parameters (obtained from Python frontend)

Arguments

HamTYPE(Fqmpo), inout

initialized during this subroutine.

RsTYPE(MPORuleSet), inout

Rule set for simulation

llINTEGER, inout

number of sites in the system.

OpsTYPE(qtensorlist), inout

Operator alphabet contain all operators to build MPO.

HparamsTYPE(HamiltonianParameters)(*), POINTER, in

Hamiltonian parameters contain coupling etc.

iopINTEGER, in

The index of the identity in the operator list.

Source Code

show / hide f90 code

  subroutine ruleset_to_ham_mpo_qtensorlist_qmpo(Ham, Rs, ll, Ops, &
                                                         Hparams, iop, errst)
      type(qmpo), intent(inout) :: Ham
      type(MPORuleSet), intent(in) :: Rs
      integer, intent(in) :: ll
      type(qtensorlist), intent(in) :: Ops
      type(HamiltonianParameters), pointer, intent(in) :: Hparams(:)
      integer, intent(in) :: iop
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! looping over sites
      integer :: xx

      ! bond dimension for MPO rules / MPO
      integer :: bd, bdff, bdmb

      !if(present(errst)) errst = 0

      Ham%ti = .true.
      do ii = 1, size(Hparams)
          if(.not. Hparams(ii - 1)%ti) Ham%ti = .false.
      end do

      Ham%ll = ll
      allocate(Ham%Ws(ll))

      ! Preliminary calculations
      ! ------------------------

      ! Count the bond dimension for FF rules and MBString rules
      bdff = 0
      do ii = 1, Rs%nff
          bdff = bdff + Rs%FF(ii)%r_c
      end do

      bdmb = 0
      do ii = 1, Rs%nmb
          bdmb = bdmb + Rs%MB(ii)%n - 1
      end do

      ! Bond dimension is bond dimension of two-site operator
      ! (+2 if on-site terms)
      bd = 2 + Rs%nbond + bdff + Rs%nexp + Rs%nprod + bdmb + Rs%ntterm

      if(Rs%pbc) then
          bd = bd + Rs%nbond
      end if

      ! Set the MPO matrices
      ! --------------------
      !
      ! The order is
      ! [local site] [bond] [prod] [exp] [TT] [ff] [mbstring] [identity]

      if(Ham%ti) then
          ! Translation invariant: Set first, bulk, and last + pointers
          ! ...........................................................

          call set_first_mpo_qtensorlist_qmpo(Ham%Wl, Rs, Ops, &
               Hparams, bd, 1, iop, errst=errst)
          !if(prop_error('ruleset_to_ham_mpo_qtensorlist_'//&
          !              'qmpo: set_first_mpo failed.', &
          !              'MPOOps_include.f90:4117', errst=errst)) return

          call set_bulk_mpo_qtensorlist_qmpo(Ham%Wb, Rs, Ops, &
                                                     Hparams, bd, 2, iop)

          call set_last_mpo_qtensorlist_qmpo(Ham%Wr, Rs, Ops, &
                                                     Hparams, bd, 3, iop)

          call set_timpo_pointers(Ham)
      else
          ! Spatial dependent couplings: set all individual
          ! ...............................................

          call set_first_mpo_qtensorlist_qmpo(Ham%Ws(1), Rs, Ops, &
                                                      Hparams, bd, 1, iop)

          do xx = 2, (ll - 1)
              call set_bulk_mpo_qtensorlist_qmpo(Ham%Ws(xx), Rs, Ops, &
                                                         Hparams, bd, xx, iop)
          end do

          call set_last_mpo_qtensorlist_qmpo(Ham%Ws(ll), Rs, Ops, &
                                                     Hparams, bd, ll, iop)
      end if

  end subroutine ruleset_to_ham_mpo_qtensorlist_qmpo

MPOOps_f90.ruleset_to_ham_mpo_qtensorlist_qmpoc()

fortran-subroutine - May 2017 (dj, updated) Construct an MPO from a set of rules, an alphabet of operators, and a set of hamiltonian parameters (obtained from Python frontend)

Arguments

HamTYPE(Fqmpoc), inout

initialized during this subroutine.

RsTYPE(MPORuleSet), inout

Rule set for simulation

llINTEGER, inout

number of sites in the system.

OpsTYPE(qtensorlist), inout

Operator alphabet contain all operators to build MPO.

HparamsTYPE(HamiltonianParameters)(*), POINTER, in

Hamiltonian parameters contain coupling etc.

iopINTEGER, in

The index of the identity in the operator list.

Source Code

show / hide f90 code

  subroutine ruleset_to_ham_mpo_qtensorlist_qmpoc(Ham, Rs, ll, Ops, &
                                                         Hparams, iop, errst)
      type(qmpoc), intent(inout) :: Ham
      type(MPORuleSet), intent(in) :: Rs
      integer, intent(in) :: ll
      type(qtensorlist), intent(in) :: Ops
      type(HamiltonianParameters), pointer, intent(in) :: Hparams(:)
      integer, intent(in) :: iop
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! looping over sites
      integer :: xx

      ! bond dimension for MPO rules / MPO
      integer :: bd, bdff, bdmb

      !if(present(errst)) errst = 0

      Ham%ti = .true.
      do ii = 1, size(Hparams)
          if(.not. Hparams(ii - 1)%ti) Ham%ti = .false.
      end do

      Ham%ll = ll
      allocate(Ham%Ws(ll))

      ! Preliminary calculations
      ! ------------------------

      ! Count the bond dimension for FF rules and MBString rules
      bdff = 0
      do ii = 1, Rs%nff
          bdff = bdff + Rs%FF(ii)%r_c
      end do

      bdmb = 0
      do ii = 1, Rs%nmb
          bdmb = bdmb + Rs%MB(ii)%n - 1
      end do

      ! Bond dimension is bond dimension of two-site operator
      ! (+2 if on-site terms)
      bd = 2 + Rs%nbond + bdff + Rs%nexp + Rs%nprod + bdmb + Rs%ntterm

      if(Rs%pbc) then
          bd = bd + Rs%nbond
      end if

      ! Set the MPO matrices
      ! --------------------
      !
      ! The order is
      ! [local site] [bond] [prod] [exp] [TT] [ff] [mbstring] [identity]

      if(Ham%ti) then
          ! Translation invariant: Set first, bulk, and last + pointers
          ! ...........................................................

          call set_first_mpo_qtensorlist_qmpoc(Ham%Wl, Rs, Ops, &
               Hparams, bd, 1, iop, errst=errst)
          !if(prop_error('ruleset_to_ham_mpo_qtensorlist_'//&
          !              'qmpoc: set_first_mpo failed.', &
          !              'MPOOps_include.f90:4117', errst=errst)) return

          call set_bulk_mpo_qtensorlist_qmpoc(Ham%Wb, Rs, Ops, &
                                                     Hparams, bd, 2, iop)

          call set_last_mpo_qtensorlist_qmpoc(Ham%Wr, Rs, Ops, &
                                                     Hparams, bd, 3, iop)

          call set_timpo_pointers(Ham)
      else
          ! Spatial dependent couplings: set all individual
          ! ...............................................

          call set_first_mpo_qtensorlist_qmpoc(Ham%Ws(1), Rs, Ops, &
                                                      Hparams, bd, 1, iop)

          do xx = 2, (ll - 1)
              call set_bulk_mpo_qtensorlist_qmpoc(Ham%Ws(xx), Rs, Ops, &
                                                         Hparams, bd, xx, iop)
          end do

          call set_last_mpo_qtensorlist_qmpoc(Ham%Ws(ll), Rs, Ops, &
                                                     Hparams, bd, ll, iop)
      end if

  end subroutine ruleset_to_ham_mpo_qtensorlist_qmpoc

MPOOps_f90.ruleset_to_ham_mpo_qtensorclist_qmpoc()

fortran-subroutine - May 2017 (dj, updated) Construct an MPO from a set of rules, an alphabet of operators, and a set of hamiltonian parameters (obtained from Python frontend)

Arguments

HamTYPE(Fqmpoc), inout

initialized during this subroutine.

RsTYPE(MPORuleSet), inout

Rule set for simulation

llINTEGER, inout

number of sites in the system.

OpsTYPE(qtensorclist), inout

Operator alphabet contain all operators to build MPO.

HparamsTYPE(HamiltonianParameters)(*), POINTER, in

Hamiltonian parameters contain coupling etc.

iopINTEGER, in

The index of the identity in the operator list.

Source Code

show / hide f90 code

  subroutine ruleset_to_ham_mpo_qtensorclist_qmpoc(Ham, Rs, ll, Ops, &
                                                         Hparams, iop, errst)
      type(qmpoc), intent(inout) :: Ham
      type(MPORuleSet), intent(in) :: Rs
      integer, intent(in) :: ll
      type(qtensorclist), intent(in) :: Ops
      type(HamiltonianParameters), pointer, intent(in) :: Hparams(:)
      integer, intent(in) :: iop
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! looping over sites
      integer :: xx

      ! bond dimension for MPO rules / MPO
      integer :: bd, bdff, bdmb

      !if(present(errst)) errst = 0

      Ham%ti = .true.
      do ii = 1, size(Hparams)
          if(.not. Hparams(ii - 1)%ti) Ham%ti = .false.
      end do

      Ham%ll = ll
      allocate(Ham%Ws(ll))

      ! Preliminary calculations
      ! ------------------------

      ! Count the bond dimension for FF rules and MBString rules
      bdff = 0
      do ii = 1, Rs%nff
          bdff = bdff + Rs%FF(ii)%r_c
      end do

      bdmb = 0
      do ii = 1, Rs%nmb
          bdmb = bdmb + Rs%MB(ii)%n - 1
      end do

      ! Bond dimension is bond dimension of two-site operator
      ! (+2 if on-site terms)
      bd = 2 + Rs%nbond + bdff + Rs%nexp + Rs%nprod + bdmb + Rs%ntterm

      if(Rs%pbc) then
          bd = bd + Rs%nbond
      end if

      ! Set the MPO matrices
      ! --------------------
      !
      ! The order is
      ! [local site] [bond] [prod] [exp] [TT] [ff] [mbstring] [identity]

      if(Ham%ti) then
          ! Translation invariant: Set first, bulk, and last + pointers
          ! ...........................................................

          call set_first_mpo_qtensorclist_qmpoc(Ham%Wl, Rs, Ops, &
               Hparams, bd, 1, iop, errst=errst)
          !if(prop_error('ruleset_to_ham_mpo_qtensorclist_'//&
          !              'qmpoc: set_first_mpo failed.', &
          !              'MPOOps_include.f90:4117', errst=errst)) return

          call set_bulk_mpo_qtensorclist_qmpoc(Ham%Wb, Rs, Ops, &
                                                     Hparams, bd, 2, iop)

          call set_last_mpo_qtensorclist_qmpoc(Ham%Wr, Rs, Ops, &
                                                     Hparams, bd, 3, iop)

          call set_timpo_pointers(Ham)
      else
          ! Spatial dependent couplings: set all individual
          ! ...............................................

          call set_first_mpo_qtensorclist_qmpoc(Ham%Ws(1), Rs, Ops, &
                                                      Hparams, bd, 1, iop)

          do xx = 2, (ll - 1)
              call set_bulk_mpo_qtensorclist_qmpoc(Ham%Ws(xx), Rs, Ops, &
                                                         Hparams, bd, xx, iop)
          end do

          call set_last_mpo_qtensorclist_qmpoc(Ham%Ws(ll), Rs, Ops, &
                                                     Hparams, bd, ll, iop)
      end if

  end subroutine ruleset_to_ham_mpo_qtensorclist_qmpoc

MPOOps_f90.ruleset_to_effham_mpo_tensorlist_mpoc()

fortran-subroutine - May 2017 (dj, updated) Construct an MPO from a set of rules, an alphabet of operators, and a set of hamiltonian parameters (obtained from Python frontend) This subroutine generates an effective Hamiltonian.

Arguments

HamTYPE(Fmpoc), inout

initialized during this subroutine.

RsTYPE(MPORuleSet), inout

Rule set for simulation

llINTEGER, inout

number of sites in the system.

OpsTYPE(tensorlist), inout

Operator alphabet contain all operators to build MPO.

HparamsTYPE(HamiltonianParameters)(*), POINTER, in

Hamiltonian parameters contain coupling etc.

iopINTEGER, in

The index of the identity in the operator list.

Details

In order to allow for more complicated Lindblad terms, we build the MPO from scratch and do not copy the closed system MPO and modify it.

Source Code

show / hide f90 code

  subroutine ruleset_to_effham_mpo_tensorlist_mpoc(Ham, Rs, ll, &
       Ops, Hparams, iop, errst)
      type(mpoc), intent(inout) :: Ham
      type(MPORuleSet), intent(in) :: Rs
      integer, intent(in) :: ll
      type(tensorlist), intent(inout) :: Ops
      type(HamiltonianParameters), pointer, intent(in) :: Hparams(:)
      integer, intent(in) :: iop
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! looping over sites
      integer :: xx

      ! bond dimension for MPO rules / MPO
      integer :: bd, bdff, bdmb, bdmbsl

      !if(present(errst)) errst = 0

      Ham%ti = .true.
      do ii = 1, size(Hparams)
          if(.not. Hparams(ii - 1)%ti) Ham%ti = .false.
      end do

      Ham%ll = ll
      allocate(Ham%Ws(ll))

      ! Preliminary calculations
      ! ------------------------

      ! Count the bond dimension for FF rules, MBString rules, and
      ! MBSLindblad rules
      bdff = 0
      do ii = 1, Rs%nff
          bdff = bdff + Rs%FF(ii)%r_c
      end do

      bdmb = 0
      do ii = 1, Rs%nmb
          bdmb = bdmb + Rs%MB(ii)%n - 1
      end do

      bdmbsl = 0
      do ii = 1, Rs%nmbsl
          bdmbsl = bdmbsl + Rs%Mbsl(ii)%n - 1
      end do

      do ii = 1, Rs%nmbslxy
          bdmbsl = bdmbsl + Rs%Mbslxy(ii)%n - 1
      end do

      ! Bond dimension is bond dimension of two-site operator
      ! (+2 if on-site terms)
      bd = 2 + Rs%nbond + bdff + Rs%nexp + Rs%nprod + bdmb + Rs%ntterm &
           + bdmbsl + Rs%nlexp

      if(Rs%pbc) then
          bd = bd + Rs%nbond
      end if

      ! Set the MPO matrices
      ! --------------------
      !
      ! The order is [local site] [bond] [prod] [exp] [TT] [LindExp] ...
      ! ...  [ff] [mbstring] [mbslind] [mbslxy] [identity]

      if(Ham%ti) then
          ! Translation invariant: Set first, bulk, and last + pointers
          ! ...........................................................

          call set_first_effmpo_tensorlist_mpoc(Ham%Wl, Rs, &
               Ops, Hparams, bd, 1, iop, errst=errst)
          !if(prop_error('ruleset_to_ham_mpo_tensorlist'//&
          !              '_mpoc : set_first... failed.', &
          !              'MPOOps_include.f90:4941', errst=errst)) return

          call set_bulk_effmpo_tensorlist_mpoc(Ham%Wb, Rs, &
               Ops, Hparams, bd, 2, iop, errst=errst)
          !if(prop_error('ruleset_to_ham_mpo_tensorlist'//&
          !              '_mpoc : set_bulk... failed.', &
          !              'MPOOps_include.f90:4947', errst=errst)) return

          call set_last_effmpo_tensorlist_mpoc(Ham%Wr, Rs, &
               Ops, Hparams, bd, 3, iop, errst=errst)
          !if(prop_error('ruleset_to_ham_mpo_tensorlist'//&
          !              '_mpoc : set_last... failed.', &
          !              'MPOOps_include.f90:4953', errst=errst)) return

          call set_timpo_pointers(Ham)
      else
          ! Spatial dependent couplings: set all individual
          ! ...............................................

          call set_first_effmpo_tensorlist_mpoc(Ham%Ws(1), Rs, &
               Ops, Hparams, bd, 1, iop, errst=errst)
          !if(prop_error('ruleset_to_ham_mpo_tensorlist'//&
          !              '_mpoc : set_first... failed.', &
          !              'MPOOps_include.f90:4964', errst=errst)) return

          do xx = 2, (ll - 1)
              call set_bulk_effmpo_tensorlist_mpoc(Ham%Ws(xx), Rs, &
                   Ops, Hparams, bd, xx, iop, errst=errst)
              !if(prop_error('ruleset_to_ham_mpo_tensorlist'//&
              !              '_mpoc : set_bulk... failed.', &
              !              'MPOOps_include.f90:4971', errst=errst)) return
          end do

          call set_last_effmpo_tensorlist_mpoc(Ham%Ws(ll), Rs, &
               Ops, Hparams, bd, ll, iop, errst=errst)
          !if(prop_error('ruleset_to_ham_mpo_tensorlist'//&
          !              '_mpoc : set_last... failed.', &
          !              'MPOOps_include.f90:4978', errst=errst)) return
      end if

  end subroutine ruleset_to_effham_mpo_tensorlist_mpoc

MPOOps_f90.ruleset_to_effham_mpo_tensorlistc_mpoc()

fortran-subroutine - May 2017 (dj, updated) Construct an MPO from a set of rules, an alphabet of operators, and a set of hamiltonian parameters (obtained from Python frontend) This subroutine generates an effective Hamiltonian.

Arguments

HamTYPE(Fmpoc), inout

initialized during this subroutine.

RsTYPE(MPORuleSet), inout

Rule set for simulation

llINTEGER, inout

number of sites in the system.

OpsTYPE(tensorlistc), inout

Operator alphabet contain all operators to build MPO.

HparamsTYPE(HamiltonianParameters)(*), POINTER, in

Hamiltonian parameters contain coupling etc.

iopINTEGER, in

The index of the identity in the operator list.

Details

In order to allow for more complicated Lindblad terms, we build the MPO from scratch and do not copy the closed system MPO and modify it.

Source Code

show / hide f90 code

  subroutine ruleset_to_effham_mpo_tensorlistc_mpoc(Ham, Rs, ll, &
       Ops, Hparams, iop, errst)
      type(mpoc), intent(inout) :: Ham
      type(MPORuleSet), intent(in) :: Rs
      integer, intent(in) :: ll
      type(tensorlistc), intent(inout) :: Ops
      type(HamiltonianParameters), pointer, intent(in) :: Hparams(:)
      integer, intent(in) :: iop
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! looping over sites
      integer :: xx

      ! bond dimension for MPO rules / MPO
      integer :: bd, bdff, bdmb, bdmbsl

      !if(present(errst)) errst = 0

      Ham%ti = .true.
      do ii = 1, size(Hparams)
          if(.not. Hparams(ii - 1)%ti) Ham%ti = .false.
      end do

      Ham%ll = ll
      allocate(Ham%Ws(ll))

      ! Preliminary calculations
      ! ------------------------

      ! Count the bond dimension for FF rules, MBString rules, and
      ! MBSLindblad rules
      bdff = 0
      do ii = 1, Rs%nff
          bdff = bdff + Rs%FF(ii)%r_c
      end do

      bdmb = 0
      do ii = 1, Rs%nmb
          bdmb = bdmb + Rs%MB(ii)%n - 1
      end do

      bdmbsl = 0
      do ii = 1, Rs%nmbsl
          bdmbsl = bdmbsl + Rs%Mbsl(ii)%n - 1
      end do

      do ii = 1, Rs%nmbslxy
          bdmbsl = bdmbsl + Rs%Mbslxy(ii)%n - 1
      end do

      ! Bond dimension is bond dimension of two-site operator
      ! (+2 if on-site terms)
      bd = 2 + Rs%nbond + bdff + Rs%nexp + Rs%nprod + bdmb + Rs%ntterm &
           + bdmbsl + Rs%nlexp

      if(Rs%pbc) then
          bd = bd + Rs%nbond
      end if

      ! Set the MPO matrices
      ! --------------------
      !
      ! The order is [local site] [bond] [prod] [exp] [TT] [LindExp] ...
      ! ...  [ff] [mbstring] [mbslind] [mbslxy] [identity]

      if(Ham%ti) then
          ! Translation invariant: Set first, bulk, and last + pointers
          ! ...........................................................

          call set_first_effmpo_tensorlistc_mpoc(Ham%Wl, Rs, &
               Ops, Hparams, bd, 1, iop, errst=errst)
          !if(prop_error('ruleset_to_ham_mpo_tensorlistc'//&
          !              '_mpoc : set_first... failed.', &
          !              'MPOOps_include.f90:4941', errst=errst)) return

          call set_bulk_effmpo_tensorlistc_mpoc(Ham%Wb, Rs, &
               Ops, Hparams, bd, 2, iop, errst=errst)
          !if(prop_error('ruleset_to_ham_mpo_tensorlistc'//&
          !              '_mpoc : set_bulk... failed.', &
          !              'MPOOps_include.f90:4947', errst=errst)) return

          call set_last_effmpo_tensorlistc_mpoc(Ham%Wr, Rs, &
               Ops, Hparams, bd, 3, iop, errst=errst)
          !if(prop_error('ruleset_to_ham_mpo_tensorlistc'//&
          !              '_mpoc : set_last... failed.', &
          !              'MPOOps_include.f90:4953', errst=errst)) return

          call set_timpo_pointers(Ham)
      else
          ! Spatial dependent couplings: set all individual
          ! ...............................................

          call set_first_effmpo_tensorlistc_mpoc(Ham%Ws(1), Rs, &
               Ops, Hparams, bd, 1, iop, errst=errst)
          !if(prop_error('ruleset_to_ham_mpo_tensorlistc'//&
          !              '_mpoc : set_first... failed.', &
          !              'MPOOps_include.f90:4964', errst=errst)) return

          do xx = 2, (ll - 1)
              call set_bulk_effmpo_tensorlistc_mpoc(Ham%Ws(xx), Rs, &
                   Ops, Hparams, bd, xx, iop, errst=errst)
              !if(prop_error('ruleset_to_ham_mpo_tensorlistc'//&
              !              '_mpoc : set_bulk... failed.', &
              !              'MPOOps_include.f90:4971', errst=errst)) return
          end do

          call set_last_effmpo_tensorlistc_mpoc(Ham%Ws(ll), Rs, &
               Ops, Hparams, bd, ll, iop, errst=errst)
          !if(prop_error('ruleset_to_ham_mpo_tensorlistc'//&
          !              '_mpoc : set_last... failed.', &
          !              'MPOOps_include.f90:4978', errst=errst)) return
      end if

  end subroutine ruleset_to_effham_mpo_tensorlistc_mpoc

MPOOps_f90.ruleset_to_effham_mpo_qtensorlist_qmpoc()

fortran-subroutine - May 2017 (dj, updated) Construct an MPO from a set of rules, an alphabet of operators, and a set of hamiltonian parameters (obtained from Python frontend) This subroutine generates an effective Hamiltonian.

Arguments

HamTYPE(Fqmpoc), inout

initialized during this subroutine.

RsTYPE(MPORuleSet), inout

Rule set for simulation

llINTEGER, inout

number of sites in the system.

OpsTYPE(qtensorlist), inout

Operator alphabet contain all operators to build MPO.

HparamsTYPE(HamiltonianParameters)(*), POINTER, in

Hamiltonian parameters contain coupling etc.

iopINTEGER, in

The index of the identity in the operator list.

Details

In order to allow for more complicated Lindblad terms, we build the MPO from scratch and do not copy the closed system MPO and modify it.

Source Code

show / hide f90 code

  subroutine ruleset_to_effham_mpo_qtensorlist_qmpoc(Ham, Rs, ll, &
       Ops, Hparams, iop, errst)
      type(qmpoc), intent(inout) :: Ham
      type(MPORuleSet), intent(in) :: Rs
      integer, intent(in) :: ll
      type(qtensorlist), intent(inout) :: Ops
      type(HamiltonianParameters), pointer, intent(in) :: Hparams(:)
      integer, intent(in) :: iop
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! looping over sites
      integer :: xx

      ! bond dimension for MPO rules / MPO
      integer :: bd, bdff, bdmb, bdmbsl

      !if(present(errst)) errst = 0

      Ham%ti = .true.
      do ii = 1, size(Hparams)
          if(.not. Hparams(ii - 1)%ti) Ham%ti = .false.
      end do

      Ham%ll = ll
      allocate(Ham%Ws(ll))

      ! Preliminary calculations
      ! ------------------------

      ! Count the bond dimension for FF rules, MBString rules, and
      ! MBSLindblad rules
      bdff = 0
      do ii = 1, Rs%nff
          bdff = bdff + Rs%FF(ii)%r_c
      end do

      bdmb = 0
      do ii = 1, Rs%nmb
          bdmb = bdmb + Rs%MB(ii)%n - 1
      end do

      bdmbsl = 0
      do ii = 1, Rs%nmbsl
          bdmbsl = bdmbsl + Rs%Mbsl(ii)%n - 1
      end do

      do ii = 1, Rs%nmbslxy
          bdmbsl = bdmbsl + Rs%Mbslxy(ii)%n - 1
      end do

      ! Bond dimension is bond dimension of two-site operator
      ! (+2 if on-site terms)
      bd = 2 + Rs%nbond + bdff + Rs%nexp + Rs%nprod + bdmb + Rs%ntterm &
           + bdmbsl + Rs%nlexp

      if(Rs%pbc) then
          bd = bd + Rs%nbond
      end if

      ! Set the MPO matrices
      ! --------------------
      !
      ! The order is [local site] [bond] [prod] [exp] [TT] [LindExp] ...
      ! ...  [ff] [mbstring] [mbslind] [mbslxy] [identity]

      if(Ham%ti) then
          ! Translation invariant: Set first, bulk, and last + pointers
          ! ...........................................................

          call set_first_effmpo_qtensorlist_qmpoc(Ham%Wl, Rs, &
               Ops, Hparams, bd, 1, iop, errst=errst)
          !if(prop_error('ruleset_to_ham_mpo_qtensorlist'//&
          !              '_qmpoc : set_first... failed.', &
          !              'MPOOps_include.f90:4941', errst=errst)) return

          call set_bulk_effmpo_qtensorlist_qmpoc(Ham%Wb, Rs, &
               Ops, Hparams, bd, 2, iop, errst=errst)
          !if(prop_error('ruleset_to_ham_mpo_qtensorlist'//&
          !              '_qmpoc : set_bulk... failed.', &
          !              'MPOOps_include.f90:4947', errst=errst)) return

          call set_last_effmpo_qtensorlist_qmpoc(Ham%Wr, Rs, &
               Ops, Hparams, bd, 3, iop, errst=errst)
          !if(prop_error('ruleset_to_ham_mpo_qtensorlist'//&
          !              '_qmpoc : set_last... failed.', &
          !              'MPOOps_include.f90:4953', errst=errst)) return

          call set_timpo_pointers(Ham)
      else
          ! Spatial dependent couplings: set all individual
          ! ...............................................

          call set_first_effmpo_qtensorlist_qmpoc(Ham%Ws(1), Rs, &
               Ops, Hparams, bd, 1, iop, errst=errst)
          !if(prop_error('ruleset_to_ham_mpo_qtensorlist'//&
          !              '_qmpoc : set_first... failed.', &
          !              'MPOOps_include.f90:4964', errst=errst)) return

          do xx = 2, (ll - 1)
              call set_bulk_effmpo_qtensorlist_qmpoc(Ham%Ws(xx), Rs, &
                   Ops, Hparams, bd, xx, iop, errst=errst)
              !if(prop_error('ruleset_to_ham_mpo_qtensorlist'//&
              !              '_qmpoc : set_bulk... failed.', &
              !              'MPOOps_include.f90:4971', errst=errst)) return
          end do

          call set_last_effmpo_qtensorlist_qmpoc(Ham%Ws(ll), Rs, &
               Ops, Hparams, bd, ll, iop, errst=errst)
          !if(prop_error('ruleset_to_ham_mpo_qtensorlist'//&
          !              '_qmpoc : set_last... failed.', &
          !              'MPOOps_include.f90:4978', errst=errst)) return
      end if

  end subroutine ruleset_to_effham_mpo_qtensorlist_qmpoc

MPOOps_f90.ruleset_to_effham_mpo_qtensorclist_qmpoc()

fortran-subroutine - May 2017 (dj, updated) Construct an MPO from a set of rules, an alphabet of operators, and a set of hamiltonian parameters (obtained from Python frontend) This subroutine generates an effective Hamiltonian.

Arguments

HamTYPE(Fqmpoc), inout

initialized during this subroutine.

RsTYPE(MPORuleSet), inout

Rule set for simulation

llINTEGER, inout

number of sites in the system.

OpsTYPE(qtensorclist), inout

Operator alphabet contain all operators to build MPO.

HparamsTYPE(HamiltonianParameters)(*), POINTER, in

Hamiltonian parameters contain coupling etc.

iopINTEGER, in

The index of the identity in the operator list.

Details

In order to allow for more complicated Lindblad terms, we build the MPO from scratch and do not copy the closed system MPO and modify it.

Source Code

show / hide f90 code

  subroutine ruleset_to_effham_mpo_qtensorclist_qmpoc(Ham, Rs, ll, &
       Ops, Hparams, iop, errst)
      type(qmpoc), intent(inout) :: Ham
      type(MPORuleSet), intent(in) :: Rs
      integer, intent(in) :: ll
      type(qtensorclist), intent(inout) :: Ops
      type(HamiltonianParameters), pointer, intent(in) :: Hparams(:)
      integer, intent(in) :: iop
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! looping over sites
      integer :: xx

      ! bond dimension for MPO rules / MPO
      integer :: bd, bdff, bdmb, bdmbsl

      !if(present(errst)) errst = 0

      Ham%ti = .true.
      do ii = 1, size(Hparams)
          if(.not. Hparams(ii - 1)%ti) Ham%ti = .false.
      end do

      Ham%ll = ll
      allocate(Ham%Ws(ll))

      ! Preliminary calculations
      ! ------------------------

      ! Count the bond dimension for FF rules, MBString rules, and
      ! MBSLindblad rules
      bdff = 0
      do ii = 1, Rs%nff
          bdff = bdff + Rs%FF(ii)%r_c
      end do

      bdmb = 0
      do ii = 1, Rs%nmb
          bdmb = bdmb + Rs%MB(ii)%n - 1
      end do

      bdmbsl = 0
      do ii = 1, Rs%nmbsl
          bdmbsl = bdmbsl + Rs%Mbsl(ii)%n - 1
      end do

      do ii = 1, Rs%nmbslxy
          bdmbsl = bdmbsl + Rs%Mbslxy(ii)%n - 1
      end do

      ! Bond dimension is bond dimension of two-site operator
      ! (+2 if on-site terms)
      bd = 2 + Rs%nbond + bdff + Rs%nexp + Rs%nprod + bdmb + Rs%ntterm &
           + bdmbsl + Rs%nlexp

      if(Rs%pbc) then
          bd = bd + Rs%nbond
      end if

      ! Set the MPO matrices
      ! --------------------
      !
      ! The order is [local site] [bond] [prod] [exp] [TT] [LindExp] ...
      ! ...  [ff] [mbstring] [mbslind] [mbslxy] [identity]

      if(Ham%ti) then
          ! Translation invariant: Set first, bulk, and last + pointers
          ! ...........................................................

          call set_first_effmpo_qtensorclist_qmpoc(Ham%Wl, Rs, &
               Ops, Hparams, bd, 1, iop, errst=errst)
          !if(prop_error('ruleset_to_ham_mpo_qtensorclist'//&
          !              '_qmpoc : set_first... failed.', &
          !              'MPOOps_include.f90:4941', errst=errst)) return

          call set_bulk_effmpo_qtensorclist_qmpoc(Ham%Wb, Rs, &
               Ops, Hparams, bd, 2, iop, errst=errst)
          !if(prop_error('ruleset_to_ham_mpo_qtensorclist'//&
          !              '_qmpoc : set_bulk... failed.', &
          !              'MPOOps_include.f90:4947', errst=errst)) return

          call set_last_effmpo_qtensorclist_qmpoc(Ham%Wr, Rs, &
               Ops, Hparams, bd, 3, iop, errst=errst)
          !if(prop_error('ruleset_to_ham_mpo_qtensorclist'//&
          !              '_qmpoc : set_last... failed.', &
          !              'MPOOps_include.f90:4953', errst=errst)) return

          call set_timpo_pointers(Ham)
      else
          ! Spatial dependent couplings: set all individual
          ! ...............................................

          call set_first_effmpo_qtensorclist_qmpoc(Ham%Ws(1), Rs, &
               Ops, Hparams, bd, 1, iop, errst=errst)
          !if(prop_error('ruleset_to_ham_mpo_qtensorclist'//&
          !              '_qmpoc : set_first... failed.', &
          !              'MPOOps_include.f90:4964', errst=errst)) return

          do xx = 2, (ll - 1)
              call set_bulk_effmpo_qtensorclist_qmpoc(Ham%Ws(xx), Rs, &
                   Ops, Hparams, bd, xx, iop, errst=errst)
              !if(prop_error('ruleset_to_ham_mpo_qtensorclist'//&
              !              '_qmpoc : set_bulk... failed.', &
              !              'MPOOps_include.f90:4971', errst=errst)) return
          end do

          call set_last_effmpo_qtensorclist_qmpoc(Ham%Ws(ll), Rs, &
               Ops, Hparams, bd, ll, iop, errst=errst)
          !if(prop_error('ruleset_to_ham_mpo_qtensorclist'//&
          !              '_qmpoc : set_last... failed.', &
          !              'MPOOps_include.f90:4978', errst=errst)) return
      end if

  end subroutine ruleset_to_effham_mpo_qtensorclist_qmpoc

MPOOps_f90.ruleset_to_liou_mpo_tensorlist_mpoc()

fortran-subroutine - May 2017 (dj, updated) Construct an MPO from a set of rules, an alphabet of operators, and a set of hamiltonian parameters (obtained from Python frontend). This subroutine is the open quantum system version constructing the Liouville operator.

Arguments

HamTYPE(Fmpoc), inout

initialized during this subroutine.

RsTYPE(MPORuleSet), inout

Rule set for simulation

llINTEGER, inout

number of sites in the system.

OpsTYPE(tensorlist), inout

Operator alphabet contain all operators to build MPO.

HparamsTYPE(HamiltonianParameters)(*), POINTER, in

Hamiltonian parameters contain coupling etc.

iopINTEGER, in

The index of the identity in the operator list.

Source Code

show / hide f90 code

  subroutine ruleset_to_liou_mpo_tensorlist_mpoc(Ham, Rs, ll, Ops, &
                                                          Hparams, iop, errst)
      type(mpoc), intent(inout) :: Ham
      type(MPORuleSet), intent(in) :: Rs
      integer, intent(in) :: ll
      type(tensorlist), intent(inout) :: Ops
      type(HamiltonianParameters), pointer, intent(in) :: Hparams(:)
      integer, intent(in) :: iop
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! looping over sites
      integer :: xx

      ! bond dimension for MPO rules / MPO
      integer :: bd, bdff, bdmb, bdmbsl

      !if(present(errst)) errst = 0

      Ham%ti = .true.
      do ii = 1, size(Hparams)
          if(.not. Hparams(ii - 1)%ti) Ham%ti = .false.
      end do

      Ham%ll = ll
      allocate(Ham%Ws(ll))

      ! Preliminary calculations
      ! ------------------------

      ! Count the bond dimension for FF rules and MBString rules
      bdff = 0
      do ii = 1, Rs%nff
          bdff = bdff + Rs%FF(ii)%r_c
      end do

      bdmb = 0
      do ii = 1, Rs%nmb
          bdmb = bdmb + Rs%MB(ii)%n - 1
      end do

      bdmbsl = 0
      do ii = 1, Rs%nmbsl
          bdmbsl = bdmbsl + Rs%Mbsl(ii)%n - 1
      end do

      do ii = 1, Rs%nmbslxy
          bdmbsl = bdmbsl + Rs%Mbslxy(ii)%n - 1
      end do

      ! Bond dimension is bond dimension of two-site operator
      ! (+2 if on-site terms, MBS-Lind needs three times the bond dimension)
      bd = 2 + 2 * (Rs%nbond + Rs%nexp + Rs%nprod + Rs%ntterm + bdff + bdmb) &
           + 3 * bdmbsl + 3 * Rs%nlexp
      if(Rs%pbc) then
          bd = bd + 2 * Rs%nbond
      end if

      ! Set the MPO matrices
      ! --------------------
      !
      ! The order is [local site] [bond] [prod] [exp] [TT] [LindExp] ...
      ! ... [ff] [mbstring] [mbs lind] [identity]

      if(Ham%ti) then
          ! Translation invariant: Set first, bulk, and last + pointers
          ! ...........................................................

          call set_first_lmpo_tensorlist_mpoc(Ham%Wl, Rs, Ops, &
                                                       Hparams, bd, 1, iop)
          call fuse(Ham%Wl, errst=errst)
          !if(prop_error('ruleset_to_liou_mpo_tensorlist'//&
          !              '_mpoc : fuse (1) failed.', &
          !              errst=errst)) return

          call set_bulk_lmpo_tensorlist_mpoc(Ham%Wb, Rs, Ops, &
                                                      Hparams, bd, 2, iop)
          call fuse(Ham%Wb, errst=errst)
          !if(prop_error('ruleset_to_liou_mpo_tensorlist'//&
          !              '_mpoc : fuse (2) failed.', &
          !              errst=errst)) return

          call set_last_lmpo_tensorlist_mpoc(Ham%Wr, Rs, Ops, &
                                                      Hparams, bd, 3, iop)
          call fuse(Ham%Wr, errst=errst)
          !if(prop_error('ruleset_to_liou_mpo_tensorlist'//&
          !              '_mpoc : fuse (3) failed.', &
          !              errst=errst)) return

          call set_timpo_pointers(Ham)
      else
          ! Spatial dependent couplings: set all individual
          ! ...............................................

          call set_first_lmpo_tensorlist_mpoc(Ham%Ws(1), Rs, Ops, &
                                                       Hparams, bd, 1, iop)
          call fuse(Ham%Ws(1), errst=errst)
          !if(prop_error('ruleset_to_liou_mpo_tensorlist'//&
          !              '_mpoc : fuse (4) failed.', &
          !              errst=errst)) return

          do xx = 2, (ll - 1)
              call set_bulk_lmpo_tensorlist_mpoc(Ham%Ws(xx), Rs, Ops, &
                                                          Hparams, bd, xx, iop)
              call fuse(Ham%Ws(xx), errst=errst)
              !if(prop_error('ruleset_to_liou_mpo_tensorlist'//&
              !              '_mpoc : fuse (5) failed.', &
              !              errst=errst)) return
          end do

          call set_last_lmpo_tensorlist_mpoc(Ham%Ws(ll), Rs, Ops, &
                                                      Hparams, bd, ll, iop)
          call fuse(Ham%Ws(ll), errst=errst)
          !if(prop_error('ruleset_to_liou_mpo_tensorlist'//&
          !              '_mpoc : fuse (6) failed.', &
          !              errst=errst)) return
      end if

      ! The Hamiltonian MPO has operator hashed according to the last index.
      ! Zaletel hashes on its own, others not necessary right now as far as
      ! I believe.
      !call set_hash(Ham, [2])

  end subroutine ruleset_to_liou_mpo_tensorlist_mpoc

MPOOps_f90.ruleset_to_liou_mpo_tensorlistc_mpoc()

fortran-subroutine - May 2017 (dj, updated) Construct an MPO from a set of rules, an alphabet of operators, and a set of hamiltonian parameters (obtained from Python frontend). This subroutine is the open quantum system version constructing the Liouville operator.

Arguments

HamTYPE(Fmpoc), inout

initialized during this subroutine.

RsTYPE(MPORuleSet), inout

Rule set for simulation

llINTEGER, inout

number of sites in the system.

OpsTYPE(tensorlistc), inout

Operator alphabet contain all operators to build MPO.

HparamsTYPE(HamiltonianParameters)(*), POINTER, in

Hamiltonian parameters contain coupling etc.

iopINTEGER, in

The index of the identity in the operator list.

Source Code

show / hide f90 code

  subroutine ruleset_to_liou_mpo_tensorlistc_mpoc(Ham, Rs, ll, Ops, &
                                                          Hparams, iop, errst)
      type(mpoc), intent(inout) :: Ham
      type(MPORuleSet), intent(in) :: Rs
      integer, intent(in) :: ll
      type(tensorlistc), intent(inout) :: Ops
      type(HamiltonianParameters), pointer, intent(in) :: Hparams(:)
      integer, intent(in) :: iop
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! looping over sites
      integer :: xx

      ! bond dimension for MPO rules / MPO
      integer :: bd, bdff, bdmb, bdmbsl

      !if(present(errst)) errst = 0

      Ham%ti = .true.
      do ii = 1, size(Hparams)
          if(.not. Hparams(ii - 1)%ti) Ham%ti = .false.
      end do

      Ham%ll = ll
      allocate(Ham%Ws(ll))

      ! Preliminary calculations
      ! ------------------------

      ! Count the bond dimension for FF rules and MBString rules
      bdff = 0
      do ii = 1, Rs%nff
          bdff = bdff + Rs%FF(ii)%r_c
      end do

      bdmb = 0
      do ii = 1, Rs%nmb
          bdmb = bdmb + Rs%MB(ii)%n - 1
      end do

      bdmbsl = 0
      do ii = 1, Rs%nmbsl
          bdmbsl = bdmbsl + Rs%Mbsl(ii)%n - 1
      end do

      do ii = 1, Rs%nmbslxy
          bdmbsl = bdmbsl + Rs%Mbslxy(ii)%n - 1
      end do

      ! Bond dimension is bond dimension of two-site operator
      ! (+2 if on-site terms, MBS-Lind needs three times the bond dimension)
      bd = 2 + 2 * (Rs%nbond + Rs%nexp + Rs%nprod + Rs%ntterm + bdff + bdmb) &
           + 3 * bdmbsl + 3 * Rs%nlexp
      if(Rs%pbc) then
          bd = bd + 2 * Rs%nbond
      end if

      ! Set the MPO matrices
      ! --------------------
      !
      ! The order is [local site] [bond] [prod] [exp] [TT] [LindExp] ...
      ! ... [ff] [mbstring] [mbs lind] [identity]

      if(Ham%ti) then
          ! Translation invariant: Set first, bulk, and last + pointers
          ! ...........................................................

          call set_first_lmpo_tensorlistc_mpoc(Ham%Wl, Rs, Ops, &
                                                       Hparams, bd, 1, iop)
          call fuse(Ham%Wl, errst=errst)
          !if(prop_error('ruleset_to_liou_mpo_tensorlistc'//&
          !              '_mpoc : fuse (1) failed.', &
          !              errst=errst)) return

          call set_bulk_lmpo_tensorlistc_mpoc(Ham%Wb, Rs, Ops, &
                                                      Hparams, bd, 2, iop)
          call fuse(Ham%Wb, errst=errst)
          !if(prop_error('ruleset_to_liou_mpo_tensorlistc'//&
          !              '_mpoc : fuse (2) failed.', &
          !              errst=errst)) return

          call set_last_lmpo_tensorlistc_mpoc(Ham%Wr, Rs, Ops, &
                                                      Hparams, bd, 3, iop)
          call fuse(Ham%Wr, errst=errst)
          !if(prop_error('ruleset_to_liou_mpo_tensorlistc'//&
          !              '_mpoc : fuse (3) failed.', &
          !              errst=errst)) return

          call set_timpo_pointers(Ham)
      else
          ! Spatial dependent couplings: set all individual
          ! ...............................................

          call set_first_lmpo_tensorlistc_mpoc(Ham%Ws(1), Rs, Ops, &
                                                       Hparams, bd, 1, iop)
          call fuse(Ham%Ws(1), errst=errst)
          !if(prop_error('ruleset_to_liou_mpo_tensorlistc'//&
          !              '_mpoc : fuse (4) failed.', &
          !              errst=errst)) return

          do xx = 2, (ll - 1)
              call set_bulk_lmpo_tensorlistc_mpoc(Ham%Ws(xx), Rs, Ops, &
                                                          Hparams, bd, xx, iop)
              call fuse(Ham%Ws(xx), errst=errst)
              !if(prop_error('ruleset_to_liou_mpo_tensorlistc'//&
              !              '_mpoc : fuse (5) failed.', &
              !              errst=errst)) return
          end do

          call set_last_lmpo_tensorlistc_mpoc(Ham%Ws(ll), Rs, Ops, &
                                                      Hparams, bd, ll, iop)
          call fuse(Ham%Ws(ll), errst=errst)
          !if(prop_error('ruleset_to_liou_mpo_tensorlistc'//&
          !              '_mpoc : fuse (6) failed.', &
          !              errst=errst)) return
      end if

      ! The Hamiltonian MPO has operator hashed according to the last index.
      ! Zaletel hashes on its own, others not necessary right now as far as
      ! I believe.
      !call set_hash(Ham, [2])

  end subroutine ruleset_to_liou_mpo_tensorlistc_mpoc

MPOOps_f90.ruleset_to_liou_mpo_qtensorlist_qmpoc()

fortran-subroutine - May 2017 (dj, updated) Construct an MPO from a set of rules, an alphabet of operators, and a set of hamiltonian parameters (obtained from Python frontend). This subroutine is the open quantum system version constructing the Liouville operator.

Arguments

HamTYPE(Fqmpoc), inout

initialized during this subroutine.

RsTYPE(MPORuleSet), inout

Rule set for simulation

llINTEGER, inout

number of sites in the system.

OpsTYPE(qtensorlist), inout

Operator alphabet contain all operators to build MPO.

HparamsTYPE(HamiltonianParameters)(*), POINTER, in

Hamiltonian parameters contain coupling etc.

iopINTEGER, in

The index of the identity in the operator list.

Source Code

show / hide f90 code

  subroutine ruleset_to_liou_mpo_qtensorlist_qmpoc(Ham, Rs, ll, Ops, &
                                                          Hparams, iop, errst)
      type(qmpoc), intent(inout) :: Ham
      type(MPORuleSet), intent(in) :: Rs
      integer, intent(in) :: ll
      type(qtensorlist), intent(inout) :: Ops
      type(HamiltonianParameters), pointer, intent(in) :: Hparams(:)
      integer, intent(in) :: iop
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! looping over sites
      integer :: xx

      ! bond dimension for MPO rules / MPO
      integer :: bd, bdff, bdmb, bdmbsl

      !if(present(errst)) errst = 0

      Ham%ti = .true.
      do ii = 1, size(Hparams)
          if(.not. Hparams(ii - 1)%ti) Ham%ti = .false.
      end do

      Ham%ll = ll
      allocate(Ham%Ws(ll))

      ! Preliminary calculations
      ! ------------------------

      ! Count the bond dimension for FF rules and MBString rules
      bdff = 0
      do ii = 1, Rs%nff
          bdff = bdff + Rs%FF(ii)%r_c
      end do

      bdmb = 0
      do ii = 1, Rs%nmb
          bdmb = bdmb + Rs%MB(ii)%n - 1
      end do

      bdmbsl = 0
      do ii = 1, Rs%nmbsl
          bdmbsl = bdmbsl + Rs%Mbsl(ii)%n - 1
      end do

      do ii = 1, Rs%nmbslxy
          bdmbsl = bdmbsl + Rs%Mbslxy(ii)%n - 1
      end do

      ! Bond dimension is bond dimension of two-site operator
      ! (+2 if on-site terms, MBS-Lind needs three times the bond dimension)
      bd = 2 + 2 * (Rs%nbond + Rs%nexp + Rs%nprod + Rs%ntterm + bdff + bdmb) &
           + 3 * bdmbsl + 3 * Rs%nlexp
      if(Rs%pbc) then
          bd = bd + 2 * Rs%nbond
      end if

      ! Set the MPO matrices
      ! --------------------
      !
      ! The order is [local site] [bond] [prod] [exp] [TT] [LindExp] ...
      ! ... [ff] [mbstring] [mbs lind] [identity]

      if(Ham%ti) then
          ! Translation invariant: Set first, bulk, and last + pointers
          ! ...........................................................

          call set_first_lmpo_qtensorlist_qmpoc(Ham%Wl, Rs, Ops, &
                                                       Hparams, bd, 1, iop)
          call fuse(Ham%Wl, errst=errst)
          !if(prop_error('ruleset_to_liou_mpo_qtensorlist'//&
          !              '_qmpoc : fuse (1) failed.', &
          !              errst=errst)) return

          call set_bulk_lmpo_qtensorlist_qmpoc(Ham%Wb, Rs, Ops, &
                                                      Hparams, bd, 2, iop)
          call fuse(Ham%Wb, errst=errst)
          !if(prop_error('ruleset_to_liou_mpo_qtensorlist'//&
          !              '_qmpoc : fuse (2) failed.', &
          !              errst=errst)) return

          call set_last_lmpo_qtensorlist_qmpoc(Ham%Wr, Rs, Ops, &
                                                      Hparams, bd, 3, iop)
          call fuse(Ham%Wr, errst=errst)
          !if(prop_error('ruleset_to_liou_mpo_qtensorlist'//&
          !              '_qmpoc : fuse (3) failed.', &
          !              errst=errst)) return

          call set_timpo_pointers(Ham)
      else
          ! Spatial dependent couplings: set all individual
          ! ...............................................

          call set_first_lmpo_qtensorlist_qmpoc(Ham%Ws(1), Rs, Ops, &
                                                       Hparams, bd, 1, iop)
          call fuse(Ham%Ws(1), errst=errst)
          !if(prop_error('ruleset_to_liou_mpo_qtensorlist'//&
          !              '_qmpoc : fuse (4) failed.', &
          !              errst=errst)) return

          do xx = 2, (ll - 1)
              call set_bulk_lmpo_qtensorlist_qmpoc(Ham%Ws(xx), Rs, Ops, &
                                                          Hparams, bd, xx, iop)
              call fuse(Ham%Ws(xx), errst=errst)
              !if(prop_error('ruleset_to_liou_mpo_qtensorlist'//&
              !              '_qmpoc : fuse (5) failed.', &
              !              errst=errst)) return
          end do

          call set_last_lmpo_qtensorlist_qmpoc(Ham%Ws(ll), Rs, Ops, &
                                                      Hparams, bd, ll, iop)
          call fuse(Ham%Ws(ll), errst=errst)
          !if(prop_error('ruleset_to_liou_mpo_qtensorlist'//&
          !              '_qmpoc : fuse (6) failed.', &
          !              errst=errst)) return
      end if

      ! The Hamiltonian MPO has operator hashed according to the last index.
      ! Zaletel hashes on its own, others not necessary right now as far as
      ! I believe.
      !call set_hash(Ham, [2])

  end subroutine ruleset_to_liou_mpo_qtensorlist_qmpoc

MPOOps_f90.ruleset_to_liou_mpo_qtensorclist_qmpoc()

fortran-subroutine - May 2017 (dj, updated) Construct an MPO from a set of rules, an alphabet of operators, and a set of hamiltonian parameters (obtained from Python frontend). This subroutine is the open quantum system version constructing the Liouville operator.

Arguments

HamTYPE(Fqmpoc), inout

initialized during this subroutine.

RsTYPE(MPORuleSet), inout

Rule set for simulation

llINTEGER, inout

number of sites in the system.

OpsTYPE(qtensorclist), inout

Operator alphabet contain all operators to build MPO.

HparamsTYPE(HamiltonianParameters)(*), POINTER, in

Hamiltonian parameters contain coupling etc.

iopINTEGER, in

The index of the identity in the operator list.

Source Code

show / hide f90 code

  subroutine ruleset_to_liou_mpo_qtensorclist_qmpoc(Ham, Rs, ll, Ops, &
                                                          Hparams, iop, errst)
      type(qmpoc), intent(inout) :: Ham
      type(MPORuleSet), intent(in) :: Rs
      integer, intent(in) :: ll
      type(qtensorclist), intent(inout) :: Ops
      type(HamiltonianParameters), pointer, intent(in) :: Hparams(:)
      integer, intent(in) :: iop
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! looping over sites
      integer :: xx

      ! bond dimension for MPO rules / MPO
      integer :: bd, bdff, bdmb, bdmbsl

      !if(present(errst)) errst = 0

      Ham%ti = .true.
      do ii = 1, size(Hparams)
          if(.not. Hparams(ii - 1)%ti) Ham%ti = .false.
      end do

      Ham%ll = ll
      allocate(Ham%Ws(ll))

      ! Preliminary calculations
      ! ------------------------

      ! Count the bond dimension for FF rules and MBString rules
      bdff = 0
      do ii = 1, Rs%nff
          bdff = bdff + Rs%FF(ii)%r_c
      end do

      bdmb = 0
      do ii = 1, Rs%nmb
          bdmb = bdmb + Rs%MB(ii)%n - 1
      end do

      bdmbsl = 0
      do ii = 1, Rs%nmbsl
          bdmbsl = bdmbsl + Rs%Mbsl(ii)%n - 1
      end do

      do ii = 1, Rs%nmbslxy
          bdmbsl = bdmbsl + Rs%Mbslxy(ii)%n - 1
      end do

      ! Bond dimension is bond dimension of two-site operator
      ! (+2 if on-site terms, MBS-Lind needs three times the bond dimension)
      bd = 2 + 2 * (Rs%nbond + Rs%nexp + Rs%nprod + Rs%ntterm + bdff + bdmb) &
           + 3 * bdmbsl + 3 * Rs%nlexp
      if(Rs%pbc) then
          bd = bd + 2 * Rs%nbond
      end if

      ! Set the MPO matrices
      ! --------------------
      !
      ! The order is [local site] [bond] [prod] [exp] [TT] [LindExp] ...
      ! ... [ff] [mbstring] [mbs lind] [identity]

      if(Ham%ti) then
          ! Translation invariant: Set first, bulk, and last + pointers
          ! ...........................................................

          call set_first_lmpo_qtensorclist_qmpoc(Ham%Wl, Rs, Ops, &
                                                       Hparams, bd, 1, iop)
          call fuse(Ham%Wl, errst=errst)
          !if(prop_error('ruleset_to_liou_mpo_qtensorclist'//&
          !              '_qmpoc : fuse (1) failed.', &
          !              errst=errst)) return

          call set_bulk_lmpo_qtensorclist_qmpoc(Ham%Wb, Rs, Ops, &
                                                      Hparams, bd, 2, iop)
          call fuse(Ham%Wb, errst=errst)
          !if(prop_error('ruleset_to_liou_mpo_qtensorclist'//&
          !              '_qmpoc : fuse (2) failed.', &
          !              errst=errst)) return

          call set_last_lmpo_qtensorclist_qmpoc(Ham%Wr, Rs, Ops, &
                                                      Hparams, bd, 3, iop)
          call fuse(Ham%Wr, errst=errst)
          !if(prop_error('ruleset_to_liou_mpo_qtensorclist'//&
          !              '_qmpoc : fuse (3) failed.', &
          !              errst=errst)) return

          call set_timpo_pointers(Ham)
      else
          ! Spatial dependent couplings: set all individual
          ! ...............................................

          call set_first_lmpo_qtensorclist_qmpoc(Ham%Ws(1), Rs, Ops, &
                                                       Hparams, bd, 1, iop)
          call fuse(Ham%Ws(1), errst=errst)
          !if(prop_error('ruleset_to_liou_mpo_qtensorclist'//&
          !              '_qmpoc : fuse (4) failed.', &
          !              errst=errst)) return

          do xx = 2, (ll - 1)
              call set_bulk_lmpo_qtensorclist_qmpoc(Ham%Ws(xx), Rs, Ops, &
                                                          Hparams, bd, xx, iop)
              call fuse(Ham%Ws(xx), errst=errst)
              !if(prop_error('ruleset_to_liou_mpo_qtensorclist'//&
              !              '_qmpoc : fuse (5) failed.', &
              !              errst=errst)) return
          end do

          call set_last_lmpo_qtensorclist_qmpoc(Ham%Ws(ll), Rs, Ops, &
                                                      Hparams, bd, ll, iop)
          call fuse(Ham%Ws(ll), errst=errst)
          !if(prop_error('ruleset_to_liou_mpo_qtensorclist'//&
          !              '_qmpoc : fuse (6) failed.', &
          !              errst=errst)) return
      end if

      ! The Hamiltonian MPO has operator hashed according to the last index.
      ! Zaletel hashes on its own, others not necessary right now as far as
      ! I believe.
      !call set_hash(Ham, [2])

  end subroutine ruleset_to_liou_mpo_qtensorclist_qmpoc

MPOOps_f90.ruleset_to_clliou_mpo_tensorlist_mpo()

fortran-subroutine - May 2017 (dj, updated) Construct an MPO from a set of rules, an alphabet of operators, and a set of hamiltonian parameters (obtained from Python frontend). This subroutine is the open quantum system version constructing the Liouville operator.

Arguments

HamTYPE(Fmpo), inout

initialized during this subroutine.

RsTYPE(MPORuleSet), inout

Rule set for simulation

llINTEGER, inout

number of sites in the system.

OpsTYPE(tensorlist), inout

Operator alphabet contain all operators to build MPO.

HparamsTYPE(HamiltonianParameters)(*), POINTER, in

Hamiltonian parameters contain coupling etc.

iopINTEGER, in

The index of the identity in the operator list.

Source Code

show / hide f90 code

  subroutine ruleset_to_clliou_mpo_tensorlist_mpo(Ham, Rs, ll, Ops, &
                                                            Hparams, iop, errst)
      type(mpo), intent(inout) :: Ham
      type(MPORuleSet), intent(in) :: Rs
      integer, intent(in) :: ll
      type(tensorlist), intent(in) :: Ops
      type(HamiltonianParameters), pointer, intent(in) :: Hparams(:)
      integer, intent(in) :: iop
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! looping over sites
      integer :: xx

      ! bond dimension for MPO rules / MPO
      integer :: bd, bdff, bdmb

      !if(present(errst)) errst = 0

      Ham%ti = .true.
      do ii = 1, size(Hparams)
          if(.not. Hparams(ii - 1)%ti) Ham%ti = .false.
      end do

      Ham%ll = ll
      allocate(Ham%Ws(ll))

      ! Preliminary calculations
      ! ------------------------

      ! Count the bond dimension for FF rules and MBString rules
      bdff = 0
      do ii = 1, Rs%nff
          bdff = bdff + Rs%FF(ii)%r_c
      end do

      bdmb = 0
      do ii = 1, Rs%nmb
          bdmb = bdmb + Rs%MB(ii)%n - 1
      end do

      ! Bond dimension is bond dimension of two-site operator
      ! (+2 if on-site terms, MBS-Lind needs three times the bond dimension)
      bd = 2 + 2 * (Rs%nbond + Rs%nexp + Rs%nprod + Rs%ntterm + bdff + bdmb)
      if(Rs%pbc) then
          bd = bd + 2 * Rs%nbond
      end if

      ! Set the MPO matrices
      ! --------------------
      !
      ! The order is [local site] [bond] [prod] [exp] [TT] [LindExp] ...
      ! ... [ff] [mbstring] [mbs lind] [identity]

      if(Ham%ti) then
          ! Translation invariant: Set first, bulk, and last + pointers
          ! ...........................................................

          call set_first_cllmpo_tensorlist_mpo(Ham%Wl, Rs, Ops, &
                                                       Hparams, bd, 1, iop)
          call fuse(Ham%Wl, errst=errst)
          !if(prop_error('ruleset_to_liou_mpo_tensorlist'//&
          !              '_mpo : fuse (1) failed.', &
          !              errst=errst)) return

          call set_bulk_cllmpo_tensorlist_mpo(Ham%Wb, Rs, Ops, &
                                                      Hparams, bd, 2, iop)
          call fuse(Ham%Wb, errst=errst)
          !if(prop_error('ruleset_to_liou_mpo_tensorlist'//&
          !              '_mpo : fuse (2) failed.', &
          !              errst=errst)) return

          call set_last_cllmpo_tensorlist_mpo(Ham%Wr, Rs, Ops, &
                                                      Hparams, bd, 3, iop)
          call fuse(Ham%Wr, errst=errst)
          !if(prop_error('ruleset_to_liou_mpo_tensorlist'//&
          !              '_mpo : fuse (3) failed.', &
          !              errst=errst)) return

          call set_timpo_pointers(Ham)
      else
          ! Spatial dependent couplings: set all individual
          ! ...............................................

          call set_first_cllmpo_tensorlist_mpo(Ham%Ws(1), Rs, Ops, &
                                                       Hparams, bd, 1, iop)
          call fuse(Ham%Ws(1), errst=errst)
          !if(prop_error('ruleset_to_liou_mpo_tensorlist'//&
          !              '_mpo : fuse (4) failed.', &
          !              errst=errst)) return

          do xx = 2, (ll - 1)
              call set_bulk_cllmpo_tensorlist_mpo(Ham%Ws(xx), Rs, Ops, &
                                                          Hparams, bd, xx, iop)
              call fuse(Ham%Ws(xx), errst=errst)
              !if(prop_error('ruleset_to_liou_mpo_tensorlist'//&
              !              '_mpo : fuse (5) failed.', &
              !              errst=errst)) return
          end do

          call set_last_cllmpo_tensorlist_mpo(Ham%Ws(ll), Rs, Ops, &
                                                      Hparams, bd, ll, iop)
          call fuse(Ham%Ws(ll), errst=errst)
          !if(prop_error('ruleset_to_liou_mpo_tensorlist'//&
          !              '_mpo : fuse (6) failed.', &
          !              errst=errst)) return
      end if

      ! The Hamiltonian MPO has operator hashed according to the last index.
      ! Zaletel hashes on its own, others not necessary right now as far as
      ! I believe.
      !call set_hash(Ham, [2])

  end subroutine ruleset_to_clliou_mpo_tensorlist_mpo

MPOOps_f90.ruleset_to_clliou_mpo_tensorlistc_mpoc()

fortran-subroutine - May 2017 (dj, updated) Construct an MPO from a set of rules, an alphabet of operators, and a set of hamiltonian parameters (obtained from Python frontend). This subroutine is the open quantum system version constructing the Liouville operator.

Arguments

HamTYPE(Fmpoc), inout

initialized during this subroutine.

RsTYPE(MPORuleSet), inout

Rule set for simulation

llINTEGER, inout

number of sites in the system.

OpsTYPE(tensorlistc), inout

Operator alphabet contain all operators to build MPO.

HparamsTYPE(HamiltonianParameters)(*), POINTER, in

Hamiltonian parameters contain coupling etc.

iopINTEGER, in

The index of the identity in the operator list.

Source Code

show / hide f90 code

  subroutine ruleset_to_clliou_mpo_tensorlistc_mpoc(Ham, Rs, ll, Ops, &
                                                            Hparams, iop, errst)
      type(mpoc), intent(inout) :: Ham
      type(MPORuleSet), intent(in) :: Rs
      integer, intent(in) :: ll
      type(tensorlistc), intent(in) :: Ops
      type(HamiltonianParameters), pointer, intent(in) :: Hparams(:)
      integer, intent(in) :: iop
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! looping over sites
      integer :: xx

      ! bond dimension for MPO rules / MPO
      integer :: bd, bdff, bdmb

      !if(present(errst)) errst = 0

      Ham%ti = .true.
      do ii = 1, size(Hparams)
          if(.not. Hparams(ii - 1)%ti) Ham%ti = .false.
      end do

      Ham%ll = ll
      allocate(Ham%Ws(ll))

      ! Preliminary calculations
      ! ------------------------

      ! Count the bond dimension for FF rules and MBString rules
      bdff = 0
      do ii = 1, Rs%nff
          bdff = bdff + Rs%FF(ii)%r_c
      end do

      bdmb = 0
      do ii = 1, Rs%nmb
          bdmb = bdmb + Rs%MB(ii)%n - 1
      end do

      ! Bond dimension is bond dimension of two-site operator
      ! (+2 if on-site terms, MBS-Lind needs three times the bond dimension)
      bd = 2 + 2 * (Rs%nbond + Rs%nexp + Rs%nprod + Rs%ntterm + bdff + bdmb)
      if(Rs%pbc) then
          bd = bd + 2 * Rs%nbond
      end if

      ! Set the MPO matrices
      ! --------------------
      !
      ! The order is [local site] [bond] [prod] [exp] [TT] [LindExp] ...
      ! ... [ff] [mbstring] [mbs lind] [identity]

      if(Ham%ti) then
          ! Translation invariant: Set first, bulk, and last + pointers
          ! ...........................................................

          call set_first_cllmpo_tensorlistc_mpoc(Ham%Wl, Rs, Ops, &
                                                       Hparams, bd, 1, iop)
          call fuse(Ham%Wl, errst=errst)
          !if(prop_error('ruleset_to_liou_mpo_tensorlistc'//&
          !              '_mpoc : fuse (1) failed.', &
          !              errst=errst)) return

          call set_bulk_cllmpo_tensorlistc_mpoc(Ham%Wb, Rs, Ops, &
                                                      Hparams, bd, 2, iop)
          call fuse(Ham%Wb, errst=errst)
          !if(prop_error('ruleset_to_liou_mpo_tensorlistc'//&
          !              '_mpoc : fuse (2) failed.', &
          !              errst=errst)) return

          call set_last_cllmpo_tensorlistc_mpoc(Ham%Wr, Rs, Ops, &
                                                      Hparams, bd, 3, iop)
          call fuse(Ham%Wr, errst=errst)
          !if(prop_error('ruleset_to_liou_mpo_tensorlistc'//&
          !              '_mpoc : fuse (3) failed.', &
          !              errst=errst)) return

          call set_timpo_pointers(Ham)
      else
          ! Spatial dependent couplings: set all individual
          ! ...............................................

          call set_first_cllmpo_tensorlistc_mpoc(Ham%Ws(1), Rs, Ops, &
                                                       Hparams, bd, 1, iop)
          call fuse(Ham%Ws(1), errst=errst)
          !if(prop_error('ruleset_to_liou_mpo_tensorlistc'//&
          !              '_mpoc : fuse (4) failed.', &
          !              errst=errst)) return

          do xx = 2, (ll - 1)
              call set_bulk_cllmpo_tensorlistc_mpoc(Ham%Ws(xx), Rs, Ops, &
                                                          Hparams, bd, xx, iop)
              call fuse(Ham%Ws(xx), errst=errst)
              !if(prop_error('ruleset_to_liou_mpo_tensorlistc'//&
              !              '_mpoc : fuse (5) failed.', &
              !              errst=errst)) return
          end do

          call set_last_cllmpo_tensorlistc_mpoc(Ham%Ws(ll), Rs, Ops, &
                                                      Hparams, bd, ll, iop)
          call fuse(Ham%Ws(ll), errst=errst)
          !if(prop_error('ruleset_to_liou_mpo_tensorlistc'//&
          !              '_mpoc : fuse (6) failed.', &
          !              errst=errst)) return
      end if

      ! The Hamiltonian MPO has operator hashed according to the last index.
      ! Zaletel hashes on its own, others not necessary right now as far as
      ! I believe.
      !call set_hash(Ham, [2])

  end subroutine ruleset_to_clliou_mpo_tensorlistc_mpoc

MPOOps_f90.ruleset_to_clliou_mpo_qtensorlist_qmpo()

fortran-subroutine - May 2017 (dj, updated) Construct an MPO from a set of rules, an alphabet of operators, and a set of hamiltonian parameters (obtained from Python frontend). This subroutine is the open quantum system version constructing the Liouville operator.

Arguments

HamTYPE(Fqmpo), inout

initialized during this subroutine.

RsTYPE(MPORuleSet), inout

Rule set for simulation

llINTEGER, inout

number of sites in the system.

OpsTYPE(qtensorlist), inout

Operator alphabet contain all operators to build MPO.

HparamsTYPE(HamiltonianParameters)(*), POINTER, in

Hamiltonian parameters contain coupling etc.

iopINTEGER, in

The index of the identity in the operator list.

Source Code

show / hide f90 code

  subroutine ruleset_to_clliou_mpo_qtensorlist_qmpo(Ham, Rs, ll, Ops, &
                                                            Hparams, iop, errst)
      type(qmpo), intent(inout) :: Ham
      type(MPORuleSet), intent(in) :: Rs
      integer, intent(in) :: ll
      type(qtensorlist), intent(in) :: Ops
      type(HamiltonianParameters), pointer, intent(in) :: Hparams(:)
      integer, intent(in) :: iop
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! looping over sites
      integer :: xx

      ! bond dimension for MPO rules / MPO
      integer :: bd, bdff, bdmb

      !if(present(errst)) errst = 0

      Ham%ti = .true.
      do ii = 1, size(Hparams)
          if(.not. Hparams(ii - 1)%ti) Ham%ti = .false.
      end do

      Ham%ll = ll
      allocate(Ham%Ws(ll))

      ! Preliminary calculations
      ! ------------------------

      ! Count the bond dimension for FF rules and MBString rules
      bdff = 0
      do ii = 1, Rs%nff
          bdff = bdff + Rs%FF(ii)%r_c
      end do

      bdmb = 0
      do ii = 1, Rs%nmb
          bdmb = bdmb + Rs%MB(ii)%n - 1
      end do

      ! Bond dimension is bond dimension of two-site operator
      ! (+2 if on-site terms, MBS-Lind needs three times the bond dimension)
      bd = 2 + 2 * (Rs%nbond + Rs%nexp + Rs%nprod + Rs%ntterm + bdff + bdmb)
      if(Rs%pbc) then
          bd = bd + 2 * Rs%nbond
      end if

      ! Set the MPO matrices
      ! --------------------
      !
      ! The order is [local site] [bond] [prod] [exp] [TT] [LindExp] ...
      ! ... [ff] [mbstring] [mbs lind] [identity]

      if(Ham%ti) then
          ! Translation invariant: Set first, bulk, and last + pointers
          ! ...........................................................

          call set_first_cllmpo_qtensorlist_qmpo(Ham%Wl, Rs, Ops, &
                                                       Hparams, bd, 1, iop)
          call fuse(Ham%Wl, errst=errst)
          !if(prop_error('ruleset_to_liou_mpo_qtensorlist'//&
          !              '_qmpo : fuse (1) failed.', &
          !              errst=errst)) return

          call set_bulk_cllmpo_qtensorlist_qmpo(Ham%Wb, Rs, Ops, &
                                                      Hparams, bd, 2, iop)
          call fuse(Ham%Wb, errst=errst)
          !if(prop_error('ruleset_to_liou_mpo_qtensorlist'//&
          !              '_qmpo : fuse (2) failed.', &
          !              errst=errst)) return

          call set_last_cllmpo_qtensorlist_qmpo(Ham%Wr, Rs, Ops, &
                                                      Hparams, bd, 3, iop)
          call fuse(Ham%Wr, errst=errst)
          !if(prop_error('ruleset_to_liou_mpo_qtensorlist'//&
          !              '_qmpo : fuse (3) failed.', &
          !              errst=errst)) return

          call set_timpo_pointers(Ham)
      else
          ! Spatial dependent couplings: set all individual
          ! ...............................................

          call set_first_cllmpo_qtensorlist_qmpo(Ham%Ws(1), Rs, Ops, &
                                                       Hparams, bd, 1, iop)
          call fuse(Ham%Ws(1), errst=errst)
          !if(prop_error('ruleset_to_liou_mpo_qtensorlist'//&
          !              '_qmpo : fuse (4) failed.', &
          !              errst=errst)) return

          do xx = 2, (ll - 1)
              call set_bulk_cllmpo_qtensorlist_qmpo(Ham%Ws(xx), Rs, Ops, &
                                                          Hparams, bd, xx, iop)
              call fuse(Ham%Ws(xx), errst=errst)
              !if(prop_error('ruleset_to_liou_mpo_qtensorlist'//&
              !              '_qmpo : fuse (5) failed.', &
              !              errst=errst)) return
          end do

          call set_last_cllmpo_qtensorlist_qmpo(Ham%Ws(ll), Rs, Ops, &
                                                      Hparams, bd, ll, iop)
          call fuse(Ham%Ws(ll), errst=errst)
          !if(prop_error('ruleset_to_liou_mpo_qtensorlist'//&
          !              '_qmpo : fuse (6) failed.', &
          !              errst=errst)) return
      end if

      ! The Hamiltonian MPO has operator hashed according to the last index.
      ! Zaletel hashes on its own, others not necessary right now as far as
      ! I believe.
      !call set_hash(Ham, [2])

  end subroutine ruleset_to_clliou_mpo_qtensorlist_qmpo

MPOOps_f90.ruleset_to_clliou_mpo_qtensorclist_qmpoc()

fortran-subroutine - May 2017 (dj, updated) Construct an MPO from a set of rules, an alphabet of operators, and a set of hamiltonian parameters (obtained from Python frontend). This subroutine is the open quantum system version constructing the Liouville operator.

Arguments

HamTYPE(Fqmpoc), inout

initialized during this subroutine.

RsTYPE(MPORuleSet), inout

Rule set for simulation

llINTEGER, inout

number of sites in the system.

OpsTYPE(qtensorclist), inout

Operator alphabet contain all operators to build MPO.

HparamsTYPE(HamiltonianParameters)(*), POINTER, in

Hamiltonian parameters contain coupling etc.

iopINTEGER, in

The index of the identity in the operator list.

Source Code

show / hide f90 code

  subroutine ruleset_to_clliou_mpo_qtensorclist_qmpoc(Ham, Rs, ll, Ops, &
                                                            Hparams, iop, errst)
      type(qmpoc), intent(inout) :: Ham
      type(MPORuleSet), intent(in) :: Rs
      integer, intent(in) :: ll
      type(qtensorclist), intent(in) :: Ops
      type(HamiltonianParameters), pointer, intent(in) :: Hparams(:)
      integer, intent(in) :: iop
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! looping over sites
      integer :: xx

      ! bond dimension for MPO rules / MPO
      integer :: bd, bdff, bdmb

      !if(present(errst)) errst = 0

      Ham%ti = .true.
      do ii = 1, size(Hparams)
          if(.not. Hparams(ii - 1)%ti) Ham%ti = .false.
      end do

      Ham%ll = ll
      allocate(Ham%Ws(ll))

      ! Preliminary calculations
      ! ------------------------

      ! Count the bond dimension for FF rules and MBString rules
      bdff = 0
      do ii = 1, Rs%nff
          bdff = bdff + Rs%FF(ii)%r_c
      end do

      bdmb = 0
      do ii = 1, Rs%nmb
          bdmb = bdmb + Rs%MB(ii)%n - 1
      end do

      ! Bond dimension is bond dimension of two-site operator
      ! (+2 if on-site terms, MBS-Lind needs three times the bond dimension)
      bd = 2 + 2 * (Rs%nbond + Rs%nexp + Rs%nprod + Rs%ntterm + bdff + bdmb)
      if(Rs%pbc) then
          bd = bd + 2 * Rs%nbond
      end if

      ! Set the MPO matrices
      ! --------------------
      !
      ! The order is [local site] [bond] [prod] [exp] [TT] [LindExp] ...
      ! ... [ff] [mbstring] [mbs lind] [identity]

      if(Ham%ti) then
          ! Translation invariant: Set first, bulk, and last + pointers
          ! ...........................................................

          call set_first_cllmpo_qtensorclist_qmpoc(Ham%Wl, Rs, Ops, &
                                                       Hparams, bd, 1, iop)
          call fuse(Ham%Wl, errst=errst)
          !if(prop_error('ruleset_to_liou_mpo_qtensorclist'//&
          !              '_qmpoc : fuse (1) failed.', &
          !              errst=errst)) return

          call set_bulk_cllmpo_qtensorclist_qmpoc(Ham%Wb, Rs, Ops, &
                                                      Hparams, bd, 2, iop)
          call fuse(Ham%Wb, errst=errst)
          !if(prop_error('ruleset_to_liou_mpo_qtensorclist'//&
          !              '_qmpoc : fuse (2) failed.', &
          !              errst=errst)) return

          call set_last_cllmpo_qtensorclist_qmpoc(Ham%Wr, Rs, Ops, &
                                                      Hparams, bd, 3, iop)
          call fuse(Ham%Wr, errst=errst)
          !if(prop_error('ruleset_to_liou_mpo_qtensorclist'//&
          !              '_qmpoc : fuse (3) failed.', &
          !              errst=errst)) return

          call set_timpo_pointers(Ham)
      else
          ! Spatial dependent couplings: set all individual
          ! ...............................................

          call set_first_cllmpo_qtensorclist_qmpoc(Ham%Ws(1), Rs, Ops, &
                                                       Hparams, bd, 1, iop)
          call fuse(Ham%Ws(1), errst=errst)
          !if(prop_error('ruleset_to_liou_mpo_qtensorclist'//&
          !              '_qmpoc : fuse (4) failed.', &
          !              errst=errst)) return

          do xx = 2, (ll - 1)
              call set_bulk_cllmpo_qtensorclist_qmpoc(Ham%Ws(xx), Rs, Ops, &
                                                          Hparams, bd, xx, iop)
              call fuse(Ham%Ws(xx), errst=errst)
              !if(prop_error('ruleset_to_liou_mpo_qtensorclist'//&
              !              '_qmpoc : fuse (5) failed.', &
              !              errst=errst)) return
          end do

          call set_last_cllmpo_qtensorclist_qmpoc(Ham%Ws(ll), Rs, Ops, &
                                                      Hparams, bd, ll, iop)
          call fuse(Ham%Ws(ll), errst=errst)
          !if(prop_error('ruleset_to_liou_mpo_qtensorclist'//&
          !              '_qmpoc : fuse (6) failed.', &
          !              errst=errst)) return
      end if

      ! The Hamiltonian MPO has operator hashed according to the last index.
      ! Zaletel hashes on its own, others not necessary right now as far as
      ! I believe.
      !call set_hash(Ham, [2])

  end subroutine ruleset_to_clliou_mpo_qtensorclist_qmpoc

MPOOps_f90.contractmpol_tensor_tensor()

fortran-subroutine - October 2017 (dj, updated) Do . The l stands for left-moving.

Arguments

ToutTYPE(tensor), inout

On exit, transfer matrix for one index in the row bond dimension of the MPO.

kkINTEGER, inout

The index of the row bond dimension in the MPO.

MatTYPE(tensor), inout

Matrix representing the MPO on the specific site.

TinTYPE(tensor), POINTER, inout

??

Details

Contract the MPO matrix M_{(k,a),b,c} with the tensor-array T_{(a),i,b,j} to a tensor T_{c,i,j}. This version works for single site and two-site MPO depending on the rank of the MPO matrix.

Source Code

show / hide f90 code

  subroutine contractmpol_tensor_tensor(Tout, kk, Mat, Tin, errst)
      type(tensor) :: Tout
      integer, intent(in) :: kk
      type(sr_matrix_tensor) :: Mat
      type(tensor), dimension(:) :: Tin
      integer, intent(out), optional :: errst

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

      ! for looping
      integer ::  ii

      ! Index in sparse row
      integer :: idx

      ! Rank of tensor in MPO matrix
      integer :: rnk

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

      ! temporary tensor
      !type(tensor) :: Tmp

      ! First one is initialization
      beta = dzero
      rnk = rank(Mat%Row(1)%Op(1))

      do ii = 1, Mat%Row(kk)%numel
          idx = Mat%Row(kk)%ind(ii)

          !call copy(Tmp, Tin(idx))
          if(rnk == 2) then
              call mcontr(Tout, Tin(idx), Mat%Row(kk)%Op(ii), [2], [2], &
                          beta=beta, errst=errst)
              !if(prop_error('contractmpol_tensor_tensor: '//&
              !              'mcontr (1) failed.', 'MPOOps_include.f90:9062', &
              !              errst=errst)) return

              !call contr(Tout, Mat%Row(kk)%Op(ii), Tmp, [2], [2], &
              !           beta=beta, errst=errst)
              !!if(prop_error('contractmpol_tensor_tensor: '//&
              !!              'contr (1) failed.', errst=errst)) return

          elseif(rnk == 4) then
              call mcontr(Tout, Tin(idx), Mat%Row(kk)%Op(ii), [2, 3], [3, 4], &
                          beta=beta, errst=errst)
              !if(prop_error('contractmpol_tensor_tensor: '//&
              !              'mcontr (2) failed.', 'MPOOps_include.f90:9074', &
              !              errst=errst)) return

              !call contr(Tout, Mat%Row(kk)%Op(ii), Tmp, [3, 4], [2, 3], &
              !           beta=beta, errst=errst)
              !!if(prop_error('contractmpol_tensor_tensor: '//&
              !!              'contr (2) failed.', errst=errst)) return

          else
              errst = raise_error('contractmpol_tensor_tensor: '//&
                                  'bad rank.', 99, 'MPOOps_include.f90:9084', errst=errst)
          end if
          !call destroy(Tmp)

          ! Set operation to addition
          beta = done
      end do

  end subroutine contractmpol_tensor_tensor

MPOOps_f90.contractmpol_tensor_tensorc()

fortran-subroutine - October 2017 (dj, updated) Do . The l stands for left-moving.

Arguments

ToutTYPE(tensorc), inout

On exit, transfer matrix for one index in the row bond dimension of the MPO.

kkINTEGER, inout

The index of the row bond dimension in the MPO.

MatTYPE(tensor), inout

Matrix representing the MPO on the specific site.

TinTYPE(tensorc), POINTER, inout

??

Details

Contract the MPO matrix M_{(k,a),b,c} with the tensor-array T_{(a),i,b,j} to a tensor T_{c,i,j}. This version works for single site and two-site MPO depending on the rank of the MPO matrix.

Source Code

show / hide f90 code

  subroutine contractmpol_tensor_tensorc(Tout, kk, Mat, Tin, errst)
      type(tensorc) :: Tout
      integer, intent(in) :: kk
      type(sr_matrix_tensor) :: Mat
      type(tensorc), dimension(:) :: Tin
      integer, intent(out), optional :: errst

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

      ! for looping
      integer ::  ii

      ! Index in sparse row
      integer :: idx

      ! Rank of tensor in MPO matrix
      integer :: rnk

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

      ! temporary tensor
      !type(tensorc) :: Tmp

      ! First one is initialization
      beta = zzero
      rnk = rank(Mat%Row(1)%Op(1))

      do ii = 1, Mat%Row(kk)%numel
          idx = Mat%Row(kk)%ind(ii)

          !call copy(Tmp, Tin(idx))
          if(rnk == 2) then
              call mcontr(Tout, Tin(idx), Mat%Row(kk)%Op(ii), [2], [2], &
                          beta=beta, errst=errst)
              !if(prop_error('contractmpol_tensor_tensorc: '//&
              !              'mcontr (1) failed.', 'MPOOps_include.f90:9062', &
              !              errst=errst)) return

              !call contr(Tout, Mat%Row(kk)%Op(ii), Tmp, [2], [2], &
              !           beta=beta, errst=errst)
              !!if(prop_error('contractmpol_tensor_tensorc: '//&
              !!              'contr (1) failed.', errst=errst)) return

          elseif(rnk == 4) then
              call mcontr(Tout, Tin(idx), Mat%Row(kk)%Op(ii), [2, 3], [3, 4], &
                          beta=beta, errst=errst)
              !if(prop_error('contractmpol_tensor_tensorc: '//&
              !              'mcontr (2) failed.', 'MPOOps_include.f90:9074', &
              !              errst=errst)) return

              !call contr(Tout, Mat%Row(kk)%Op(ii), Tmp, [3, 4], [2, 3], &
              !           beta=beta, errst=errst)
              !!if(prop_error('contractmpol_tensor_tensorc: '//&
              !!              'contr (2) failed.', errst=errst)) return

          else
              errst = raise_error('contractmpol_tensor_tensorc: '//&
                                  'bad rank.', 99, 'MPOOps_include.f90:9084', errst=errst)
          end if
          !call destroy(Tmp)

          ! Set operation to addition
          beta = zone
      end do

  end subroutine contractmpol_tensor_tensorc

MPOOps_f90.contractmpol_tensorc_tensorc()

fortran-subroutine - October 2017 (dj, updated) Do . The l stands for left-moving.

Arguments

ToutTYPE(tensorc), inout

On exit, transfer matrix for one index in the row bond dimension of the MPO.

kkINTEGER, inout

The index of the row bond dimension in the MPO.

MatTYPE(tensorc), inout

Matrix representing the MPO on the specific site.

TinTYPE(tensorc), POINTER, inout

??

Details

Contract the MPO matrix M_{(k,a),b,c} with the tensor-array T_{(a),i,b,j} to a tensor T_{c,i,j}. This version works for single site and two-site MPO depending on the rank of the MPO matrix.

Source Code

show / hide f90 code

  subroutine contractmpol_tensorc_tensorc(Tout, kk, Mat, Tin, errst)
      type(tensorc) :: Tout
      integer, intent(in) :: kk
      type(sr_matrix_tensorc) :: Mat
      type(tensorc), dimension(:) :: Tin
      integer, intent(out), optional :: errst

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

      ! for looping
      integer ::  ii

      ! Index in sparse row
      integer :: idx

      ! Rank of tensor in MPO matrix
      integer :: rnk

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

      ! temporary tensor
      !type(tensorc) :: Tmp

      ! First one is initialization
      beta = zzero
      rnk = rank(Mat%Row(1)%Op(1))

      do ii = 1, Mat%Row(kk)%numel
          idx = Mat%Row(kk)%ind(ii)

          !call copy(Tmp, Tin(idx))
          if(rnk == 2) then
              call mcontr(Tout, Tin(idx), Mat%Row(kk)%Op(ii), [2], [2], &
                          beta=beta, errst=errst)
              !if(prop_error('contractmpol_tensorc_tensorc: '//&
              !              'mcontr (1) failed.', 'MPOOps_include.f90:9062', &
              !              errst=errst)) return

              !call contr(Tout, Mat%Row(kk)%Op(ii), Tmp, [2], [2], &
              !           beta=beta, errst=errst)
              !!if(prop_error('contractmpol_tensorc_tensorc: '//&
              !!              'contr (1) failed.', errst=errst)) return

          elseif(rnk == 4) then
              call mcontr(Tout, Tin(idx), Mat%Row(kk)%Op(ii), [2, 3], [3, 4], &
                          beta=beta, errst=errst)
              !if(prop_error('contractmpol_tensorc_tensorc: '//&
              !              'mcontr (2) failed.', 'MPOOps_include.f90:9074', &
              !              errst=errst)) return

              !call contr(Tout, Mat%Row(kk)%Op(ii), Tmp, [3, 4], [2, 3], &
              !           beta=beta, errst=errst)
              !!if(prop_error('contractmpol_tensorc_tensorc: '//&
              !!              'contr (2) failed.', errst=errst)) return

          else
              errst = raise_error('contractmpol_tensorc_tensorc: '//&
                                  'bad rank.', 99, 'MPOOps_include.f90:9084', errst=errst)
          end if
          !call destroy(Tmp)

          ! Set operation to addition
          beta = zone
      end do

  end subroutine contractmpol_tensorc_tensorc

MPOOps_f90.contractmpol_qtensor_qtensor()

fortran-subroutine - October 2017 (dj, updated) Do . The l stands for left-moving.

Arguments

ToutTYPE(qtensor), inout

On exit, transfer matrix for one index in the row bond dimension of the MPO.

kkINTEGER, inout

The index of the row bond dimension in the MPO.

MatTYPE(qtensor), inout

Matrix representing the MPO on the specific site.

TinTYPE(qtensor), POINTER, inout

??

Details

Contract the MPO matrix M_{(k,a),b,c} with the tensor-array T_{(a),i,b,j} to a tensor T_{c,i,j}. This version works for single site and two-site MPO depending on the rank of the MPO matrix.

Source Code

show / hide f90 code

  subroutine contractmpol_qtensor_qtensor(Tout, kk, Mat, Tin, errst)
      type(qtensor) :: Tout
      integer, intent(in) :: kk
      type(sr_matrix_qtensor) :: Mat
      type(qtensor), dimension(:) :: Tin
      integer, intent(out), optional :: errst

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

      ! for looping
      integer ::  ii

      ! Index in sparse row
      integer :: idx

      ! Rank of tensor in MPO matrix
      integer :: rnk

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

      ! temporary tensor
      !type(qtensor) :: Tmp

      ! First one is initialization
      beta = dzero
      rnk = rank(Mat%Row(1)%Op(1))

      do ii = 1, Mat%Row(kk)%numel
          idx = Mat%Row(kk)%ind(ii)

          !call copy(Tmp, Tin(idx))
          if(rnk == 2) then
              call mcontr(Tout, Tin(idx), Mat%Row(kk)%Op(ii), [2], [2], &
                          beta=beta, errst=errst)
              !if(prop_error('contractmpol_qtensor_qtensor: '//&
              !              'mcontr (1) failed.', 'MPOOps_include.f90:9062', &
              !              errst=errst)) return

              !call contr(Tout, Mat%Row(kk)%Op(ii), Tmp, [2], [2], &
              !           beta=beta, errst=errst)
              !!if(prop_error('contractmpol_qtensor_qtensor: '//&
              !!              'contr (1) failed.', errst=errst)) return

          elseif(rnk == 4) then
              call mcontr(Tout, Tin(idx), Mat%Row(kk)%Op(ii), [2, 3], [3, 4], &
                          beta=beta, errst=errst)
              !if(prop_error('contractmpol_qtensor_qtensor: '//&
              !              'mcontr (2) failed.', 'MPOOps_include.f90:9074', &
              !              errst=errst)) return

              !call contr(Tout, Mat%Row(kk)%Op(ii), Tmp, [3, 4], [2, 3], &
              !           beta=beta, errst=errst)
              !!if(prop_error('contractmpol_qtensor_qtensor: '//&
              !!              'contr (2) failed.', errst=errst)) return

          else
              errst = raise_error('contractmpol_qtensor_qtensor: '//&
                                  'bad rank.', 99, 'MPOOps_include.f90:9084', errst=errst)
          end if
          !call destroy(Tmp)

          ! Set operation to addition
          beta = done
      end do

  end subroutine contractmpol_qtensor_qtensor

MPOOps_f90.contractmpol_qtensor_qtensorc()

fortran-subroutine - October 2017 (dj, updated) Do . The l stands for left-moving.

Arguments

ToutTYPE(qtensorc), inout

On exit, transfer matrix for one index in the row bond dimension of the MPO.

kkINTEGER, inout

The index of the row bond dimension in the MPO.

MatTYPE(qtensor), inout

Matrix representing the MPO on the specific site.

TinTYPE(qtensorc), POINTER, inout

??

Details

Contract the MPO matrix M_{(k,a),b,c} with the tensor-array T_{(a),i,b,j} to a tensor T_{c,i,j}. This version works for single site and two-site MPO depending on the rank of the MPO matrix.

Source Code

show / hide f90 code

  subroutine contractmpol_qtensor_qtensorc(Tout, kk, Mat, Tin, errst)
      type(qtensorc) :: Tout
      integer, intent(in) :: kk
      type(sr_matrix_qtensor) :: Mat
      type(qtensorc), dimension(:) :: Tin
      integer, intent(out), optional :: errst

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

      ! for looping
      integer ::  ii

      ! Index in sparse row
      integer :: idx

      ! Rank of tensor in MPO matrix
      integer :: rnk

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

      ! temporary tensor
      !type(qtensorc) :: Tmp

      ! First one is initialization
      beta = zzero
      rnk = rank(Mat%Row(1)%Op(1))

      do ii = 1, Mat%Row(kk)%numel
          idx = Mat%Row(kk)%ind(ii)

          !call copy(Tmp, Tin(idx))
          if(rnk == 2) then
              call mcontr(Tout, Tin(idx), Mat%Row(kk)%Op(ii), [2], [2], &
                          beta=beta, errst=errst)
              !if(prop_error('contractmpol_qtensor_qtensorc: '//&
              !              'mcontr (1) failed.', 'MPOOps_include.f90:9062', &
              !              errst=errst)) return

              !call contr(Tout, Mat%Row(kk)%Op(ii), Tmp, [2], [2], &
              !           beta=beta, errst=errst)
              !!if(prop_error('contractmpol_qtensor_qtensorc: '//&
              !!              'contr (1) failed.', errst=errst)) return

          elseif(rnk == 4) then
              call mcontr(Tout, Tin(idx), Mat%Row(kk)%Op(ii), [2, 3], [3, 4], &
                          beta=beta, errst=errst)
              !if(prop_error('contractmpol_qtensor_qtensorc: '//&
              !              'mcontr (2) failed.', 'MPOOps_include.f90:9074', &
              !              errst=errst)) return

              !call contr(Tout, Mat%Row(kk)%Op(ii), Tmp, [3, 4], [2, 3], &
              !           beta=beta, errst=errst)
              !!if(prop_error('contractmpol_qtensor_qtensorc: '//&
              !!              'contr (2) failed.', errst=errst)) return

          else
              errst = raise_error('contractmpol_qtensor_qtensorc: '//&
                                  'bad rank.', 99, 'MPOOps_include.f90:9084', errst=errst)
          end if
          !call destroy(Tmp)

          ! Set operation to addition
          beta = zone
      end do

  end subroutine contractmpol_qtensor_qtensorc

MPOOps_f90.contractmpol_qtensorc_qtensorc()

fortran-subroutine - October 2017 (dj, updated) Do . The l stands for left-moving.

Arguments

ToutTYPE(qtensorc), inout

On exit, transfer matrix for one index in the row bond dimension of the MPO.

kkINTEGER, inout

The index of the row bond dimension in the MPO.

MatTYPE(qtensorc), inout

Matrix representing the MPO on the specific site.

TinTYPE(qtensorc), POINTER, inout

??

Details

Contract the MPO matrix M_{(k,a),b,c} with the tensor-array T_{(a),i,b,j} to a tensor T_{c,i,j}. This version works for single site and two-site MPO depending on the rank of the MPO matrix.

Source Code

show / hide f90 code

  subroutine contractmpol_qtensorc_qtensorc(Tout, kk, Mat, Tin, errst)
      type(qtensorc) :: Tout
      integer, intent(in) :: kk
      type(sr_matrix_qtensorc) :: Mat
      type(qtensorc), dimension(:) :: Tin
      integer, intent(out), optional :: errst

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

      ! for looping
      integer ::  ii

      ! Index in sparse row
      integer :: idx

      ! Rank of tensor in MPO matrix
      integer :: rnk

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

      ! temporary tensor
      !type(qtensorc) :: Tmp

      ! First one is initialization
      beta = zzero
      rnk = rank(Mat%Row(1)%Op(1))

      do ii = 1, Mat%Row(kk)%numel
          idx = Mat%Row(kk)%ind(ii)

          !call copy(Tmp, Tin(idx))
          if(rnk == 2) then
              call mcontr(Tout, Tin(idx), Mat%Row(kk)%Op(ii), [2], [2], &
                          beta=beta, errst=errst)
              !if(prop_error('contractmpol_qtensorc_qtensorc: '//&
              !              'mcontr (1) failed.', 'MPOOps_include.f90:9062', &
              !              errst=errst)) return

              !call contr(Tout, Mat%Row(kk)%Op(ii), Tmp, [2], [2], &
              !           beta=beta, errst=errst)
              !!if(prop_error('contractmpol_qtensorc_qtensorc: '//&
              !!              'contr (1) failed.', errst=errst)) return

          elseif(rnk == 4) then
              call mcontr(Tout, Tin(idx), Mat%Row(kk)%Op(ii), [2, 3], [3, 4], &
                          beta=beta, errst=errst)
              !if(prop_error('contractmpol_qtensorc_qtensorc: '//&
              !              'mcontr (2) failed.', 'MPOOps_include.f90:9074', &
              !              errst=errst)) return

              !call contr(Tout, Mat%Row(kk)%Op(ii), Tmp, [3, 4], [2, 3], &
              !           beta=beta, errst=errst)
              !!if(prop_error('contractmpol_qtensorc_qtensorc: '//&
              !!              'contr (2) failed.', errst=errst)) return

          else
              errst = raise_error('contractmpol_qtensorc_qtensorc: '//&
                                  'bad rank.', 99, 'MPOOps_include.f90:9084', errst=errst)
          end if
          !call destroy(Tmp)

          ! Set operation to addition
          beta = zone
      end do

  end subroutine contractmpol_qtensorc_qtensorc

MPOOps_f90.contractmpol_lptn_tensor_tensor()

fortran-subroutine - October 2017 (dj, updated) Left-moving building of a transfer matrix for an LPTN.

Arguments

ToutTYPE(tensor), inout

On exit, transfer matrix for one index in the row bond dimension of the MPO.

kkINTEGER, inout

The index of the row bond dimension in the MPO.

MatTYPE(tensor), inout

Matrix representing the MPO on the specific site.

TinTYPE(tensor), POINTER, inout

Tensor resulting from contraction of the transfer matrix and the bra and ket tensor.

Details

The LPTN version only works for single site MPO matrices.

Source Code

show / hide f90 code

  subroutine contractmpol_lptn_tensor_tensor(Tout, kk, Mat, Tin, errst)
      type(tensor), intent(inout) :: Tout
      integer, intent(in) :: kk
      type(sr_matrix_tensor), intent(inout) :: Mat
      type(tensor), dimension(:), intent(inout) :: Tin
      integer, intent(out), optional :: errst

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

      ! for looping
      integer ::  ii

      ! Index in sparse row
      integer :: idx

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

      !if(present(errst)) errst = 0

      ! First one is initialization
      beta = dzero

      do ii = 1, Mat%Row(kk)%numel
          idx = Mat%Row(kk)%ind(ii)

          call contr(Tout, Tin(idx), Mat%Row(kk)%Op(ii), [1, 2], [1, 2], &
                     beta=beta, errst=errst)
          !if(prop_error('contractmpol_lptn_tensor_tensor: '//&
          !              'mcontr (1) failed.', 'MPOOps_include.f90:9172', &
          !              errst=errst)) return

          ! Set operation to addition
          beta = done
      end do

  end subroutine contractmpol_lptn_tensor_tensor

MPOOps_f90.contractmpol_lptn_tensor_tensorc()

fortran-subroutine - October 2017 (dj, updated) Left-moving building of a transfer matrix for an LPTN.

Arguments

ToutTYPE(tensorc), inout

On exit, transfer matrix for one index in the row bond dimension of the MPO.

kkINTEGER, inout

The index of the row bond dimension in the MPO.

MatTYPE(tensor), inout

Matrix representing the MPO on the specific site.

TinTYPE(tensorc), POINTER, inout

Tensor resulting from contraction of the transfer matrix and the bra and ket tensor.

Details

The LPTN version only works for single site MPO matrices.

Source Code

show / hide f90 code

  subroutine contractmpol_lptn_tensor_tensorc(Tout, kk, Mat, Tin, errst)
      type(tensorc), intent(inout) :: Tout
      integer, intent(in) :: kk
      type(sr_matrix_tensor), intent(inout) :: Mat
      type(tensorc), dimension(:), intent(inout) :: Tin
      integer, intent(out), optional :: errst

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

      ! for looping
      integer ::  ii

      ! Index in sparse row
      integer :: idx

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

      !if(present(errst)) errst = 0

      ! First one is initialization
      beta = zzero

      do ii = 1, Mat%Row(kk)%numel
          idx = Mat%Row(kk)%ind(ii)

          call contr(Tout, Tin(idx), Mat%Row(kk)%Op(ii), [1, 2], [1, 2], &
                     beta=beta, errst=errst)
          !if(prop_error('contractmpol_lptn_tensor_tensorc: '//&
          !              'mcontr (1) failed.', 'MPOOps_include.f90:9172', &
          !              errst=errst)) return

          ! Set operation to addition
          beta = zone
      end do

  end subroutine contractmpol_lptn_tensor_tensorc

MPOOps_f90.contractmpol_lptn_tensorc_tensorc()

fortran-subroutine - October 2017 (dj, updated) Left-moving building of a transfer matrix for an LPTN.

Arguments

ToutTYPE(tensorc), inout

On exit, transfer matrix for one index in the row bond dimension of the MPO.

kkINTEGER, inout

The index of the row bond dimension in the MPO.

MatTYPE(tensorc), inout

Matrix representing the MPO on the specific site.

TinTYPE(tensorc), POINTER, inout

Tensor resulting from contraction of the transfer matrix and the bra and ket tensor.

Details

The LPTN version only works for single site MPO matrices.

Source Code

show / hide f90 code

  subroutine contractmpol_lptn_tensorc_tensorc(Tout, kk, Mat, Tin, errst)
      type(tensorc), intent(inout) :: Tout
      integer, intent(in) :: kk
      type(sr_matrix_tensorc), intent(inout) :: Mat
      type(tensorc), dimension(:), intent(inout) :: Tin
      integer, intent(out), optional :: errst

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

      ! for looping
      integer ::  ii

      ! Index in sparse row
      integer :: idx

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

      !if(present(errst)) errst = 0

      ! First one is initialization
      beta = zzero

      do ii = 1, Mat%Row(kk)%numel
          idx = Mat%Row(kk)%ind(ii)

          call contr(Tout, Tin(idx), Mat%Row(kk)%Op(ii), [1, 2], [1, 2], &
                     beta=beta, errst=errst)
          !if(prop_error('contractmpol_lptn_tensorc_tensorc: '//&
          !              'mcontr (1) failed.', 'MPOOps_include.f90:9172', &
          !              errst=errst)) return

          ! Set operation to addition
          beta = zone
      end do

  end subroutine contractmpol_lptn_tensorc_tensorc

MPOOps_f90.contractmpol_lptn_qtensor_qtensor()

fortran-subroutine - October 2017 (dj, updated) Left-moving building of a transfer matrix for an LPTN.

Arguments

ToutTYPE(qtensor), inout

On exit, transfer matrix for one index in the row bond dimension of the MPO.

kkINTEGER, inout

The index of the row bond dimension in the MPO.

MatTYPE(qtensor), inout

Matrix representing the MPO on the specific site.

TinTYPE(qtensor), POINTER, inout

Tensor resulting from contraction of the transfer matrix and the bra and ket tensor.

Details

The LPTN version only works for single site MPO matrices.

Source Code

show / hide f90 code

  subroutine contractmpol_lptn_qtensor_qtensor(Tout, kk, Mat, Tin, errst)
      type(qtensor), intent(inout) :: Tout
      integer, intent(in) :: kk
      type(sr_matrix_qtensor), intent(inout) :: Mat
      type(qtensor), dimension(:), intent(inout) :: Tin
      integer, intent(out), optional :: errst

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

      ! for looping
      integer ::  ii

      ! Index in sparse row
      integer :: idx

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

      !if(present(errst)) errst = 0

      ! First one is initialization
      beta = dzero

      do ii = 1, Mat%Row(kk)%numel
          idx = Mat%Row(kk)%ind(ii)

          call contr(Tout, Tin(idx), Mat%Row(kk)%Op(ii), [1, 2], [1, 2], &
                     beta=beta, errst=errst)
          !if(prop_error('contractmpol_lptn_qtensor_qtensor: '//&
          !              'mcontr (1) failed.', 'MPOOps_include.f90:9172', &
          !              errst=errst)) return

          ! Set operation to addition
          beta = done
      end do

  end subroutine contractmpol_lptn_qtensor_qtensor

MPOOps_f90.contractmpol_lptn_qtensor_qtensorc()

fortran-subroutine - October 2017 (dj, updated) Left-moving building of a transfer matrix for an LPTN.

Arguments

ToutTYPE(qtensorc), inout

On exit, transfer matrix for one index in the row bond dimension of the MPO.

kkINTEGER, inout

The index of the row bond dimension in the MPO.

MatTYPE(qtensor), inout

Matrix representing the MPO on the specific site.

TinTYPE(qtensorc), POINTER, inout

Tensor resulting from contraction of the transfer matrix and the bra and ket tensor.

Details

The LPTN version only works for single site MPO matrices.

Source Code

show / hide f90 code

  subroutine contractmpol_lptn_qtensor_qtensorc(Tout, kk, Mat, Tin, errst)
      type(qtensorc), intent(inout) :: Tout
      integer, intent(in) :: kk
      type(sr_matrix_qtensor), intent(inout) :: Mat
      type(qtensorc), dimension(:), intent(inout) :: Tin
      integer, intent(out), optional :: errst

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

      ! for looping
      integer ::  ii

      ! Index in sparse row
      integer :: idx

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

      !if(present(errst)) errst = 0

      ! First one is initialization
      beta = zzero

      do ii = 1, Mat%Row(kk)%numel
          idx = Mat%Row(kk)%ind(ii)

          call contr(Tout, Tin(idx), Mat%Row(kk)%Op(ii), [1, 2], [1, 2], &
                     beta=beta, errst=errst)
          !if(prop_error('contractmpol_lptn_qtensor_qtensorc: '//&
          !              'mcontr (1) failed.', 'MPOOps_include.f90:9172', &
          !              errst=errst)) return

          ! Set operation to addition
          beta = zone
      end do

  end subroutine contractmpol_lptn_qtensor_qtensorc

MPOOps_f90.contractmpol_lptn_qtensorc_qtensorc()

fortran-subroutine - October 2017 (dj, updated) Left-moving building of a transfer matrix for an LPTN.

Arguments

ToutTYPE(qtensorc), inout

On exit, transfer matrix for one index in the row bond dimension of the MPO.

kkINTEGER, inout

The index of the row bond dimension in the MPO.

MatTYPE(qtensorc), inout

Matrix representing the MPO on the specific site.

TinTYPE(qtensorc), POINTER, inout

Tensor resulting from contraction of the transfer matrix and the bra and ket tensor.

Details

The LPTN version only works for single site MPO matrices.

Source Code

show / hide f90 code

  subroutine contractmpol_lptn_qtensorc_qtensorc(Tout, kk, Mat, Tin, errst)
      type(qtensorc), intent(inout) :: Tout
      integer, intent(in) :: kk
      type(sr_matrix_qtensorc), intent(inout) :: Mat
      type(qtensorc), dimension(:), intent(inout) :: Tin
      integer, intent(out), optional :: errst

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

      ! for looping
      integer ::  ii

      ! Index in sparse row
      integer :: idx

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

      !if(present(errst)) errst = 0

      ! First one is initialization
      beta = zzero

      do ii = 1, Mat%Row(kk)%numel
          idx = Mat%Row(kk)%ind(ii)

          call contr(Tout, Tin(idx), Mat%Row(kk)%Op(ii), [1, 2], [1, 2], &
                     beta=beta, errst=errst)
          !if(prop_error('contractmpol_lptn_qtensorc_qtensorc: '//&
          !              'mcontr (1) failed.', 'MPOOps_include.f90:9172', &
          !              errst=errst)) return

          ! Set operation to addition
          beta = zone
      end do

  end subroutine contractmpol_lptn_qtensorc_qtensorc

MPOOps_f90.contractmpol_mpdo_tensor_tensor()

fortran-subroutine - October 2017 (dj, updated) Left-moving building of a transfer matrix for an MPDO.

Arguments

ToutTYPE(tensor), inout

On exit, transfer matrix for one index in the row bond dimension of the MPO.

kkINTEGER, inout

The index of the row bond dimension in the MPO.

MatTYPE(tensor), inout

Matrix representing the MPO on the specific site.

TinTYPE(tensor), POINTER, inout

Tensor resulting from contraction of the transfer matrix and the site tensor.

Details

The MPDO version only works for single site MPO matrices.

Source Code

show / hide f90 code

  subroutine contractmpol_mpdo_tensor_tensor(Tout, kk, Mat, Tin, errst)
      type(tensor), intent(inout) :: Tout
      integer, intent(in) :: kk
      type(sr_matrix_tensor), intent(inout) :: Mat
      type(tensor), dimension(:), intent(inout) :: Tin
      integer, intent(out), optional :: errst

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

      ! for looping
      integer ::  ii

      ! Index in sparse row
      integer :: idx

      ! Copy of the operator
      type(tensor) :: Tmp

      ! indices for fusing
      integer, dimension(2, 1) :: fidx

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

      !if(present(errst)) errst = 0

      ! First one is initialization
      beta = dzero

      fidx(:, 1) = [1, 2]

      do ii = 1, Mat%Row(kk)%numel
          idx = Mat%Row(kk)%ind(ii)

          call copy(Tmp, Mat%Row(kk)%Op(ii))
          call transposed(Tmp)
          call fuse(Tmp, fidx, '0')

          call contr(Tout, Tin(idx), Tmp, [2], [1], &
                     beta=beta, errst=errst)
          !if(prop_error('contractmpol_mpdo_tensor_tensor: '//&
          !              'mcontr (1) failed.', 'MPOOps_include.f90:9271', &
          !              errst=errst)) return

          call destroy(Tmp)

          ! Set operation to addition
          beta = done
      end do

  end subroutine contractmpol_mpdo_tensor_tensor

MPOOps_f90.contractmpol_mpdo_tensor_tensorc()

fortran-subroutine - October 2017 (dj, updated) Left-moving building of a transfer matrix for an MPDO.

Arguments

ToutTYPE(tensorc), inout

On exit, transfer matrix for one index in the row bond dimension of the MPO.

kkINTEGER, inout

The index of the row bond dimension in the MPO.

MatTYPE(tensor), inout

Matrix representing the MPO on the specific site.

TinTYPE(tensorc), POINTER, inout

Tensor resulting from contraction of the transfer matrix and the site tensor.

Details

The MPDO version only works for single site MPO matrices.

Source Code

show / hide f90 code

  subroutine contractmpol_mpdo_tensor_tensorc(Tout, kk, Mat, Tin, errst)
      type(tensorc), intent(inout) :: Tout
      integer, intent(in) :: kk
      type(sr_matrix_tensor), intent(inout) :: Mat
      type(tensorc), dimension(:), intent(inout) :: Tin
      integer, intent(out), optional :: errst

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

      ! for looping
      integer ::  ii

      ! Index in sparse row
      integer :: idx

      ! Copy of the operator
      type(tensor) :: Tmp

      ! indices for fusing
      integer, dimension(2, 1) :: fidx

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

      !if(present(errst)) errst = 0

      ! First one is initialization
      beta = zzero

      fidx(:, 1) = [1, 2]

      do ii = 1, Mat%Row(kk)%numel
          idx = Mat%Row(kk)%ind(ii)

          call copy(Tmp, Mat%Row(kk)%Op(ii))
          call transposed(Tmp)
          call fuse(Tmp, fidx, '0')

          call contr(Tout, Tin(idx), Tmp, [2], [1], &
                     beta=beta, errst=errst)
          !if(prop_error('contractmpol_mpdo_tensor_tensorc: '//&
          !              'mcontr (1) failed.', 'MPOOps_include.f90:9271', &
          !              errst=errst)) return

          call destroy(Tmp)

          ! Set operation to addition
          beta = zone
      end do

  end subroutine contractmpol_mpdo_tensor_tensorc

MPOOps_f90.contractmpol_mpdo_tensorc_tensorc()

fortran-subroutine - October 2017 (dj, updated) Left-moving building of a transfer matrix for an MPDO.

Arguments

ToutTYPE(tensorc), inout

On exit, transfer matrix for one index in the row bond dimension of the MPO.

kkINTEGER, inout

The index of the row bond dimension in the MPO.

MatTYPE(tensorc), inout

Matrix representing the MPO on the specific site.

TinTYPE(tensorc), POINTER, inout

Tensor resulting from contraction of the transfer matrix and the site tensor.

Details

The MPDO version only works for single site MPO matrices.

Source Code

show / hide f90 code

  subroutine contractmpol_mpdo_tensorc_tensorc(Tout, kk, Mat, Tin, errst)
      type(tensorc), intent(inout) :: Tout
      integer, intent(in) :: kk
      type(sr_matrix_tensorc), intent(inout) :: Mat
      type(tensorc), dimension(:), intent(inout) :: Tin
      integer, intent(out), optional :: errst

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

      ! for looping
      integer ::  ii

      ! Index in sparse row
      integer :: idx

      ! Copy of the operator
      type(tensorc) :: Tmp

      ! indices for fusing
      integer, dimension(2, 1) :: fidx

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

      !if(present(errst)) errst = 0

      ! First one is initialization
      beta = zzero

      fidx(:, 1) = [1, 2]

      do ii = 1, Mat%Row(kk)%numel
          idx = Mat%Row(kk)%ind(ii)

          call copy(Tmp, Mat%Row(kk)%Op(ii))
          call transposed(Tmp)
          call fuse(Tmp, fidx, '0')

          call contr(Tout, Tin(idx), Tmp, [2], [1], &
                     beta=beta, errst=errst)
          !if(prop_error('contractmpol_mpdo_tensorc_tensorc: '//&
          !              'mcontr (1) failed.', 'MPOOps_include.f90:9271', &
          !              errst=errst)) return

          call destroy(Tmp)

          ! Set operation to addition
          beta = zone
      end do

  end subroutine contractmpol_mpdo_tensorc_tensorc

MPOOps_f90.contractmpol_mpdo_qtensor_qtensor()

fortran-subroutine - October 2017 (dj, updated) Left-moving building of a transfer matrix for an MPDO.

Arguments

ToutTYPE(qtensor), inout

On exit, transfer matrix for one index in the row bond dimension of the MPO.

kkINTEGER, inout

The index of the row bond dimension in the MPO.

MatTYPE(qtensor), inout

Matrix representing the MPO on the specific site.

TinTYPE(qtensor), POINTER, inout

Tensor resulting from contraction of the transfer matrix and the site tensor.

Details

The MPDO version only works for single site MPO matrices.

Source Code

show / hide f90 code

  subroutine contractmpol_mpdo_qtensor_qtensor(Tout, kk, Mat, Tin, errst)
      type(qtensor), intent(inout) :: Tout
      integer, intent(in) :: kk
      type(sr_matrix_qtensor), intent(inout) :: Mat
      type(qtensor), dimension(:), intent(inout) :: Tin
      integer, intent(out), optional :: errst

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

      ! for looping
      integer ::  ii

      ! Index in sparse row
      integer :: idx

      ! Copy of the operator
      type(qtensor) :: Tmp

      ! indices for fusing
      integer, dimension(2, 1) :: fidx

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

      !if(present(errst)) errst = 0

      ! First one is initialization
      beta = dzero

      fidx(:, 1) = [1, 2]

      do ii = 1, Mat%Row(kk)%numel
          idx = Mat%Row(kk)%ind(ii)

          call copy(Tmp, Mat%Row(kk)%Op(ii))
          call transposed(Tmp)
          call fuse(Tmp, fidx, '0')

          call contr(Tout, Tin(idx), Tmp, [2], [1], &
                     beta=beta, errst=errst)
          !if(prop_error('contractmpol_mpdo_qtensor_qtensor: '//&
          !              'mcontr (1) failed.', 'MPOOps_include.f90:9271', &
          !              errst=errst)) return

          call destroy(Tmp)

          ! Set operation to addition
          beta = done
      end do

  end subroutine contractmpol_mpdo_qtensor_qtensor

MPOOps_f90.contractmpol_mpdo_qtensor_qtensorc()

fortran-subroutine - October 2017 (dj, updated) Left-moving building of a transfer matrix for an MPDO.

Arguments

ToutTYPE(qtensorc), inout

On exit, transfer matrix for one index in the row bond dimension of the MPO.

kkINTEGER, inout

The index of the row bond dimension in the MPO.

MatTYPE(qtensor), inout

Matrix representing the MPO on the specific site.

TinTYPE(qtensorc), POINTER, inout

Tensor resulting from contraction of the transfer matrix and the site tensor.

Details

The MPDO version only works for single site MPO matrices.

Source Code

show / hide f90 code

  subroutine contractmpol_mpdo_qtensor_qtensorc(Tout, kk, Mat, Tin, errst)
      type(qtensorc), intent(inout) :: Tout
      integer, intent(in) :: kk
      type(sr_matrix_qtensor), intent(inout) :: Mat
      type(qtensorc), dimension(:), intent(inout) :: Tin
      integer, intent(out), optional :: errst

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

      ! for looping
      integer ::  ii

      ! Index in sparse row
      integer :: idx

      ! Copy of the operator
      type(qtensor) :: Tmp

      ! indices for fusing
      integer, dimension(2, 1) :: fidx

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

      !if(present(errst)) errst = 0

      ! First one is initialization
      beta = zzero

      fidx(:, 1) = [1, 2]

      do ii = 1, Mat%Row(kk)%numel
          idx = Mat%Row(kk)%ind(ii)

          call copy(Tmp, Mat%Row(kk)%Op(ii))
          call transposed(Tmp)
          call fuse(Tmp, fidx, '0')

          call contr(Tout, Tin(idx), Tmp, [2], [1], &
                     beta=beta, errst=errst)
          !if(prop_error('contractmpol_mpdo_qtensor_qtensorc: '//&
          !              'mcontr (1) failed.', 'MPOOps_include.f90:9271', &
          !              errst=errst)) return

          call destroy(Tmp)

          ! Set operation to addition
          beta = zone
      end do

  end subroutine contractmpol_mpdo_qtensor_qtensorc

MPOOps_f90.contractmpol_mpdo_qtensorc_qtensorc()

fortran-subroutine - October 2017 (dj, updated) Left-moving building of a transfer matrix for an MPDO.

Arguments

ToutTYPE(qtensorc), inout

On exit, transfer matrix for one index in the row bond dimension of the MPO.

kkINTEGER, inout

The index of the row bond dimension in the MPO.

MatTYPE(qtensorc), inout

Matrix representing the MPO on the specific site.

TinTYPE(qtensorc), POINTER, inout

Tensor resulting from contraction of the transfer matrix and the site tensor.

Details

The MPDO version only works for single site MPO matrices.

Source Code

show / hide f90 code

  subroutine contractmpol_mpdo_qtensorc_qtensorc(Tout, kk, Mat, Tin, errst)
      type(qtensorc), intent(inout) :: Tout
      integer, intent(in) :: kk
      type(sr_matrix_qtensorc), intent(inout) :: Mat
      type(qtensorc), dimension(:), intent(inout) :: Tin
      integer, intent(out), optional :: errst

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

      ! for looping
      integer ::  ii

      ! Index in sparse row
      integer :: idx

      ! Copy of the operator
      type(qtensorc) :: Tmp

      ! indices for fusing
      integer, dimension(2, 1) :: fidx

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

      !if(present(errst)) errst = 0

      ! First one is initialization
      beta = zzero

      fidx(:, 1) = [1, 2]

      do ii = 1, Mat%Row(kk)%numel
          idx = Mat%Row(kk)%ind(ii)

          call copy(Tmp, Mat%Row(kk)%Op(ii))
          call transposed(Tmp)
          call fuse(Tmp, fidx, '0')

          call contr(Tout, Tin(idx), Tmp, [2], [1], &
                     beta=beta, errst=errst)
          !if(prop_error('contractmpol_mpdo_qtensorc_qtensorc: '//&
          !              'mcontr (1) failed.', 'MPOOps_include.f90:9271', &
          !              errst=errst)) return

          call destroy(Tmp)

          ! Set operation to addition
          beta = zone
      end do

  end subroutine contractmpol_mpdo_qtensorc_qtensorc

MPOOps_f90.contractmpor_tensor_tensor()

fortran-subroutine - ?? () - only used to define transfermatrices - no FOURtensor verison required.

Arguments

GTYPE(tensor), inout

??

kpINTEGER, inout

??

WTYPE(tensor), inout

??

FTYPE(tensor), POINTER, inout

??

Source Code

show / hide f90 code

  subroutine contractmpor_tensor_tensor(Tout, kk, Mat, Tin, errst)
      type(tensor), intent(inout) :: Tout
      integer, intent(in) :: kk
      type(sr_matrix_tensor) :: Mat
      type(tensor), dimension(:) :: Tin
      integer, intent(out), optional :: errst

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

      ! for looping
      integer ::  ii, jj

      ! operation for contraction
      real(KIND=rKind) :: beta

      ! temporary tensor
      !type(tensor) :: Tmp

      ! First beta is 0.0
      beta = dzero

      do ii = 1, Mat%rbd
          do jj = 1, Mat%Row(ii)%numel

              if(kk /= Mat%Row(ii)%ind(jj)) cycle

              call mcontr(Tout, Tin(ii), Mat%Row(ii)%Op(jj), [2], [2], &
                          beta=beta, errst=errst)
              !if(prop_error('contractmpor_tensor_tensor: '// &
              !              'mcontr failed.', 'MPOOps_include.f90:9354', &
              !              errst=errst)) return

              !call copy(Tmp, Tin(ii))
              !call contr(Tout, Tmp, Mat%Row(ii)%Op(jj), [2], [2], &
              !           beta=beta, errst=errst)
              !!if(prop_error('contractmpor_tensor_tensor: '// &
              !!              'contr failed.', errst=errst)) return

              ! Next one is addition
              beta = done

              !call destroy(Tmp)

              ! There can be only one element - leave inner loop
              exit
          end do
      end do

  end subroutine contractmpor_tensor_tensor

MPOOps_f90.contractmpor_tensor_tensorc()

fortran-subroutine - ?? () - only used to define transfermatrices - no FOURtensorc verison required.

Arguments

GTYPE(tensorc), inout

??

kpINTEGER, inout

??

WTYPE(tensor), inout

??

FTYPE(tensorc), POINTER, inout

??

Source Code

show / hide f90 code

  subroutine contractmpor_tensor_tensorc(Tout, kk, Mat, Tin, errst)
      type(tensorc), intent(inout) :: Tout
      integer, intent(in) :: kk
      type(sr_matrix_tensor) :: Mat
      type(tensorc), dimension(:) :: Tin
      integer, intent(out), optional :: errst

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

      ! for looping
      integer ::  ii, jj

      ! operation for contraction
      complex(KIND=rKind) :: beta

      ! temporary tensor
      !type(tensorc) :: Tmp

      ! First beta is 0.0
      beta = zzero

      do ii = 1, Mat%rbd
          do jj = 1, Mat%Row(ii)%numel

              if(kk /= Mat%Row(ii)%ind(jj)) cycle

              call mcontr(Tout, Tin(ii), Mat%Row(ii)%Op(jj), [2], [2], &
                          beta=beta, errst=errst)
              !if(prop_error('contractmpor_tensor_tensorc: '// &
              !              'mcontr failed.', 'MPOOps_include.f90:9354', &
              !              errst=errst)) return

              !call copy(Tmp, Tin(ii))
              !call contr(Tout, Tmp, Mat%Row(ii)%Op(jj), [2], [2], &
              !           beta=beta, errst=errst)
              !!if(prop_error('contractmpor_tensor_tensorc: '// &
              !!              'contr failed.', errst=errst)) return

              ! Next one is addition
              beta = zone

              !call destroy(Tmp)

              ! There can be only one element - leave inner loop
              exit
          end do
      end do

  end subroutine contractmpor_tensor_tensorc

MPOOps_f90.contractmpor_tensorc_tensorc()

fortran-subroutine - ?? () - only used to define transfermatrices - no FOURtensorc verison required.

Arguments

GTYPE(tensorc), inout

??

kpINTEGER, inout

??

WTYPE(tensorc), inout

??

FTYPE(tensorc), POINTER, inout

??

Source Code

show / hide f90 code

  subroutine contractmpor_tensorc_tensorc(Tout, kk, Mat, Tin, errst)
      type(tensorc), intent(inout) :: Tout
      integer, intent(in) :: kk
      type(sr_matrix_tensorc) :: Mat
      type(tensorc), dimension(:) :: Tin
      integer, intent(out), optional :: errst

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

      ! for looping
      integer ::  ii, jj

      ! operation for contraction
      complex(KIND=rKind) :: beta

      ! temporary tensor
      !type(tensorc) :: Tmp

      ! First beta is 0.0
      beta = zzero

      do ii = 1, Mat%rbd
          do jj = 1, Mat%Row(ii)%numel

              if(kk /= Mat%Row(ii)%ind(jj)) cycle

              call mcontr(Tout, Tin(ii), Mat%Row(ii)%Op(jj), [2], [2], &
                          beta=beta, errst=errst)
              !if(prop_error('contractmpor_tensorc_tensorc: '// &
              !              'mcontr failed.', 'MPOOps_include.f90:9354', &
              !              errst=errst)) return

              !call copy(Tmp, Tin(ii))
              !call contr(Tout, Tmp, Mat%Row(ii)%Op(jj), [2], [2], &
              !           beta=beta, errst=errst)
              !!if(prop_error('contractmpor_tensorc_tensorc: '// &
              !!              'contr failed.', errst=errst)) return

              ! Next one is addition
              beta = zone

              !call destroy(Tmp)

              ! There can be only one element - leave inner loop
              exit
          end do
      end do

  end subroutine contractmpor_tensorc_tensorc

MPOOps_f90.contractmpor_qtensor_qtensor()

fortran-subroutine - ?? () - only used to define transfermatrices - no FOURqtensor verison required.

Arguments

GTYPE(qtensor), inout

??

kpINTEGER, inout

??

WTYPE(qtensor), inout

??

FTYPE(qtensor), POINTER, inout

??

Source Code

show / hide f90 code

  subroutine contractmpor_qtensor_qtensor(Tout, kk, Mat, Tin, errst)
      type(qtensor), intent(inout) :: Tout
      integer, intent(in) :: kk
      type(sr_matrix_qtensor) :: Mat
      type(qtensor), dimension(:) :: Tin
      integer, intent(out), optional :: errst

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

      ! for looping
      integer ::  ii, jj

      ! operation for contraction
      real(KIND=rKind) :: beta

      ! temporary tensor
      !type(qtensor) :: Tmp

      ! First beta is 0.0
      beta = dzero

      do ii = 1, Mat%rbd
          do jj = 1, Mat%Row(ii)%numel

              if(kk /= Mat%Row(ii)%ind(jj)) cycle

              call mcontr(Tout, Tin(ii), Mat%Row(ii)%Op(jj), [2], [2], &
                          beta=beta, errst=errst)
              !if(prop_error('contractmpor_qtensor_qtensor: '// &
              !              'mcontr failed.', 'MPOOps_include.f90:9354', &
              !              errst=errst)) return

              !call copy(Tmp, Tin(ii))
              !call contr(Tout, Tmp, Mat%Row(ii)%Op(jj), [2], [2], &
              !           beta=beta, errst=errst)
              !!if(prop_error('contractmpor_qtensor_qtensor: '// &
              !!              'contr failed.', errst=errst)) return

              ! Next one is addition
              beta = done

              !call destroy(Tmp)

              ! There can be only one element - leave inner loop
              exit
          end do
      end do

  end subroutine contractmpor_qtensor_qtensor

MPOOps_f90.contractmpor_qtensor_qtensorc()

fortran-subroutine - ?? () - only used to define transfermatrices - no FOURqtensorc verison required.

Arguments

GTYPE(qtensorc), inout

??

kpINTEGER, inout

??

WTYPE(qtensor), inout

??

FTYPE(qtensorc), POINTER, inout

??

Source Code

show / hide f90 code

  subroutine contractmpor_qtensor_qtensorc(Tout, kk, Mat, Tin, errst)
      type(qtensorc), intent(inout) :: Tout
      integer, intent(in) :: kk
      type(sr_matrix_qtensor) :: Mat
      type(qtensorc), dimension(:) :: Tin
      integer, intent(out), optional :: errst

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

      ! for looping
      integer ::  ii, jj

      ! operation for contraction
      complex(KIND=rKind) :: beta

      ! temporary tensor
      !type(qtensorc) :: Tmp

      ! First beta is 0.0
      beta = zzero

      do ii = 1, Mat%rbd
          do jj = 1, Mat%Row(ii)%numel

              if(kk /= Mat%Row(ii)%ind(jj)) cycle

              call mcontr(Tout, Tin(ii), Mat%Row(ii)%Op(jj), [2], [2], &
                          beta=beta, errst=errst)
              !if(prop_error('contractmpor_qtensor_qtensorc: '// &
              !              'mcontr failed.', 'MPOOps_include.f90:9354', &
              !              errst=errst)) return

              !call copy(Tmp, Tin(ii))
              !call contr(Tout, Tmp, Mat%Row(ii)%Op(jj), [2], [2], &
              !           beta=beta, errst=errst)
              !!if(prop_error('contractmpor_qtensor_qtensorc: '// &
              !!              'contr failed.', errst=errst)) return

              ! Next one is addition
              beta = zone

              !call destroy(Tmp)

              ! There can be only one element - leave inner loop
              exit
          end do
      end do

  end subroutine contractmpor_qtensor_qtensorc

MPOOps_f90.contractmpor_qtensorc_qtensorc()

fortran-subroutine - ?? () - only used to define transfermatrices - no FOURqtensorc verison required.

Arguments

GTYPE(qtensorc), inout

??

kpINTEGER, inout

??

WTYPE(qtensorc), inout

??

FTYPE(qtensorc), POINTER, inout

??

Source Code

show / hide f90 code

  subroutine contractmpor_qtensorc_qtensorc(Tout, kk, Mat, Tin, errst)
      type(qtensorc), intent(inout) :: Tout
      integer, intent(in) :: kk
      type(sr_matrix_qtensorc) :: Mat
      type(qtensorc), dimension(:) :: Tin
      integer, intent(out), optional :: errst

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

      ! for looping
      integer ::  ii, jj

      ! operation for contraction
      complex(KIND=rKind) :: beta

      ! temporary tensor
      !type(qtensorc) :: Tmp

      ! First beta is 0.0
      beta = zzero

      do ii = 1, Mat%rbd
          do jj = 1, Mat%Row(ii)%numel

              if(kk /= Mat%Row(ii)%ind(jj)) cycle

              call mcontr(Tout, Tin(ii), Mat%Row(ii)%Op(jj), [2], [2], &
                          beta=beta, errst=errst)
              !if(prop_error('contractmpor_qtensorc_qtensorc: '// &
              !              'mcontr failed.', 'MPOOps_include.f90:9354', &
              !              errst=errst)) return

              !call copy(Tmp, Tin(ii))
              !call contr(Tout, Tmp, Mat%Row(ii)%Op(jj), [2], [2], &
              !           beta=beta, errst=errst)
              !!if(prop_error('contractmpor_qtensorc_qtensorc: '// &
              !!              'contr failed.', errst=errst)) return

              ! Next one is addition
              beta = zone

              !call destroy(Tmp)

              ! There can be only one element - leave inner loop
              exit
          end do
      end do

  end subroutine contractmpor_qtensorc_qtensorc

MPOOps_f90.build_kraus_first_order_tensorlist()

fortran-subroutine - September 2017 (dj) Build the first order approximation to the Kraus operators for tensors without symmetry.

Arguments

KrausTYPE(tensorc), inout

First two dimensions are the Hilbert space, third dimension is the Kraus dimension.

OpsTYPE(tensorlist), inout

List of operators necessary to build Hamiltonian and, here, Kraus operators from Lindblad operators.

RsTYPE(MPORuleSet), inout

Rule set containing the list of Lindblad operators.

HparamsTYPE(HamiltonianParameters), inout

Coupling for the Lindblad operators.

iopINTEGER, inout

Position of the identity operator.

xxINTEGER, inout

Indicates the site for which the Kraus operators are built to access site-dependent coupling.

dtREAL, inout

Time step.

Source Code

show / hide f90 code

  subroutine build_kraus_first_order_tensorlist(Kraus, Ops, Rs, Hparams, iop, &
                                               xx, dt, errst)
      type(tensorc), intent(inout) :: Kraus
      type(tensorlist), intent(inout) :: Ops
      type(MPORuleSet), intent(in) :: Rs
      type(HamiltonianParameters), intent(in), pointer :: Hparams(:)
      integer, intent(in) :: iop, xx
      real(KIND=rKind), intent(in) :: dt
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! indexing
      integer :: j1, j2, k1, k2

      ! number of Lindblads
      integer :: nn

      ! Dimension local operators
      integer :: d1, d2, dim

      ! coupling
      real(KIND=rKind) :: coupl

      ! temporary tensors
      type(tensor) :: Tens

      nn = Rs%nlxx + 1
      d1 = Ops%Li(iop)%dl(1)
      d2 = Ops%Li(iop)%dl(2)
      dim = d1 * d2

      call create(Kraus, [d1, d2, nn])

      j1 = 1
      j2 = dim

      k1 = dim * (nn - 1) + 1
      k2 = dim * nn
      Kraus%elem(k1:k2) = Ops%Li(iop)%elem(:dim)

      do ii = 1, (nn - 1)
          coupl = sqrt(Rs%Lxx(ii)%w * get_coupl(Hparams, Rs%Lxx(ii)%h, xx) * dt)
          Kraus%elem(j1:j2) = coupl * Ops%Li(Rs%Lxx(ii)%o)%elem(:dim)
          j1 = j1 + dim
          j2 = j2 + dim

          call contr(Tens, Ops%Li(Rs%Lxx(ii)%o), &
                     Ops%Li(Rs%Lxx(ii)%o), [1], [1], transl='C')
          Kraus%elem(k1:k2) = Kraus%elem(k1:k2) &
                              - 0.5_rKind * coupl**2 * Tens%elem(:dim)
          call destroy(Tens)
      end do

  end subroutine build_kraus_first_order_tensorlist

MPOOps_f90.build_kraus_first_order_tensorlistc()

fortran-subroutine - September 2017 (dj) Build the first order approximation to the Kraus operators for tensors without symmetry.

Arguments

KrausTYPE(tensorc), inout

First two dimensions are the Hilbert space, third dimension is the Kraus dimension.

OpsTYPE(tensorlistc), inout

List of operators necessary to build Hamiltonian and, here, Kraus operators from Lindblad operators.

RsTYPE(MPORuleSet), inout

Rule set containing the list of Lindblad operators.

HparamsTYPE(HamiltonianParameters), inout

Coupling for the Lindblad operators.

iopINTEGER, inout

Position of the identity operator.

xxINTEGER, inout

Indicates the site for which the Kraus operators are built to access site-dependent coupling.

dtREAL, inout

Time step.

Source Code

show / hide f90 code

  subroutine build_kraus_first_order_tensorlistc(Kraus, Ops, Rs, Hparams, iop, &
                                               xx, dt, errst)
      type(tensorc), intent(inout) :: Kraus
      type(tensorlistc), intent(inout) :: Ops
      type(MPORuleSet), intent(in) :: Rs
      type(HamiltonianParameters), intent(in), pointer :: Hparams(:)
      integer, intent(in) :: iop, xx
      real(KIND=rKind), intent(in) :: dt
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! indexing
      integer :: j1, j2, k1, k2

      ! number of Lindblads
      integer :: nn

      ! Dimension local operators
      integer :: d1, d2, dim

      ! coupling
      real(KIND=rKind) :: coupl

      ! temporary tensors
      type(tensorc) :: Tens

      nn = Rs%nlxx + 1
      d1 = Ops%Li(iop)%dl(1)
      d2 = Ops%Li(iop)%dl(2)
      dim = d1 * d2

      call create(Kraus, [d1, d2, nn])

      j1 = 1
      j2 = dim

      k1 = dim * (nn - 1) + 1
      k2 = dim * nn
      Kraus%elem(k1:k2) = Ops%Li(iop)%elem(:dim)

      do ii = 1, (nn - 1)
          coupl = sqrt(Rs%Lxx(ii)%w * get_coupl(Hparams, Rs%Lxx(ii)%h, xx) * dt)
          Kraus%elem(j1:j2) = coupl * Ops%Li(Rs%Lxx(ii)%o)%elem(:dim)
          j1 = j1 + dim
          j2 = j2 + dim

          call contr(Tens, Ops%Li(Rs%Lxx(ii)%o), &
                     Ops%Li(Rs%Lxx(ii)%o), [1], [1], transl='C')
          Kraus%elem(k1:k2) = Kraus%elem(k1:k2) &
                              - 0.5_rKind * coupl**2 * Tens%elem(:dim)
          call destroy(Tens)
      end do

  end subroutine build_kraus_first_order_tensorlistc

MPOOps_f90.build_kraus_first_order_qtensorlist()

fortran-subroutine - September 2017 (dj) Build the first order approximation to the Kraus operators for tensors with symmetry.

Arguments

KrausTYPE(qtensorc), inout

???

OpsTYPE(qtensorlist), inout

List of operators necessary to build Hamiltonian and, here, Kraus operators from Lindblad operators.

RsTYPE(MPORuleSet), inout

Rule set containing the list of Lindblad operators.

HparamsTYPE(HamiltonianParameters), inout

Coupling for the Lindblad operators.

iopINTEGER, inout

Position of the identity operator.

xxINTEGER, inout

Indicates the site for which the Kraus operators are built to access site-dependent coupling.

dtREAL, inout

Time step.

Source Code

show / hide f90 code

  subroutine build_kraus_first_order_qtensorlist(Kraus, Ops, Rs, Hparams, iop, &
                                               xx, dt, errst)
      type(qtensorc), intent(inout) :: Kraus
      type(qtensorlist), intent(in) :: Ops
      type(MPORuleSet), intent(in) :: Rs
      type(HamiltonianParameters), intent(in), pointer :: Hparams(:)
      integer, intent(in) :: iop, xx
      real(KIND=rKind), intent(in) :: dt
      integer, intent(out), optional :: errst

      errst = raise_error('build_kraus_first_order_qtensorlist : not implemented', &
                          99, errst=errst)

  end subroutine build_kraus_first_order_qtensorlist

MPOOps_f90.build_kraus_first_order_qtensorclist()

fortran-subroutine - September 2017 (dj) Build the first order approximation to the Kraus operators for tensors with symmetry.

Arguments

KrausTYPE(qtensorc), inout

???

OpsTYPE(qtensorclist), inout

List of operators necessary to build Hamiltonian and, here, Kraus operators from Lindblad operators.

RsTYPE(MPORuleSet), inout

Rule set containing the list of Lindblad operators.

HparamsTYPE(HamiltonianParameters), inout

Coupling for the Lindblad operators.

iopINTEGER, inout

Position of the identity operator.

xxINTEGER, inout

Indicates the site for which the Kraus operators are built to access site-dependent coupling.

dtREAL, inout

Time step.

Source Code

show / hide f90 code

  subroutine build_kraus_first_order_qtensorclist(Kraus, Ops, Rs, Hparams, iop, &
                                               xx, dt, errst)
      type(qtensorc), intent(inout) :: Kraus
      type(qtensorclist), intent(in) :: Ops
      type(MPORuleSet), intent(in) :: Rs
      type(HamiltonianParameters), intent(in), pointer :: Hparams(:)
      integer, intent(in) :: iop, xx
      real(KIND=rKind), intent(in) :: dt
      integer, intent(out), optional :: errst

      errst = raise_error('build_kraus_first_order_qtensorclist : not implemented', &
                          99, errst=errst)

  end subroutine build_kraus_first_order_qtensorclist