"""
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**
* D. Jaschke
* M. L. Wall
"""
[docs]def copy_hamiltonianparameters():
"""
fortran-subroutine - August 2017 (dj, updated)
Copy the TYPE(HamiltonianParameters) from source Objin to Objout.
Recall indices start at zero.
**Arguments**
Objout : TYPE(HamiltonianParameters)(\*), inout
Target of copy.
Objin : TYPE(HamiltonianParameters)(\*), in
Source of copy.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def 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**
Hparams : TYPE(HamiltonianParameters)(*), inout
to be filled with the Hamiltonian parameters for a simulation/model
The array runs from zero.
filestub : CHARACTER(*), in
filename
unit : INTEGER, in
Open file on this unit.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def 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**
Hparams : TYPE(HamiltoniansParameters), POINTER, in
contains the Hamiltonian parameters
fileid : INTEGER, in
This file-unit is open to read the parameters.
whichHparams : INTEGER(*), in
list of indices to update in `Hparams`
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def destroy_hamiltonianparameters():
"""
fortran-subroutine - August 2017 (dj, updated)
Delete/deallocate all the Hamiltonian parameters.
**Arguments**
Hparams : TYPE(HamiltonianParameters)(\*), inout
Hamiltonian parameters to be deleted
filestub : CHARACTER(*), in
filename.
unit : INTEGER, in
Available unit to open file for deleting.
clearfile : LOGICAL, OPTIONAL, in
.TRUE. : delete `.dat`-file as well
.FALSE. : leave `.dat`-file on hard disk (default)
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def ReadOperators_tensorlist():
"""
fortran-subroutine - August 2017 (dj, updated)
Read Operators from the Python input file
**Arguments**
filestub : CHARACTER(*), inout
filename containing operators.
Operators : TYPE(tensorlist), inout
List of operators to be filled during the subroutine.
**Details**
(template defined in MPOOps_include.f90)
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def ReadOperators_tensorlistc():
"""
fortran-subroutine - August 2017 (dj, updated)
Read Operators from the Python input file
**Arguments**
filestub : CHARACTER(*), inout
filename containing operators.
Operators : TYPE(tensorlistc), inout
List of operators to be filled during the subroutine.
**Details**
(template defined in MPOOps_include.f90)
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def ReadOperators_qtensorlist():
"""
fortran-subroutine - August 2017 (dj, updated)
Read Operators from the Python input file.
**Arguments**
fileStub : CHARACTER(*), inout
filename containing the operators.
Operators : TYPE(qtensorlist), inout
List with operators is filled according the input file `fileStub`
generated of the python front-end.
nqs : INTEGER, in
Number of conserved quantities / symmetries in the definition of
the operators.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def ReadOperators_qtensorclist():
"""
fortran-subroutine - August 2017 (dj, updated)
Read Operators from the Python input file.
**Arguments**
fileStub : CHARACTER(*), inout
filename containing the operators.
Operators : TYPE(qtensorclist), inout
List with operators is filled according the input file `fileStub`
generated of the python front-end.
nqs : INTEGER, in
Number of conserved quantities / symmetries in the definition of
the operators.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def DeallocateOperators_tensorlist():
"""
fortran-subroutine - August 2017 (dj, updated)
Deallocate the operators used by the Python interface.
**Arguments**
fileStub : CHARACTER(*), inout
Filename. This is only used when deleting the file.
Operators : TYPE(tensorlist), inout
Contains the operator alphabet for the simulation which is
deleted during this subroutine
clearfile : LOGICAL, 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**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def DeallocateOperators_tensorlistc():
"""
fortran-subroutine - August 2017 (dj, updated)
Deallocate the operators used by the Python interface.
**Arguments**
fileStub : CHARACTER(*), inout
Filename. This is only used when deleting the file.
Operators : TYPE(tensorlistc), inout
Contains the operator alphabet for the simulation which is
deleted during this subroutine
clearfile : LOGICAL, 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**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def DeallocateOperators_qtensorlist():
"""
fortran-subroutine - August 2017 (dj, updated)
Deallocate the operators used by the Python interface.
**Arguments**
fileStub : CHARACTER(*), inout
Filename. This is only used when deleting the file.
Operators : TYPE(qtensorlist), inout
Contains the operator alphabet for the simulation which is
deleted during this subroutine
clearfile : LOGICAL, 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**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def DeallocateOperators_qtensorclist():
"""
fortran-subroutine - August 2017 (dj, updated)
Deallocate the operators used by the Python interface.
**Arguments**
fileStub : CHARACTER(*), inout
Filename. This is only used when deleting the file.
Operators : TYPE(qtensorclist), inout
Contains the operator alphabet for the simulation which is
deleted during this subroutine
clearfile : LOGICAL, 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**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def has_lindblads():
"""
fortran-function - August 2017 (dj)
Check if a rule set has any Lindblad terms in it.
**Arguments**
Rs : TYPE(MPORuleSet), in
Check this rule set for Lindblad terms.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def get_coupl():
"""
fortran-function - May 2017 (dj)
Extract the coupling.
**Arguments**
Hparams : TYPE(HamiltonianParameters), in
Contains the coupling for the each parameters in the
Hamiltonian.
idx : INTEGER, in
Position of the parameter in the list.
xx : INTEGER, in
Site index in case the coupling is site dependent.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def fuse_sparse_row_tensor():
"""
fortran-subroutine - September 2017 (dj)
Fuse the operators from a rank-4 to a rank-2 tensor.
**Arguments**
Row : TYPE(sparse_row_tensor), inout
The row of a sparse matrix. The operators
are reduced from rank-4 to rank-2 on exit.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def fuse_sparse_row_tensorc():
"""
fortran-subroutine - September 2017 (dj)
Fuse the operators from a rank-4 to a rank-2 tensor.
**Arguments**
Row : TYPE(sparse_row_tensorc), inout
The row of a sparse matrix. The operators
are reduced from rank-4 to rank-2 on exit.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def fuse_sparse_row_qtensor():
"""
fortran-subroutine - September 2017 (dj)
Fuse the operators from a rank-4 to a rank-2 tensor.
**Arguments**
Row : TYPE(sparse_row_qtensor), inout
The row of a sparse matrix. The operators
are reduced from rank-4 to rank-2 on exit.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def fuse_sparse_row_qtensorc():
"""
fortran-subroutine - September 2017 (dj)
Fuse the operators from a rank-4 to a rank-2 tensor.
**Arguments**
Row : TYPE(sparse_row_qtensorc), inout
The row of a sparse matrix. The operators
are reduced from rank-4 to rank-2 on exit.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def fuse_sr_matrix_tensor():
"""
fortran-subroutine - September 2017 (dj)
Fuse the operators from a rank-4 to a rank-2 tensor.
**Arguments**
Mat : TYPE(sr_matrix_tensor), inout
A sparse matrix. The operators
are reduced from rank-4 to rank-2 on exit.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def fuse_sr_matrix_tensorc():
"""
fortran-subroutine - September 2017 (dj)
Fuse the operators from a rank-4 to a rank-2 tensor.
**Arguments**
Mat : TYPE(sr_matrix_tensorc), inout
A sparse matrix. The operators
are reduced from rank-4 to rank-2 on exit.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def fuse_sr_matrix_qtensor():
"""
fortran-subroutine - September 2017 (dj)
Fuse the operators from a rank-4 to a rank-2 tensor.
**Arguments**
Mat : TYPE(sr_matrix_qtensor), inout
A sparse matrix. The operators
are reduced from rank-4 to rank-2 on exit.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def fuse_sr_matrix_qtensorc():
"""
fortran-subroutine - September 2017 (dj)
Fuse the operators from a rank-4 to a rank-2 tensor.
**Arguments**
Mat : TYPE(sr_matrix_qtensorc), inout
A sparse matrix. The operators
are reduced from rank-4 to rank-2 on exit.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def sdot_sr_matrix_tensor():
"""
fortran-subroutine - May 2017 (dj)
Dot product / matrix-matrix multiplication between to sparse matrices.
**Arguments**
Matc : TYPE(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.
Mata : TYPE(sr_matrix_tensor), in
The left sparse matrix in the matrix-matrix multiplications.
Matb : TYPE(sr_matrix_tensor), in
The left sparse matrix in the matrix-matrix multiplications.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def sdot_sr_matrix_tensorc():
"""
fortran-subroutine - May 2017 (dj)
Dot product / matrix-matrix multiplication between to sparse matrices.
**Arguments**
Matc : TYPE(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.
Mata : TYPE(sr_matrix_tensorc), in
The left sparse matrix in the matrix-matrix multiplications.
Matb : TYPE(sr_matrix_tensorc), in
The left sparse matrix in the matrix-matrix multiplications.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def sdot_sr_matrix_qtensor():
"""
fortran-subroutine - May 2017 (dj)
Dot product / matrix-matrix multiplication between to sparse matrices.
**Arguments**
Matc : TYPE(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.
Mata : TYPE(sr_matrix_qtensor), in
The left sparse matrix in the matrix-matrix multiplications.
Matb : TYPE(sr_matrix_qtensor), in
The left sparse matrix in the matrix-matrix multiplications.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def sdot_sr_matrix_qtensorc():
"""
fortran-subroutine - May 2017 (dj)
Dot product / matrix-matrix multiplication between to sparse matrices.
**Arguments**
Matc : TYPE(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.
Mata : TYPE(sr_matrix_qtensorc), in
The left sparse matrix in the matrix-matrix multiplications.
Matb : TYPE(sr_matrix_qtensorc), in
The left sparse matrix in the matrix-matrix multiplications.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def set_hash_sparse_row_qtensor():
"""
fortran-subroutine - October 2017 (dj)
Set the hashes for all operators in a row of a sparse matrix.
**Arguments**
Row : TYPE(sparse_row_qtensor), inout
The row of a sparse matrix. The operators
are hashed according to their quantum numbers and the given index.
idxs : INTEGER(\*), in
Specify indices to be hashed in regard to the legs of the tensor.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def set_hash_sparse_row_qtensorc():
"""
fortran-subroutine - October 2017 (dj)
Set the hashes for all operators in a row of a sparse matrix.
**Arguments**
Row : TYPE(sparse_row_qtensorc), inout
The row of a sparse matrix. The operators
are hashed according to their quantum numbers and the given index.
idxs : INTEGER(\*), in
Specify indices to be hashed in regard to the legs of the tensor.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def set_hash_sr_matrix_qtensor():
"""
fortran-subroutine - October 2017 (dj)
Set the hashes for all operators in a sparse matrix.
**Arguments**
Mat : TYPE(sr_matrix_qtensor), inout
A sparse matrix. The operators are hashed according to their
quantum numbers and the given indices.
idxs : INTEGER(\*), in
Specify indices to be hashed in regard to the legs of the tensor.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def set_hash_sr_matrix_qtensorc():
"""
fortran-subroutine - October 2017 (dj)
Set the hashes for all operators in a sparse matrix.
**Arguments**
Mat : TYPE(sr_matrix_qtensorc), inout
A sparse matrix. The operators are hashed according to their
quantum numbers and the given indices.
idxs : INTEGER(\*), in
Specify indices to be hashed in regard to the legs of the tensor.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def set_hash_sr_matrix_tensor():
"""
fortran-subroutine - October 2017 (dj)
Dummy interface to supply interface for usual tensors without symmetries.
**Arguments**
Mat : TYPE(sr_matrix_tensor), inout
A sparse matrix. The operators are hashed according to their
quantum numbers and the given indices.
idxs : INTEGER(\*), in
Specify indices to be hashed in regard to the legs of the tensor.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def set_hash_sr_matrix_tensorc():
"""
fortran-subroutine - October 2017 (dj)
Dummy interface to supply interface for usual tensors without symmetries.
**Arguments**
Mat : TYPE(sr_matrix_tensorc), inout
A sparse matrix. The operators are hashed according to their
quantum numbers and the given indices.
idxs : INTEGER(\*), in
Specify indices to be hashed in regard to the legs of the tensor.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def shift_sr_matrix_tensor():
"""
fortran-subroutine - Construct the sparse MPO matrix representing (H - shift)
**Arguments**
Mat : TYPE(sr_matrix_tensor), inout
On exit, this is the shifted MPO.
shft : REAL, in
The value for the shift.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def shift_sr_matrix_tensorc():
"""
fortran-subroutine - Construct the sparse MPO matrix representing (H - shift)
**Arguments**
Mat : TYPE(sr_matrix_tensorc), inout
On exit, this is the shifted MPO.
shft : REAL, in
The value for the shift.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def shift_sr_matrix_qtensor():
"""
fortran-subroutine - Construct the sparse MPO matrix representing (H - shift)
**Arguments**
Mat : TYPE(sr_matrix_qtensor), inout
On exit, this is the shifted MPO.
shft : REAL, in
The value for the shift.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def shift_sr_matrix_qtensorc():
"""
fortran-subroutine - Construct the sparse MPO matrix representing (H - shift)
**Arguments**
Mat : TYPE(sr_matrix_qtensorc), inout
On exit, this is the shifted MPO.
shft : REAL, in
The value for the shift.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def shiftandsquare_sparse_row_tensor():
"""
fortran-subroutine - May 2017 (dj, updated)
Shift and calculate the square for an MPO for one row.
**Arguments**
Rowsq : TYPE(MPO_ROW_TYPE), inout
Contains on exit on row of the shifted and squared MPO.
Rowi : TYPE(MPO_ROW_TYPE), inout
The left row in the sparse matrix to be shifted and squared.
Intent(out) is to allow for possible transformations.
Rowj : TYPE(MPO_ROW_TYPE), inout
The right row in the sparse matrix to be shifted and squared.
Intent(out) is to allow for possible transformations.
ilr : LOGICAL, in
Flag if the left row equals to the last row in the original matrix.
jlr : LOGICAL, in
Flag if the right row equals to the last row in the original matrix.
cbd : INTEGER, in
Number of columns in the original matrix.
Sh : TYPE(MATRIX_TYPE), in
Contains - shift x Id, where Id is the identity matrix.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def shiftandsquare_sparse_row_tensorc():
"""
fortran-subroutine - May 2017 (dj, updated)
Shift and calculate the square for an MPO for one row.
**Arguments**
Rowsq : TYPE(MPO_ROW_TYPE), inout
Contains on exit on row of the shifted and squared MPO.
Rowi : TYPE(MPO_ROW_TYPE), inout
The left row in the sparse matrix to be shifted and squared.
Intent(out) is to allow for possible transformations.
Rowj : TYPE(MPO_ROW_TYPE), inout
The right row in the sparse matrix to be shifted and squared.
Intent(out) is to allow for possible transformations.
ilr : LOGICAL, in
Flag if the left row equals to the last row in the original matrix.
jlr : LOGICAL, in
Flag if the right row equals to the last row in the original matrix.
cbd : INTEGER, in
Number of columns in the original matrix.
Sh : TYPE(MATRIX_TYPE), in
Contains - shift x Id, where Id is the identity matrix.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def shiftandsquare_sparse_row_qtensor():
"""
fortran-subroutine - May 2017 (dj, updated)
Shift and calculate the square for an MPO for one row.
**Arguments**
Rowsq : TYPE(MPO_ROW_TYPE), inout
Contains on exit on row of the shifted and squared MPO.
Rowi : TYPE(MPO_ROW_TYPE), inout
The left row in the sparse matrix to be shifted and squared.
Intent(out) is to allow for possible transformations.
Rowj : TYPE(MPO_ROW_TYPE), inout
The right row in the sparse matrix to be shifted and squared.
Intent(out) is to allow for possible transformations.
ilr : LOGICAL, in
Flag if the left row equals to the last row in the original matrix.
jlr : LOGICAL, in
Flag if the right row equals to the last row in the original matrix.
cbd : INTEGER, in
Number of columns in the original matrix.
Sh : TYPE(MATRIX_TYPE), in
Contains - shift x Id, where Id is the identity matrix.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def shiftandsquare_sparse_row_qtensorc():
"""
fortran-subroutine - May 2017 (dj, updated)
Shift and calculate the square for an MPO for one row.
**Arguments**
Rowsq : TYPE(MPO_ROW_TYPE), inout
Contains on exit on row of the shifted and squared MPO.
Rowi : TYPE(MPO_ROW_TYPE), inout
The left row in the sparse matrix to be shifted and squared.
Intent(out) is to allow for possible transformations.
Rowj : TYPE(MPO_ROW_TYPE), inout
The right row in the sparse matrix to be shifted and squared.
Intent(out) is to allow for possible transformations.
ilr : LOGICAL, in
Flag if the left row equals to the last row in the original matrix.
jlr : LOGICAL, in
Flag if the right row equals to the last row in the original matrix.
cbd : INTEGER, in
Number of columns in the original matrix.
Sh : TYPE(MATRIX_TYPE), in
Contains - shift x Id, where Id is the identity matrix.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def 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**
Matsq : TYPE(sr_matrix_tensor), inout
On exit, the shifted square of the original MPO matrix.
Mat : TYPE(sr_matrix_tensor), inout
The MPO matrix to be shifted and squared.
shift : REAL, in
The shift as scalar.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def 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**
Matsq : TYPE(sr_matrix_tensorc), inout
On exit, the shifted square of the original MPO matrix.
Mat : TYPE(sr_matrix_tensorc), inout
The MPO matrix to be shifted and squared.
shift : REAL, in
The shift as scalar.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def 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**
Matsq : TYPE(sr_matrix_qtensor), inout
On exit, the shifted square of the original MPO matrix.
Mat : TYPE(sr_matrix_qtensor), inout
The MPO matrix to be shifted and squared.
shift : REAL, in
The shift as scalar.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def 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**
Matsq : TYPE(sr_matrix_qtensorc), inout
On exit, the shifted square of the original MPO matrix.
Mat : TYPE(sr_matrix_qtensorc), inout
The MPO matrix to be shifted and squared.
shift : REAL, in
The shift as scalar.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def square_sparse_row_tensor():
"""
fortran-subroutine - May 2017 (dj, updated)
Calculate the square of an MPO for one row.
**Arguments**
Rowsq : TYPE(sparse_row_tensor), inout
Contains on exit the sparse matrix necessary
for squaring an MPO.
Rowi : to, inout
allow for possible transformations.
Rowj : to, inout
allow for possible transformations.
cbd : INTEGER, in
Number of columns in the sparse matrix to be squared.
trafol : CHARACTER, OPTIONAL, inout
Transformation on the left matrix.
trafor : CHARACTER, OPTIONAL, inout
Transformation on the right matrix.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def square_sparse_row_tensorc():
"""
fortran-subroutine - May 2017 (dj, updated)
Calculate the square of an MPO for one row.
**Arguments**
Rowsq : TYPE(sparse_row_tensorc), inout
Contains on exit the sparse matrix necessary
for squaring an MPO.
Rowi : to, inout
allow for possible transformations.
Rowj : to, inout
allow for possible transformations.
cbd : INTEGER, in
Number of columns in the sparse matrix to be squared.
trafol : CHARACTER, OPTIONAL, inout
Transformation on the left matrix.
trafor : CHARACTER, OPTIONAL, inout
Transformation on the right matrix.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def square_sparse_row_qtensor():
"""
fortran-subroutine - May 2017 (dj, updated)
Calculate the square of an MPO for one row.
**Arguments**
Rowsq : TYPE(sparse_row_qtensor), inout
Contains on exit the sparse matrix necessary
for squaring an MPO.
Rowi : to, inout
allow for possible transformations.
Rowj : to, inout
allow for possible transformations.
cbd : INTEGER, in
Number of columns in the sparse matrix to be squared.
trafol : CHARACTER, OPTIONAL, inout
Transformation on the left matrix.
trafor : CHARACTER, OPTIONAL, inout
Transformation on the right matrix.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def square_sparse_row_qtensorc():
"""
fortran-subroutine - May 2017 (dj, updated)
Calculate the square of an MPO for one row.
**Arguments**
Rowsq : TYPE(sparse_row_qtensorc), inout
Contains on exit the sparse matrix necessary
for squaring an MPO.
Rowi : to, inout
allow for possible transformations.
Rowj : to, inout
allow for possible transformations.
cbd : INTEGER, in
Number of columns in the sparse matrix to be squared.
trafol : CHARACTER, OPTIONAL, inout
Transformation on the left matrix.
trafor : CHARACTER, OPTIONAL, inout
Transformation on the right matrix.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def 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**
Matsq : TYPE(sr_matrix_tensor), inout
On exit, the square of the original MPO matrix.
Mat : TYPE(sr_matrix_tensor), inout
The MPO matrix to be squared.
trafol : CHARACTER, OPTIONAL, inout
Transformation on the left matrix.
trafor : CHARACTER, OPTIONAL, inout
Transformation on the right matrix.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def 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**
Matsq : TYPE(sr_matrix_tensorc), inout
On exit, the square of the original MPO matrix.
Mat : TYPE(sr_matrix_tensorc), inout
The MPO matrix to be squared.
trafol : CHARACTER, OPTIONAL, inout
Transformation on the left matrix.
trafor : CHARACTER, OPTIONAL, inout
Transformation on the right matrix.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def 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**
Matsq : TYPE(sr_matrix_qtensor), inout
On exit, the square of the original MPO matrix.
Mat : TYPE(sr_matrix_qtensor), inout
The MPO matrix to be squared.
trafol : CHARACTER, OPTIONAL, inout
Transformation on the left matrix.
trafor : CHARACTER, OPTIONAL, inout
Transformation on the right matrix.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def 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**
Matsq : TYPE(sr_matrix_qtensorc), inout
On exit, the square of the original MPO matrix.
Mat : TYPE(sr_matrix_qtensorc), inout
The MPO matrix to be squared.
trafol : CHARACTER, OPTIONAL, inout
Transformation on the left matrix.
trafor : CHARACTER, OPTIONAL, inout
Transformation on the right matrix.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def construct_two_site_mpo_matrix_mpo():
"""
fortran-subroutine - July 2017 (dj)
Construct all nearest-neighbor two site MPO matrices.
**Arguments**
Hts : TYPE(sr_matrix_tensor)(\*), inout
On exit allocated array of (ll - 1) nearest-neighbor two-site
MPO matrices.
Ham : TYPE(mpo), inout
Ham represents the MPO from which the two site MPO matrices
are built.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def construct_two_site_mpo_matrix_mpoc():
"""
fortran-subroutine - July 2017 (dj)
Construct all nearest-neighbor two site MPO matrices.
**Arguments**
Hts : TYPE(sr_matrix_tensorc)(\*), inout
On exit allocated array of (ll - 1) nearest-neighbor two-site
MPO matrices.
Ham : TYPE(mpoc), inout
Ham represents the MPO from which the two site MPO matrices
are built.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def construct_two_site_mpo_matrix_qmpo():
"""
fortran-subroutine - July 2017 (dj)
Construct all nearest-neighbor two site MPO matrices.
**Arguments**
Hts : TYPE(sr_matrix_qtensor)(\*), inout
On exit allocated array of (ll - 1) nearest-neighbor two-site
MPO matrices.
Ham : TYPE(qmpo), inout
Ham represents the MPO from which the two site MPO matrices
are built.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def construct_two_site_mpo_matrix_qmpoc():
"""
fortran-subroutine - July 2017 (dj)
Construct all nearest-neighbor two site MPO matrices.
**Arguments**
Hts : TYPE(sr_matrix_qtensorc)(\*), inout
On exit allocated array of (ll - 1) nearest-neighbor two-site
MPO matrices.
Ham : TYPE(qmpoc), inout
Ham represents the MPO from which the two site MPO matrices
are built.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def destroy_two_site_mpo_matrix_mpo():
"""
fortran-subroutine - July 2017 (dj)
Destroy all two site MPO matrices.
**Arguments**
Hts : TYPE(sr_matrix_tensor)(\*), inout
Deallocate array of (ll - 1) nearest-neighbor two-site
MPO matrices.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def destroy_two_site_mpo_matrix_mpoc():
"""
fortran-subroutine - July 2017 (dj)
Destroy all two site MPO matrices.
**Arguments**
Hts : TYPE(sr_matrix_tensorc)(\*), inout
Deallocate array of (ll - 1) nearest-neighbor two-site
MPO matrices.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def destroy_two_site_mpo_matrix_qmpo():
"""
fortran-subroutine - July 2017 (dj)
Destroy all two site MPO matrices.
**Arguments**
Hts : TYPE(sr_matrix_qtensor)(\*), inout
Deallocate array of (ll - 1) nearest-neighbor two-site
MPO matrices.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def destroy_two_site_mpo_matrix_qmpoc():
"""
fortran-subroutine - July 2017 (dj)
Destroy all two site MPO matrices.
**Arguments**
Hts : TYPE(sr_matrix_qtensorc)(\*), inout
Deallocate array of (ll - 1) nearest-neighbor two-site
MPO matrices.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def destroy_mpo():
"""
fortran-subroutine - May 2017 (dj, updated)
Deallocate/destroy an MPO.
**Arguments**
Obj : TYPE(mpo), inout
On exit, all variables are deallocated.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def destroy_mpoc():
"""
fortran-subroutine - May 2017 (dj, updated)
Deallocate/destroy an MPO.
**Arguments**
Obj : TYPE(mpoc), inout
On exit, all variables are deallocated.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def destroy_qmpo():
"""
fortran-subroutine - May 2017 (dj, updated)
Deallocate/destroy an MPO.
**Arguments**
Obj : TYPE(qmpo), inout
On exit, all variables are deallocated.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def destroy_qmpoc():
"""
fortran-subroutine - May 2017 (dj, updated)
Deallocate/destroy an MPO.
**Arguments**
Obj : TYPE(qmpoc), inout
On exit, all variables are deallocated.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def set_hash_mpo():
"""
fortran-subroutine - October 2017 (dj)
Set the hashes in an MPO iff it has symmetries according to the given
indices.
**Arguments**
Obj : TYPE(mpo), inout
Is MPO. On exit, the hashes will be set on each operator with
symmetries in the complete MPO.
idxs : INTEGER(\*), in
Specify indices to be hashed in regard to the legs of the tensor.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def set_hash_mpoc():
"""
fortran-subroutine - October 2017 (dj)
Set the hashes in an MPO iff it has symmetries according to the given
indices.
**Arguments**
Obj : TYPE(mpoc), inout
Is MPO. On exit, the hashes will be set on each operator with
symmetries in the complete MPO.
idxs : INTEGER(\*), in
Specify indices to be hashed in regard to the legs of the tensor.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def set_hash_qmpo():
"""
fortran-subroutine - October 2017 (dj)
Set the hashes in an MPO iff it has symmetries according to the given
indices.
**Arguments**
Obj : TYPE(qmpo), inout
Is MPO. On exit, the hashes will be set on each operator with
symmetries in the complete MPO.
idxs : INTEGER(\*), in
Specify indices to be hashed in regard to the legs of the tensor.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def set_hash_qmpoc():
"""
fortran-subroutine - October 2017 (dj)
Set the hashes in an MPO iff it has symmetries according to the given
indices.
**Arguments**
Obj : TYPE(qmpoc), inout
Is MPO. On exit, the hashes will be set on each operator with
symmetries in the complete MPO.
idxs : INTEGER(\*), in
Specify indices to be hashed in regard to the legs of the tensor.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def 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**
Obj : TYPE(mpo), inout
Set the pointers in this MPO.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def shift_mpo():
"""
fortran-subroutine - May 2017 (dj, updated)
Transform the MPO H to the representation (H - shift).
**Arguments**
Obj : TYPE(mpo), inout
MPO to be shifted. Shifted on exit.
sh : REAL, in
Apply this shift sh to the MPO.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def 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**
Objsq : TYPE(mpo), inout
On exit, the MPO shifted and squared.
Obj : TYPE(mpo), inout
MPO to be shifted and squared.
sh : REAL, in
The negative shift sh applied to the MPO.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def square_mpo():
"""
fortran-subroutine - May 2017 (dj, updated)
Square an MPO. The bond dimension on each link squares as well.
**Arguments**
Objsq : TYPE(mpo), inout
On exit, the squared MPO of Obj using the direct product.
Obj : TYPE(mpo), inout
MPO to be squared.
trafol : CHARACTER, OPTIONAL, inout
Transformation on the left matrix.
trafor : CHARACTER, OPTIONAL, inout
Transformation on the right matrix.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def 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**
Obj : TYPE(mpoc), inout
Set the pointers in this MPO.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def shift_mpoc():
"""
fortran-subroutine - May 2017 (dj, updated)
Transform the MPO H to the representation (H - shift).
**Arguments**
Obj : TYPE(mpoc), inout
MPO to be shifted. Shifted on exit.
sh : REAL, in
Apply this shift sh to the MPO.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def 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**
Objsq : TYPE(mpoc), inout
On exit, the MPO shifted and squared.
Obj : TYPE(mpoc), inout
MPO to be shifted and squared.
sh : REAL, in
The negative shift sh applied to the MPO.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def square_mpoc():
"""
fortran-subroutine - May 2017 (dj, updated)
Square an MPO. The bond dimension on each link squares as well.
**Arguments**
Objsq : TYPE(mpoc), inout
On exit, the squared MPO of Obj using the direct product.
Obj : TYPE(mpoc), inout
MPO to be squared.
trafol : CHARACTER, OPTIONAL, inout
Transformation on the left matrix.
trafor : CHARACTER, OPTIONAL, inout
Transformation on the right matrix.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def 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**
Obj : TYPE(qmpo), inout
Set the pointers in this MPO.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def shift_qmpo():
"""
fortran-subroutine - May 2017 (dj, updated)
Transform the MPO H to the representation (H - shift).
**Arguments**
Obj : TYPE(qmpo), inout
MPO to be shifted. Shifted on exit.
sh : REAL, in
Apply this shift sh to the MPO.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def 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**
Objsq : TYPE(qmpo), inout
On exit, the MPO shifted and squared.
Obj : TYPE(qmpo), inout
MPO to be shifted and squared.
sh : REAL, in
The negative shift sh applied to the MPO.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def square_qmpo():
"""
fortran-subroutine - May 2017 (dj, updated)
Square an MPO. The bond dimension on each link squares as well.
**Arguments**
Objsq : TYPE(qmpo), inout
On exit, the squared MPO of Obj using the direct product.
Obj : TYPE(qmpo), inout
MPO to be squared.
trafol : CHARACTER, OPTIONAL, inout
Transformation on the left matrix.
trafor : CHARACTER, OPTIONAL, inout
Transformation on the right matrix.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def 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**
Obj : TYPE(qmpoc), inout
Set the pointers in this MPO.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def shift_qmpoc():
"""
fortran-subroutine - May 2017 (dj, updated)
Transform the MPO H to the representation (H - shift).
**Arguments**
Obj : TYPE(qmpoc), inout
MPO to be shifted. Shifted on exit.
sh : REAL, in
Apply this shift sh to the MPO.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def 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**
Objsq : TYPE(qmpoc), inout
On exit, the MPO shifted and squared.
Obj : TYPE(qmpoc), inout
MPO to be shifted and squared.
sh : REAL, in
The negative shift sh applied to the MPO.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def square_qmpoc():
"""
fortran-subroutine - May 2017 (dj, updated)
Square an MPO. The bond dimension on each link squares as well.
**Arguments**
Objsq : TYPE(qmpoc), inout
On exit, the squared MPO of Obj using the direct product.
Obj : TYPE(qmpoc), inout
MPO to be squared.
trafol : CHARACTER, OPTIONAL, inout
Transformation on the left matrix.
trafor : CHARACTER, OPTIONAL, inout
Transformation on the right matrix.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def 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**
Ham : TYPE(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.
xx : INTEGER, in
Get hamiltonian for sites xx, xx+1
Rs : TYPE(MPORuleSet), in
Contains the rule set to build up the MPO. For the 2-site Hamiltonian
only site-rules and bond-rules are considered.
Ops : TYPE(tensorlist), in
List containing all operators for the evolution
Hparams : TYPE(HamiltonianParameters), in
containing the couplings for each operator
iop : INTEGER, in
The index of the identity in the operator list.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def 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**
Ham : TYPE(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.
xx : INTEGER, in
Get hamiltonian for sites xx, xx+1
Rs : TYPE(MPORuleSet), in
Contains the rule set to build up the MPO. For the 2-site Hamiltonian
only site-rules and bond-rules are considered.
Ops : TYPE(tensorlist), in
List containing all operators for the evolution
Hparams : TYPE(HamiltonianParameters), in
containing the couplings for each operator
iop : INTEGER, in
The index of the identity in the operator list.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def 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**
Ham : TYPE(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.
xx : INTEGER, in
Get hamiltonian for sites xx, xx+1
Rs : TYPE(MPORuleSet), in
Contains the rule set to build up the MPO. For the 2-site Hamiltonian
only site-rules and bond-rules are considered.
Ops : TYPE(tensorlistc), in
List containing all operators for the evolution
Hparams : TYPE(HamiltonianParameters), in
containing the couplings for each operator
iop : INTEGER, in
The index of the identity in the operator list.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def 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**
Ham : TYPE(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.
xx : INTEGER, in
Get hamiltonian for sites xx, xx+1
Rs : TYPE(MPORuleSet), in
Contains the rule set to build up the MPO. For the 2-site Hamiltonian
only site-rules and bond-rules are considered.
Ops : TYPE(qtensorlist), in
List containing all operators for the evolution
Hparams : TYPE(HamiltonianParameters), in
containing the couplings for each operator
iop : INTEGER, in
The index of the identity in the operator list.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def 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**
Ham : TYPE(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.
xx : INTEGER, in
Get hamiltonian for sites xx, xx+1
Rs : TYPE(MPORuleSet), in
Contains the rule set to build up the MPO. For the 2-site Hamiltonian
only site-rules and bond-rules are considered.
Ops : TYPE(qtensorlist), in
List containing all operators for the evolution
Hparams : TYPE(HamiltonianParameters), in
containing the couplings for each operator
iop : INTEGER, in
The index of the identity in the operator list.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def 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**
Ham : TYPE(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.
xx : INTEGER, in
Get hamiltonian for sites xx, xx+1
Rs : TYPE(MPORuleSet), in
Contains the rule set to build up the MPO. For the 2-site Hamiltonian
only site-rules and bond-rules are considered.
Ops : TYPE(qtensorclist), in
List containing all operators for the evolution
Hparams : TYPE(HamiltonianParameters), in
containing the couplings for each operator
iop : INTEGER, in
The index of the identity in the operator list.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def 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**
Ham : TYPE(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.
xx : INTEGER, in
Get hamiltonian for sites xx, xx+1
Rs : TYPE(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.
Ops : TYPE(tensorlist), inout
List containing all operators for the evolution
Hparams : TYPE(HamiltonianParameters), in
containing the couplings for each operator
iop : INTEGER, in
The index of the identity in the operator list.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def 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**
Ham : TYPE(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.
xx : INTEGER, in
Get hamiltonian for sites xx, xx+1
Rs : TYPE(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.
Ops : TYPE(tensorlistc), inout
List containing all operators for the evolution
Hparams : TYPE(HamiltonianParameters), in
containing the couplings for each operator
iop : INTEGER, in
The index of the identity in the operator list.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def 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**
Ham : TYPE(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.
xx : INTEGER, in
Get hamiltonian for sites xx, xx+1
Rs : TYPE(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.
Ops : TYPE(qtensorlist), inout
List containing all operators for the evolution
Hparams : TYPE(HamiltonianParameters), in
containing the couplings for each operator
iop : INTEGER, in
The index of the identity in the operator list.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def 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**
Ham : TYPE(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.
xx : INTEGER, in
Get hamiltonian for sites xx, xx+1
Rs : TYPE(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.
Ops : TYPE(qtensorclist), inout
List containing all operators for the evolution
Hparams : TYPE(HamiltonianParameters), in
containing the couplings for each operator
iop : INTEGER, in
The index of the identity in the operator list.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def 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**
Liou : TYPE(tensor), inout
On exit, the Liouville operator as rank-4 tensor.
xx : INTEGER, in
Get Liouville operator for sites xx, xx+1
Rs : TYPE(MPORuleSet), in
Contains the rule set to build up the MPO.
Ops : TYPE(tensorlist), in
List containing all operators for the evolution
Hparams : TYPE(HamiltonianParameters), in
containing the couplings for each operator
iop : INTEGER, in
The index of the identity in the operator list.
is_init : LOGICAL, OPTIONAL, out
If true, Liou has already been initialized. If false, no terms
were added up to now.
scconjspace : REAL, 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**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def 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**
Liou : TYPE(tensorc), inout
On exit, the Liouville operator as rank-4 tensor.
xx : INTEGER, in
Get Liouville operator for sites xx, xx+1
Rs : TYPE(MPORuleSet), in
Contains the rule set to build up the MPO.
Ops : TYPE(tensorlist), in
List containing all operators for the evolution
Hparams : TYPE(HamiltonianParameters), in
containing the couplings for each operator
iop : INTEGER, in
The index of the identity in the operator list.
is_init : LOGICAL, OPTIONAL, out
If true, Liou has already been initialized. If false, no terms
were added up to now.
scconjspace : REAL, 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**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def 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**
Liou : TYPE(tensorc), inout
On exit, the Liouville operator as rank-4 tensor.
xx : INTEGER, in
Get Liouville operator for sites xx, xx+1
Rs : TYPE(MPORuleSet), in
Contains the rule set to build up the MPO.
Ops : TYPE(tensorlistc), in
List containing all operators for the evolution
Hparams : TYPE(HamiltonianParameters), in
containing the couplings for each operator
iop : INTEGER, in
The index of the identity in the operator list.
is_init : LOGICAL, OPTIONAL, out
If true, Liou has already been initialized. If false, no terms
were added up to now.
scconjspace : REAL, 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**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def 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**
Liou : TYPE(qtensor), inout
On exit, the Liouville operator as rank-4 tensor.
xx : INTEGER, in
Get Liouville operator for sites xx, xx+1
Rs : TYPE(MPORuleSet), in
Contains the rule set to build up the MPO.
Ops : TYPE(qtensorlist), in
List containing all operators for the evolution
Hparams : TYPE(HamiltonianParameters), in
containing the couplings for each operator
iop : INTEGER, in
The index of the identity in the operator list.
is_init : LOGICAL, OPTIONAL, out
If true, Liou has already been initialized. If false, no terms
were added up to now.
scconjspace : REAL, 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**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def 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**
Liou : TYPE(qtensorc), inout
On exit, the Liouville operator as rank-4 tensor.
xx : INTEGER, in
Get Liouville operator for sites xx, xx+1
Rs : TYPE(MPORuleSet), in
Contains the rule set to build up the MPO.
Ops : TYPE(qtensorlist), in
List containing all operators for the evolution
Hparams : TYPE(HamiltonianParameters), in
containing the couplings for each operator
iop : INTEGER, in
The index of the identity in the operator list.
is_init : LOGICAL, OPTIONAL, out
If true, Liou has already been initialized. If false, no terms
were added up to now.
scconjspace : REAL, 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**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def 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**
Liou : TYPE(qtensorc), inout
On exit, the Liouville operator as rank-4 tensor.
xx : INTEGER, in
Get Liouville operator for sites xx, xx+1
Rs : TYPE(MPORuleSet), in
Contains the rule set to build up the MPO.
Ops : TYPE(qtensorclist), in
List containing all operators for the evolution
Hparams : TYPE(HamiltonianParameters), in
containing the couplings for each operator
iop : INTEGER, in
The index of the identity in the operator list.
is_init : LOGICAL, OPTIONAL, out
If true, Liou has already been initialized. If false, no terms
were added up to now.
scconjspace : REAL, 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**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def ruleset_to_liou_2site_tensorlist():
"""
fortran-subroutine - September 2017 (dj)
Build a two-site Liouville operator for a Lindblad master equation.
**Arguments**
Liou : TYPE(tensorc), inout
On exit, the Liouville operator as rank-4 tensor.
xx : INTEGER, in
Get Liouville operator for sites xx, xx+1
Rs : TYPE(MPORuleSet), in
Contains the rule set to build up the MPO.
Ops : TYPE(tensorlist), inout
List containing all operators for the evolution
Hparams : TYPE(HamiltonianParameters), in
containing the couplings for each operator
iop : INTEGER, 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**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def ruleset_to_liou_2site_tensorlistc():
"""
fortran-subroutine - September 2017 (dj)
Build a two-site Liouville operator for a Lindblad master equation.
**Arguments**
Liou : TYPE(tensorc), inout
On exit, the Liouville operator as rank-4 tensor.
xx : INTEGER, in
Get Liouville operator for sites xx, xx+1
Rs : TYPE(MPORuleSet), in
Contains the rule set to build up the MPO.
Ops : TYPE(tensorlistc), inout
List containing all operators for the evolution
Hparams : TYPE(HamiltonianParameters), in
containing the couplings for each operator
iop : INTEGER, 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**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def ruleset_to_liou_2site_qtensorlist():
"""
fortran-subroutine - September 2017 (dj)
Build a two-site Liouville operator for a Lindblad master equation.
**Arguments**
Liou : TYPE(qtensorc), inout
On exit, the Liouville operator as rank-4 tensor.
xx : INTEGER, in
Get Liouville operator for sites xx, xx+1
Rs : TYPE(MPORuleSet), in
Contains the rule set to build up the MPO.
Ops : TYPE(qtensorlist), inout
List containing all operators for the evolution
Hparams : TYPE(HamiltonianParameters), in
containing the couplings for each operator
iop : INTEGER, 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**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def ruleset_to_liou_2site_qtensorclist():
"""
fortran-subroutine - September 2017 (dj)
Build a two-site Liouville operator for a Lindblad master equation.
**Arguments**
Liou : TYPE(qtensorc), inout
On exit, the Liouville operator as rank-4 tensor.
xx : INTEGER, in
Get Liouville operator for sites xx, xx+1
Rs : TYPE(MPORuleSet), in
Contains the rule set to build up the MPO.
Ops : TYPE(qtensorclist), inout
List containing all operators for the evolution
Hparams : TYPE(HamiltonianParameters), in
containing the couplings for each operator
iop : INTEGER, 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**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def 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**
Ham : TYPE(Fmpo), inout
initialized during this subroutine.
Rs : TYPE(MPORuleSet), inout
Rule set for simulation
ll : INTEGER, inout
number of sites in the system.
Ops : TYPE(tensorlist), inout
Operator alphabet contain all operators to build MPO.
Hparams : TYPE(HamiltonianParameters)(*), POINTER, in
Hamiltonian parameters contain coupling etc.
iop : INTEGER, in
The index of the identity in the operator list.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine 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
"""
return
[docs]def 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**
Ham : TYPE(Fmpoc), inout
initialized during this subroutine.
Rs : TYPE(MPORuleSet), inout
Rule set for simulation
ll : INTEGER, inout
number of sites in the system.
Ops : TYPE(tensorlist), inout
Operator alphabet contain all operators to build MPO.
Hparams : TYPE(HamiltonianParameters)(*), POINTER, in
Hamiltonian parameters contain coupling etc.
iop : INTEGER, in
The index of the identity in the operator list.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine 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
"""
return
[docs]def 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**
Ham : TYPE(Fmpoc), inout
initialized during this subroutine.
Rs : TYPE(MPORuleSet), inout
Rule set for simulation
ll : INTEGER, inout
number of sites in the system.
Ops : TYPE(tensorlistc), inout
Operator alphabet contain all operators to build MPO.
Hparams : TYPE(HamiltonianParameters)(*), POINTER, in
Hamiltonian parameters contain coupling etc.
iop : INTEGER, in
The index of the identity in the operator list.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine 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
"""
return
[docs]def 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**
Ham : TYPE(Fqmpo), inout
initialized during this subroutine.
Rs : TYPE(MPORuleSet), inout
Rule set for simulation
ll : INTEGER, inout
number of sites in the system.
Ops : TYPE(qtensorlist), inout
Operator alphabet contain all operators to build MPO.
Hparams : TYPE(HamiltonianParameters)(*), POINTER, in
Hamiltonian parameters contain coupling etc.
iop : INTEGER, in
The index of the identity in the operator list.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine 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
"""
return
[docs]def 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**
Ham : TYPE(Fqmpoc), inout
initialized during this subroutine.
Rs : TYPE(MPORuleSet), inout
Rule set for simulation
ll : INTEGER, inout
number of sites in the system.
Ops : TYPE(qtensorlist), inout
Operator alphabet contain all operators to build MPO.
Hparams : TYPE(HamiltonianParameters)(*), POINTER, in
Hamiltonian parameters contain coupling etc.
iop : INTEGER, in
The index of the identity in the operator list.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine 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
"""
return
[docs]def 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**
Ham : TYPE(Fqmpoc), inout
initialized during this subroutine.
Rs : TYPE(MPORuleSet), inout
Rule set for simulation
ll : INTEGER, inout
number of sites in the system.
Ops : TYPE(qtensorclist), inout
Operator alphabet contain all operators to build MPO.
Hparams : TYPE(HamiltonianParameters)(*), POINTER, in
Hamiltonian parameters contain coupling etc.
iop : INTEGER, in
The index of the identity in the operator list.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine 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
"""
return
[docs]def 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**
Ham : TYPE(Fmpoc), inout
initialized during this subroutine.
Rs : TYPE(MPORuleSet), inout
Rule set for simulation
ll : INTEGER, inout
number of sites in the system.
Ops : TYPE(tensorlist), inout
Operator alphabet contain all operators to build MPO.
Hparams : TYPE(HamiltonianParameters)(*), POINTER, in
Hamiltonian parameters contain coupling etc.
iop : INTEGER, in
The index of the identity in the operator list.
**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**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def 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**
Ham : TYPE(Fmpoc), inout
initialized during this subroutine.
Rs : TYPE(MPORuleSet), inout
Rule set for simulation
ll : INTEGER, inout
number of sites in the system.
Ops : TYPE(tensorlistc), inout
Operator alphabet contain all operators to build MPO.
Hparams : TYPE(HamiltonianParameters)(*), POINTER, in
Hamiltonian parameters contain coupling etc.
iop : INTEGER, in
The index of the identity in the operator list.
**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**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def 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**
Ham : TYPE(Fqmpoc), inout
initialized during this subroutine.
Rs : TYPE(MPORuleSet), inout
Rule set for simulation
ll : INTEGER, inout
number of sites in the system.
Ops : TYPE(qtensorlist), inout
Operator alphabet contain all operators to build MPO.
Hparams : TYPE(HamiltonianParameters)(*), POINTER, in
Hamiltonian parameters contain coupling etc.
iop : INTEGER, in
The index of the identity in the operator list.
**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**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def 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**
Ham : TYPE(Fqmpoc), inout
initialized during this subroutine.
Rs : TYPE(MPORuleSet), inout
Rule set for simulation
ll : INTEGER, inout
number of sites in the system.
Ops : TYPE(qtensorclist), inout
Operator alphabet contain all operators to build MPO.
Hparams : TYPE(HamiltonianParameters)(*), POINTER, in
Hamiltonian parameters contain coupling etc.
iop : INTEGER, in
The index of the identity in the operator list.
**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**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def 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**
Ham : TYPE(Fmpoc), inout
initialized during this subroutine.
Rs : TYPE(MPORuleSet), inout
Rule set for simulation
ll : INTEGER, inout
number of sites in the system.
Ops : TYPE(tensorlist), inout
Operator alphabet contain all operators to build MPO.
Hparams : TYPE(HamiltonianParameters)(*), POINTER, in
Hamiltonian parameters contain coupling etc.
iop : INTEGER, in
The index of the identity in the operator list.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine 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
"""
return
[docs]def 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**
Ham : TYPE(Fmpoc), inout
initialized during this subroutine.
Rs : TYPE(MPORuleSet), inout
Rule set for simulation
ll : INTEGER, inout
number of sites in the system.
Ops : TYPE(tensorlistc), inout
Operator alphabet contain all operators to build MPO.
Hparams : TYPE(HamiltonianParameters)(*), POINTER, in
Hamiltonian parameters contain coupling etc.
iop : INTEGER, in
The index of the identity in the operator list.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine 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
"""
return
[docs]def 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**
Ham : TYPE(Fqmpoc), inout
initialized during this subroutine.
Rs : TYPE(MPORuleSet), inout
Rule set for simulation
ll : INTEGER, inout
number of sites in the system.
Ops : TYPE(qtensorlist), inout
Operator alphabet contain all operators to build MPO.
Hparams : TYPE(HamiltonianParameters)(*), POINTER, in
Hamiltonian parameters contain coupling etc.
iop : INTEGER, in
The index of the identity in the operator list.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine 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
"""
return
[docs]def 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**
Ham : TYPE(Fqmpoc), inout
initialized during this subroutine.
Rs : TYPE(MPORuleSet), inout
Rule set for simulation
ll : INTEGER, inout
number of sites in the system.
Ops : TYPE(qtensorclist), inout
Operator alphabet contain all operators to build MPO.
Hparams : TYPE(HamiltonianParameters)(*), POINTER, in
Hamiltonian parameters contain coupling etc.
iop : INTEGER, in
The index of the identity in the operator list.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine 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
"""
return
[docs]def 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**
Ham : TYPE(Fmpo), inout
initialized during this subroutine.
Rs : TYPE(MPORuleSet), inout
Rule set for simulation
ll : INTEGER, inout
number of sites in the system.
Ops : TYPE(tensorlist), inout
Operator alphabet contain all operators to build MPO.
Hparams : TYPE(HamiltonianParameters)(*), POINTER, in
Hamiltonian parameters contain coupling etc.
iop : INTEGER, in
The index of the identity in the operator list.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine 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
"""
return
[docs]def 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**
Ham : TYPE(Fmpoc), inout
initialized during this subroutine.
Rs : TYPE(MPORuleSet), inout
Rule set for simulation
ll : INTEGER, inout
number of sites in the system.
Ops : TYPE(tensorlistc), inout
Operator alphabet contain all operators to build MPO.
Hparams : TYPE(HamiltonianParameters)(*), POINTER, in
Hamiltonian parameters contain coupling etc.
iop : INTEGER, in
The index of the identity in the operator list.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine 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
"""
return
[docs]def 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**
Ham : TYPE(Fqmpo), inout
initialized during this subroutine.
Rs : TYPE(MPORuleSet), inout
Rule set for simulation
ll : INTEGER, inout
number of sites in the system.
Ops : TYPE(qtensorlist), inout
Operator alphabet contain all operators to build MPO.
Hparams : TYPE(HamiltonianParameters)(*), POINTER, in
Hamiltonian parameters contain coupling etc.
iop : INTEGER, in
The index of the identity in the operator list.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine 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
"""
return
[docs]def 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**
Ham : TYPE(Fqmpoc), inout
initialized during this subroutine.
Rs : TYPE(MPORuleSet), inout
Rule set for simulation
ll : INTEGER, inout
number of sites in the system.
Ops : TYPE(qtensorclist), inout
Operator alphabet contain all operators to build MPO.
Hparams : TYPE(HamiltonianParameters)(*), POINTER, in
Hamiltonian parameters contain coupling etc.
iop : INTEGER, in
The index of the identity in the operator list.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine 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
"""
return
[docs]def contractmpol_tensor_tensor():
"""
fortran-subroutine - October 2017 (dj, updated)
Do :math:`G_{a i b} = \sum_{k' i'} W_{k k'}^{i i'} F^{k'}_{a i' b}`.
The ``l`` stands for left-moving.
**Arguments**
Tout : TYPE(tensor), inout
On exit, transfer matrix for one index in the row bond dimension
of the MPO.
kk : INTEGER, inout
The index of the row bond dimension in the MPO.
Mat : TYPE(tensor), inout
Matrix representing the MPO on the specific site.
Tin : TYPE(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**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def contractmpol_tensor_tensorc():
"""
fortran-subroutine - October 2017 (dj, updated)
Do :math:`G_{a i b} = \sum_{k' i'} W_{k k'}^{i i'} F^{k'}_{a i' b}`.
The ``l`` stands for left-moving.
**Arguments**
Tout : TYPE(tensorc), inout
On exit, transfer matrix for one index in the row bond dimension
of the MPO.
kk : INTEGER, inout
The index of the row bond dimension in the MPO.
Mat : TYPE(tensor), inout
Matrix representing the MPO on the specific site.
Tin : TYPE(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**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def contractmpol_tensorc_tensorc():
"""
fortran-subroutine - October 2017 (dj, updated)
Do :math:`G_{a i b} = \sum_{k' i'} W_{k k'}^{i i'} F^{k'}_{a i' b}`.
The ``l`` stands for left-moving.
**Arguments**
Tout : TYPE(tensorc), inout
On exit, transfer matrix for one index in the row bond dimension
of the MPO.
kk : INTEGER, inout
The index of the row bond dimension in the MPO.
Mat : TYPE(tensorc), inout
Matrix representing the MPO on the specific site.
Tin : TYPE(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**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def contractmpol_qtensor_qtensor():
"""
fortran-subroutine - October 2017 (dj, updated)
Do :math:`G_{a i b} = \sum_{k' i'} W_{k k'}^{i i'} F^{k'}_{a i' b}`.
The ``l`` stands for left-moving.
**Arguments**
Tout : TYPE(qtensor), inout
On exit, transfer matrix for one index in the row bond dimension
of the MPO.
kk : INTEGER, inout
The index of the row bond dimension in the MPO.
Mat : TYPE(qtensor), inout
Matrix representing the MPO on the specific site.
Tin : TYPE(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**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def contractmpol_qtensor_qtensorc():
"""
fortran-subroutine - October 2017 (dj, updated)
Do :math:`G_{a i b} = \sum_{k' i'} W_{k k'}^{i i'} F^{k'}_{a i' b}`.
The ``l`` stands for left-moving.
**Arguments**
Tout : TYPE(qtensorc), inout
On exit, transfer matrix for one index in the row bond dimension
of the MPO.
kk : INTEGER, inout
The index of the row bond dimension in the MPO.
Mat : TYPE(qtensor), inout
Matrix representing the MPO on the specific site.
Tin : TYPE(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**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def contractmpol_qtensorc_qtensorc():
"""
fortran-subroutine - October 2017 (dj, updated)
Do :math:`G_{a i b} = \sum_{k' i'} W_{k k'}^{i i'} F^{k'}_{a i' b}`.
The ``l`` stands for left-moving.
**Arguments**
Tout : TYPE(qtensorc), inout
On exit, transfer matrix for one index in the row bond dimension
of the MPO.
kk : INTEGER, inout
The index of the row bond dimension in the MPO.
Mat : TYPE(qtensorc), inout
Matrix representing the MPO on the specific site.
Tin : TYPE(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**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def contractmpol_lptn_tensor_tensor():
"""
fortran-subroutine - October 2017 (dj, updated)
Left-moving building of a transfer matrix for an LPTN.
**Arguments**
Tout : TYPE(tensor), inout
On exit, transfer matrix for one index in the row bond dimension
of the MPO.
kk : INTEGER, inout
The index of the row bond dimension in the MPO.
Mat : TYPE(tensor), inout
Matrix representing the MPO on the specific site.
Tin : TYPE(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**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def contractmpol_lptn_tensor_tensorc():
"""
fortran-subroutine - October 2017 (dj, updated)
Left-moving building of a transfer matrix for an LPTN.
**Arguments**
Tout : TYPE(tensorc), inout
On exit, transfer matrix for one index in the row bond dimension
of the MPO.
kk : INTEGER, inout
The index of the row bond dimension in the MPO.
Mat : TYPE(tensor), inout
Matrix representing the MPO on the specific site.
Tin : TYPE(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**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def contractmpol_lptn_tensorc_tensorc():
"""
fortran-subroutine - October 2017 (dj, updated)
Left-moving building of a transfer matrix for an LPTN.
**Arguments**
Tout : TYPE(tensorc), inout
On exit, transfer matrix for one index in the row bond dimension
of the MPO.
kk : INTEGER, inout
The index of the row bond dimension in the MPO.
Mat : TYPE(tensorc), inout
Matrix representing the MPO on the specific site.
Tin : TYPE(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**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def contractmpol_lptn_qtensor_qtensor():
"""
fortran-subroutine - October 2017 (dj, updated)
Left-moving building of a transfer matrix for an LPTN.
**Arguments**
Tout : TYPE(qtensor), inout
On exit, transfer matrix for one index in the row bond dimension
of the MPO.
kk : INTEGER, inout
The index of the row bond dimension in the MPO.
Mat : TYPE(qtensor), inout
Matrix representing the MPO on the specific site.
Tin : TYPE(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**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def contractmpol_lptn_qtensor_qtensorc():
"""
fortran-subroutine - October 2017 (dj, updated)
Left-moving building of a transfer matrix for an LPTN.
**Arguments**
Tout : TYPE(qtensorc), inout
On exit, transfer matrix for one index in the row bond dimension
of the MPO.
kk : INTEGER, inout
The index of the row bond dimension in the MPO.
Mat : TYPE(qtensor), inout
Matrix representing the MPO on the specific site.
Tin : TYPE(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**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def contractmpol_lptn_qtensorc_qtensorc():
"""
fortran-subroutine - October 2017 (dj, updated)
Left-moving building of a transfer matrix for an LPTN.
**Arguments**
Tout : TYPE(qtensorc), inout
On exit, transfer matrix for one index in the row bond dimension
of the MPO.
kk : INTEGER, inout
The index of the row bond dimension in the MPO.
Mat : TYPE(qtensorc), inout
Matrix representing the MPO on the specific site.
Tin : TYPE(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**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def contractmpol_mpdo_tensor_tensor():
"""
fortran-subroutine - October 2017 (dj, updated)
Left-moving building of a transfer matrix for an MPDO.
**Arguments**
Tout : TYPE(tensor), inout
On exit, transfer matrix for one index in the row bond dimension
of the MPO.
kk : INTEGER, inout
The index of the row bond dimension in the MPO.
Mat : TYPE(tensor), inout
Matrix representing the MPO on the specific site.
Tin : TYPE(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**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def contractmpol_mpdo_tensor_tensorc():
"""
fortran-subroutine - October 2017 (dj, updated)
Left-moving building of a transfer matrix for an MPDO.
**Arguments**
Tout : TYPE(tensorc), inout
On exit, transfer matrix for one index in the row bond dimension
of the MPO.
kk : INTEGER, inout
The index of the row bond dimension in the MPO.
Mat : TYPE(tensor), inout
Matrix representing the MPO on the specific site.
Tin : TYPE(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**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def contractmpol_mpdo_tensorc_tensorc():
"""
fortran-subroutine - October 2017 (dj, updated)
Left-moving building of a transfer matrix for an MPDO.
**Arguments**
Tout : TYPE(tensorc), inout
On exit, transfer matrix for one index in the row bond dimension
of the MPO.
kk : INTEGER, inout
The index of the row bond dimension in the MPO.
Mat : TYPE(tensorc), inout
Matrix representing the MPO on the specific site.
Tin : TYPE(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**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def contractmpol_mpdo_qtensor_qtensor():
"""
fortran-subroutine - October 2017 (dj, updated)
Left-moving building of a transfer matrix for an MPDO.
**Arguments**
Tout : TYPE(qtensor), inout
On exit, transfer matrix for one index in the row bond dimension
of the MPO.
kk : INTEGER, inout
The index of the row bond dimension in the MPO.
Mat : TYPE(qtensor), inout
Matrix representing the MPO on the specific site.
Tin : TYPE(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**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def contractmpol_mpdo_qtensor_qtensorc():
"""
fortran-subroutine - October 2017 (dj, updated)
Left-moving building of a transfer matrix for an MPDO.
**Arguments**
Tout : TYPE(qtensorc), inout
On exit, transfer matrix for one index in the row bond dimension
of the MPO.
kk : INTEGER, inout
The index of the row bond dimension in the MPO.
Mat : TYPE(qtensor), inout
Matrix representing the MPO on the specific site.
Tin : TYPE(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**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def contractmpol_mpdo_qtensorc_qtensorc():
"""
fortran-subroutine - October 2017 (dj, updated)
Left-moving building of a transfer matrix for an MPDO.
**Arguments**
Tout : TYPE(qtensorc), inout
On exit, transfer matrix for one index in the row bond dimension
of the MPO.
kk : INTEGER, inout
The index of the row bond dimension in the MPO.
Mat : TYPE(qtensorc), inout
Matrix representing the MPO on the specific site.
Tin : TYPE(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**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def contractmpor_tensor_tensor():
"""
fortran-subroutine - ?? ()
:math:`G_{a i b} = \sum_{k i'} F^k_{a i' b} W_{k k'}^{i i'}` - only used
to define transfermatrices - no FOURtensor verison required.
**Arguments**
G : TYPE(tensor), inout
??
kp : INTEGER, inout
??
W : TYPE(tensor), inout
??
F : TYPE(tensor), POINTER, inout
??
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def contractmpor_tensor_tensorc():
"""
fortran-subroutine - ?? ()
:math:`G_{a i b} = \sum_{k i'} F^k_{a i' b} W_{k k'}^{i i'}` - only used
to define transfermatrices - no FOURtensorc verison required.
**Arguments**
G : TYPE(tensorc), inout
??
kp : INTEGER, inout
??
W : TYPE(tensor), inout
??
F : TYPE(tensorc), POINTER, inout
??
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def contractmpor_tensorc_tensorc():
"""
fortran-subroutine - ?? ()
:math:`G_{a i b} = \sum_{k i'} F^k_{a i' b} W_{k k'}^{i i'}` - only used
to define transfermatrices - no FOURtensorc verison required.
**Arguments**
G : TYPE(tensorc), inout
??
kp : INTEGER, inout
??
W : TYPE(tensorc), inout
??
F : TYPE(tensorc), POINTER, inout
??
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def contractmpor_qtensor_qtensor():
"""
fortran-subroutine - ?? ()
:math:`G_{a i b} = \sum_{k i'} F^k_{a i' b} W_{k k'}^{i i'}` - only used
to define transfermatrices - no FOURqtensor verison required.
**Arguments**
G : TYPE(qtensor), inout
??
kp : INTEGER, inout
??
W : TYPE(qtensor), inout
??
F : TYPE(qtensor), POINTER, inout
??
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def contractmpor_qtensor_qtensorc():
"""
fortran-subroutine - ?? ()
:math:`G_{a i b} = \sum_{k i'} F^k_{a i' b} W_{k k'}^{i i'}` - only used
to define transfermatrices - no FOURqtensorc verison required.
**Arguments**
G : TYPE(qtensorc), inout
??
kp : INTEGER, inout
??
W : TYPE(qtensor), inout
??
F : TYPE(qtensorc), POINTER, inout
??
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def contractmpor_qtensorc_qtensorc():
"""
fortran-subroutine - ?? ()
:math:`G_{a i b} = \sum_{k i'} F^k_{a i' b} W_{k k'}^{i i'}` - only used
to define transfermatrices - no FOURqtensorc verison required.
**Arguments**
G : TYPE(qtensorc), inout
??
kp : INTEGER, inout
??
W : TYPE(qtensorc), inout
??
F : TYPE(qtensorc), POINTER, inout
??
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def build_kraus_first_order_tensorlist():
"""
fortran-subroutine - September 2017 (dj)
Build the first order approximation to the Kraus operators for tensors
without symmetry.
**Arguments**
Kraus : TYPE(tensorc), inout
First two dimensions are the Hilbert space, third dimension is the
Kraus dimension.
Ops : TYPE(tensorlist), inout
List of operators necessary to build Hamiltonian and, here,
Kraus operators from Lindblad operators.
Rs : TYPE(MPORuleSet), inout
Rule set containing the list of Lindblad operators.
Hparams : TYPE(HamiltonianParameters), inout
Coupling for the Lindblad operators.
iop : INTEGER, inout
Position of the identity operator.
xx : INTEGER, inout
Indicates the site for which the Kraus operators are built to access
site-dependent coupling.
dt : REAL, inout
Time step.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def build_kraus_first_order_tensorlistc():
"""
fortran-subroutine - September 2017 (dj)
Build the first order approximation to the Kraus operators for tensors
without symmetry.
**Arguments**
Kraus : TYPE(tensorc), inout
First two dimensions are the Hilbert space, third dimension is the
Kraus dimension.
Ops : TYPE(tensorlistc), inout
List of operators necessary to build Hamiltonian and, here,
Kraus operators from Lindblad operators.
Rs : TYPE(MPORuleSet), inout
Rule set containing the list of Lindblad operators.
Hparams : TYPE(HamiltonianParameters), inout
Coupling for the Lindblad operators.
iop : INTEGER, inout
Position of the identity operator.
xx : INTEGER, inout
Indicates the site for which the Kraus operators are built to access
site-dependent coupling.
dt : REAL, inout
Time step.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def build_kraus_first_order_qtensorlist():
"""
fortran-subroutine - September 2017 (dj)
Build the first order approximation to the Kraus operators for tensors
with symmetry.
**Arguments**
Kraus : TYPE(qtensorc), inout
???
Ops : TYPE(qtensorlist), inout
List of operators necessary to build Hamiltonian and, here,
Kraus operators from Lindblad operators.
Rs : TYPE(MPORuleSet), inout
Rule set containing the list of Lindblad operators.
Hparams : TYPE(HamiltonianParameters), inout
Coupling for the Lindblad operators.
iop : INTEGER, inout
Position of the identity operator.
xx : INTEGER, inout
Indicates the site for which the Kraus operators are built to access
site-dependent coupling.
dt : REAL, inout
Time step.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return
[docs]def build_kraus_first_order_qtensorclist():
"""
fortran-subroutine - September 2017 (dj)
Build the first order approximation to the Kraus operators for tensors
with symmetry.
**Arguments**
Kraus : TYPE(qtensorc), inout
???
Ops : TYPE(qtensorclist), inout
List of operators necessary to build Hamiltonian and, here,
Kraus operators from Lindblad operators.
Rs : TYPE(MPORuleSet), inout
Rule set containing the list of Lindblad operators.
Hparams : TYPE(HamiltonianParameters), inout
Coupling for the Lindblad operators.
iop : INTEGER, inout
Position of the identity operator.
xx : INTEGER, inout
Indicates the site for which the Kraus operators are built to access
site-dependent coupling.
dt : REAL, inout
Time step.
**Source Code**
.. hidden-code-block:: fortran
:label: 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
"""
return