"""
Fortran module qTensors: June 2017 (dj)
Containing basic operations for symmetric tensors as
allocation, reading writing.
**Authors**
* D. Jaschke
* M. L. Wall
**Details**
The following subroutines / functions are defined for the
symmetric tensors.
+---------------------+-------------+---------+---------+
| procedure | include.f90 | mpi.f90 | omp.f90 |
+=====================+=============+=========+=========+
| addproject | X | | |
+---------------------+-------------+---------+---------+
| block | X | | |
+---------------------+-------------+---------+---------+
| block_subhash | X | | |
+---------------------+-------------+---------+---------+
| block2tensor_left | X | | |
+---------------------+-------------+---------+---------+
| block2tensor_right | X | | |
+---------------------+-------------+---------+---------+
| block2tensor_center | X | | |
+---------------------+-------------+---------+---------+
| block2tensor_both | X | | |
+---------------------+-------------+---------+---------+
| conj | X | | |
+---------------------+-------------+---------+---------+
| copy | X | | |
+---------------------+-------------+---------+---------+
| create | X | | |
+---------------------+-------------+---------+---------+
| dagger | X | | |
+---------------------+-------------+---------+---------+
| destroy | X | | |
+---------------------+-------------+---------+---------+
| dot | X | | |
+---------------------+-------------+---------+---------+
| extend | X | | |
+---------------------+-------------+---------+---------+
| gaxpy | X | | |
+---------------------+-------------+---------+---------+
| get_3rddim | TBA | | |
+---------------------+-------------+---------+---------+
| get_contr_idx | X | | |
+---------------------+-------------+---------+---------+
| get_hash | X | | |
+---------------------+-------------+---------+---------+
| get_hash_ii | X | | |
+---------------------+-------------+---------+---------+
| get_sum_idx | ??? | | |
+---------------------+-------------+---------+---------+
| increase_capacity | X | | |
+---------------------+-------------+---------+---------+
| is_set | X | | |
+---------------------+-------------+---------+---------+
| kron | X | | |
+---------------------+-------------+---------+---------+
| maxlineardim | X | | |
+---------------------+-------------+---------+---------+
| maxvalue | X | | |
+---------------------+-------------+---------+---------+
| norm | X | | |
+---------------------+-------------+---------+---------+
| permute_qnumbers | X | | |
+---------------------+-------------+---------+---------+
| perturb | X | | |
+---------------------+-------------+---------+---------+
| omp_addproject | | | TBA |
+---------------------+-------------+---------+---------+
| omp_conj | | | X |
+---------------------+-------------+---------+---------+
| omp_dagger | | | TBA |
+---------------------+-------------+---------+---------+
| omp_dot | | | X |
+---------------------+-------------+---------+---------+
| omp_gaxpy | | | TBA |
+---------------------+-------------+---------+---------+
| omp_norm | | | X |
+---------------------+-------------+---------+---------+
| omp_project | | | TBA |
+---------------------+-------------+---------+---------+
| omp_randomize | | | ??? |
+---------------------+-------------+---------+---------+
| omp_scale | | | X |
+---------------------+-------------+---------+---------+
| omp_transposed | | | TBA |
+---------------------+-------------+---------+---------+
| par_recv | | X | |
+---------------------+-------------+---------+---------+
| par_send | | X | |
+---------------------+-------------+---------+---------+
| print | X | | |
+---------------------+-------------+---------+---------+
| project | X | | |
+---------------------+-------------+---------+---------+
| randomize | X | | |
+---------------------+-------------+---------+---------+
| rank | X | | |
+---------------------+-------------+---------+---------+
| read | X | | |
+---------------------+-------------+---------+---------+
| scale | X | | |
+---------------------+-------------+---------+---------+
| set_hash | X | | |
+---------------------+-------------+---------+---------+
| size | X | | |
+---------------------+-------------+---------+---------+
| skim | X | | |
+---------------------+-------------+---------+---------+
| sort | X | | |
+---------------------+-------------+---------+---------+
| trace | X | | |
+---------------------+-------------+---------+---------+
| transposed | X | | |
+---------------------+-------------+---------+---------+
| write | X | | |
+---------------------+-------------+---------+---------+
"""
[docs]def sumq():
"""
fortran-function - April 2016 (updated dj)
Group element addition for the corresponding symmetry.
Return type is INTEGER(\*) = q1 + q2
**Arguments**
q1 : INTEGER(\*), in
charge number on links
q2 : INTEGER(\*), in
charge number on links
nqs : INTEGER(2), in
Number of U(1) and Z2 symmetries.
**Details**
For U(1) symmetry, the group element is ordinary addition
applied to the first nqns quantum numbers. For the quantum numbers
(nqns+1) to (nqns+npns) the group element addition is addition modulo
2 (Z2-symmetry). (Template defined in qTensors_template.f90)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function sumq(q1, q2, nqs)
integer, intent(in) :: q1(:), q2(:)
integer, dimension(2), intent(in) :: nqs
integer :: sumq(size(q1))
! Local variables
! ---------------
! for looping
integer :: jj
sumq = q1 + q2
! To-do: that seems wrong for more than one quantum number
jj = 0
do while(jj < size(q1))
! No action on U(1) quantum numbers
jj = jj + nqs(1)
! Modulo 2 for Z2 quantum numbers
sumq(jj + 1:jj + nqs(2)) = mod(sumq(jj + 1:jj + nqs(2)), 2)
jj = jj + nqs(2)
end do
end function sumq
"""
return
[docs]def prime_hash():
"""
fortran-function - ?? ()
Hash function for multiple quantum numbers using the square root of
primes hashing function. The return value is a real/double precision.
**Arguments**
q : INTEGER(*), in
Array of size nqs * dim, where nqs is the number of conserved quantum
numbers and dim is the number of dimension of the underlying tensor.
indices : INTEGER(*), in
Selecting the indices of the tensor to be hashed. From each index all
quantum numbers are considered. Example: hash(A%data(i)%q,(/1/))
hashes the tensor A_{\alpha \beta}^{i}} according to its first
dimension.
nqs : INTEGER(2), in
Saves number of U(1) and Z(2) symmetries.
**Details**
(Template defined in qTensors_template.f90)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function prime_hash(qq, indices, nqs) result(hash)
integer, intent(in) :: qq(:), indices(:)
integer, dimension(2), intent(in) :: nqs
real(KIND=rKind) :: hash
! Local variables
! ---------------
! for looping over the prime numbers
integer :: kk
! last position in q of the previous index
integer :: stride
! for looping over the index size (ii) and # of symmetries (jj)
integer :: ii, jj
! sum of nqs
integer :: snqs
hash = 0.0_rkInd
kk = 0
snqs = sum(nqs)
do ii = 1, size(indices)
stride = (indices(ii) - 1) * snqs
!hash = hash + sum(qq(stride + 1:stride + snqs) * Primes%elem(kk + 1:kk + snqs))
!kk = kk + snqs
do jj = 1, snqs
kk = kk + 1
hash = hash + qq(stride + jj) * primes(kk)
end do
end do
end function prime_hash
"""
return
[docs]def SetupPrimeRoots():
"""
fortran-subroutine - ?? (mlw)
Compute the square roots of the first N primes and store in global
vector primes. This initializes the square root of primes hash
function. The routine uses a simple sieve to check the current prime
against all others previously computed.
**Arguments**
nn : INTEGER, in
Find first nn prime numbers and setup their roots.
**Details**
(Template defined in qTensors_template.f90)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine SetupPrimeRoots(nn, errst)
!use, qTensors : Primes
integer, intent(in) :: nn
integer, intent(out), optional :: errst
! Local variables
! ---------------
! checks if integer can be divided by a previous prime number
logical :: accept
! for looping / indexing
integer :: ii, jj, ip
! Array to store prime numbers
integer, allocatable :: intprimes(:)
!if(present(errst)) errst = 0
allocate(intprimes(nn))
ii = 1
jj = 2
intprimes(ii) = jj
ii = ii + 1
do while(ii <= nn)
jj = jj + 1
accept = .true.
do ip = 1, (ii - 1)
! Check if the current number is evenly divisible by a prime
! less than it
if(mod(jj, intprimes(ip)) == 0) then
accept = .false.
exit
end if
end do
if(accept) then
intprimes(ii) = jj
ii = ii + 1
end if
end do
allocate(primes(nn))
primes = sqrt(1.0_rKind * intprimes)
deallocate(intprimes)
end subroutine SetupPrimeRoots
"""
return
[docs]def cleanup_qtensors():
"""
fortran-subroutine - March 2016 (dj)
Deallocate the vector with prime numbers.
**Details**
(Template defined in qTensors_template.f90)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine cleanup_qtensors()
deallocate(primes)
end subroutine cleanup_qtensors
"""
return
[docs]def AddProject_qtensor():
"""
fortran-subroutine - March 2016 (updated dj)
Apply the projector P to A and add to B, where P is defined as
:math:`P = 1 - \sum_{\\alpha} | psiProjs_{\\alpha}> <psiProjs_{\\alpha}|`.
**Arguments**
Bb : TYPE(qtensor), inout
Add projection of A to this tensor.
Aa : TYPE(qtensor), in
Get projection of this tensor and add to Bb
PsiProjs : TYPE(qtensor)(\*), inout
Array of tensors defining the projector.
**Details**
Used in orthogonalizing an MPS against another set of MPSs.
(template defined in qTensors_include.f90)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine AddProject_qtensor(Bb, Aa, PsiProjs, errst)
type(qtensor), intent(inout) :: Bb
type(qtensor), intent(inout) :: Aa
type(qtensor), pointer, intent(inout) :: PsiProjs(:)
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: jj
! overlap of two tensors (dot product)
real(KIND=rKind) :: proj
!if(present(errst)) errst = 0
! For done we can use underlying BLAS subroutines
call gaxpy(Bb, done, Aa, errst=errst)
!if(prop_error('AddProject_qtensor: failed gaxpy (1).', &
! errst=errst)) return
do jj = 1, size(PsiProjs)
proj = - dot(PsiProjs(jj), Aa)
call gaxpy(Bb, Proj, PsiProjs(jj), errst=errst)
!if(prop_error('AddProject_qtensor: failed gaxpy (2).', &
! errst=errst)) return
end do
end subroutine AddProject_qtensor
"""
return
[docs]def AddProject_qtensorc():
"""
fortran-subroutine - March 2016 (updated dj)
Apply the projector P to A and add to B, where P is defined as
:math:`P = 1 - \sum_{\\alpha} | psiProjs_{\\alpha}> <psiProjs_{\\alpha}|`.
**Arguments**
Bb : TYPE(qtensorc), inout
Add projection of A to this tensor.
Aa : TYPE(qtensorc), in
Get projection of this tensor and add to Bb
PsiProjs : TYPE(qtensorc)(\*), inout
Array of tensors defining the projector.
**Details**
Used in orthogonalizing an MPS against another set of MPSs.
(template defined in qTensors_include.f90)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine AddProject_qtensorc(Bb, Aa, PsiProjs, errst)
type(qtensorc), intent(inout) :: Bb
type(qtensorc), intent(inout) :: Aa
type(qtensorc), pointer, intent(inout) :: PsiProjs(:)
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: jj
! overlap of two tensors (dot product)
complex(KIND=rKind) :: proj
!if(present(errst)) errst = 0
! For zone we can use underlying BLAS subroutines
call gaxpy(Bb, zone, Aa, errst=errst)
!if(prop_error('AddProject_qtensorc: failed gaxpy (1).', &
! errst=errst)) return
do jj = 1, size(PsiProjs)
proj = - dot(PsiProjs(jj), Aa)
call gaxpy(Bb, Proj, PsiProjs(jj), errst=errst)
!if(prop_error('AddProject_qtensorc: failed gaxpy (2).', &
! errst=errst)) return
end do
end subroutine AddProject_qtensorc
"""
return
[docs]def add_dummylink_qtensor():
"""
fortran-subroutine - October 2017 (dj)
Add a dummy link to a tensor. By default quantum numbers 0.
**Arguments**
Qt : TYPE(qtensor), inout
Add a dummy link of dimenions one to the tensor.
idx : INTEGER, in
Position of the dummy link in the modified tensor.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine add_dummylink_qtensor(Qt, idx, errst)
type(qtensor), intent(inout) :: Qt
integer, intent(in) :: idx
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! total number of quantum numbers
integer :: snqs
! size for new quantum numbers
integer :: nq
! temporary quantum numbers
integer, dimension(:), allocatable :: qq
! indices to copy quantum numbers
integer :: q2, q3, p3
!if(present(errst)) errst = 0
if(Qt%nb == 0) return
snqs = sum(Qt%nqs)
nq = snqs * (rank(Qt) + 1)
allocate(qq(nq))
qq = 0
! Indices in new array
q2 = snqs * (idx - 1)
q3 = snqs * idx + 1
! Different indices in old array
p3 = q2 + 1
do ii = 1, Qt%nb
call add_dummylink(Qt%Data(ii)%Tens, idx, errst=errst)
!if(prop_error('add_dummylink_qtensor : add_'//&
! 'dummylink failed.', 'qTensors_include.f90:384', &
! errst=errst)) return
qq(:q2) = Qt%Data(ii)%qq(:q2)
qq(q3:) = Qt%Data(ii)%qq(p3:)
deallocate(Qt%Data(ii)%qq)
allocate(Qt%Data(ii)%qq(nq))
Qt%Data(ii)%qq = qq
end do
deallocate(qq)
end subroutine add_dummylink_qtensor
"""
return
[docs]def add_dummylink_qtensorc():
"""
fortran-subroutine - October 2017 (dj)
Add a dummy link to a tensor. By default quantum numbers 0.
**Arguments**
Qt : TYPE(qtensorc), inout
Add a dummy link of dimenions one to the tensor.
idx : INTEGER, in
Position of the dummy link in the modified tensor.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine add_dummylink_qtensorc(Qt, idx, errst)
type(qtensorc), intent(inout) :: Qt
integer, intent(in) :: idx
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! total number of quantum numbers
integer :: snqs
! size for new quantum numbers
integer :: nq
! temporary quantum numbers
integer, dimension(:), allocatable :: qq
! indices to copy quantum numbers
integer :: q2, q3, p3
!if(present(errst)) errst = 0
if(Qt%nb == 0) return
snqs = sum(Qt%nqs)
nq = snqs * (rank(Qt) + 1)
allocate(qq(nq))
qq = 0
! Indices in new array
q2 = snqs * (idx - 1)
q3 = snqs * idx + 1
! Different indices in old array
p3 = q2 + 1
do ii = 1, Qt%nb
call add_dummylink(Qt%Data(ii)%Tens, idx, errst=errst)
!if(prop_error('add_dummylink_qtensorc : add_'//&
! 'dummylink failed.', 'qTensors_include.f90:384', &
! errst=errst)) return
qq(:q2) = Qt%Data(ii)%qq(:q2)
qq(q3:) = Qt%Data(ii)%qq(p3:)
deallocate(Qt%Data(ii)%qq)
allocate(Qt%Data(ii)%qq(nq))
Qt%Data(ii)%qq = qq
end do
deallocate(qq)
end subroutine add_dummylink_qtensorc
"""
return
[docs]def block_qtensor():
"""
fortran-subroutine - April 2017 (dj, based on mlw)
Build the blocks for a bipartition of links prior to a decomposition.
**Arguments**
Tens : type(qtensor), inout
This tensor should be decomposed. Might be changed on exit,
e.g. due to permutations.
idxl : INTEGER(\*), in
Contains the indices of the links going to the rows.
idxr : INTEGER(\*), in
Contains the indices of the links going to the columns.
Mats : TYPE(tensorlist), inout
Contains the matrices to be decomposed back into tensors.
Deallocated on exit.
nunique : INTEGER, out
On exit the number of unique blocks corresponding to the number
of matrices in Mats.
Lmap : TYPE(VECTOR_INT)(\*), inout
Map for finding a representative of each irrep for the rows
to retrieve the quantum numbers. Allocated during this suboutine.
Rmap : TYPE(VECTOR_INT)(\*), inout
Map for finding a representative of each irrep for the columns
to retrieve the quantum numbers. Allocated during this subroutine.
Rowcut : TYPE(VECTOR_INT)(\*), inout
Contains the first and last index of rows for each irreps.
Allocated during this subroutine.
Colcut : TYPE(VECTOR_INT)(\*), inout
Contains the first and last index of columns for each irreps.
Allocated during this subroutine.
nts_row : INTEGER(\*), inout
Contains the number of irreps in each block for the rows.
Allocated during this subroutine.
nts_col : INTEGER(\*), inout
Contains the number of irreps in each block for the columns.
Allocated during this subroutine.
idxhash : INTEGER(\*), in
Sorting the hashes for the splitting. Allocated during this
subroutine.
ham : LOGICAL, in
If present (independent of value), the hash is build based
on all links on the left and respectively right side. This
allows us to split 2-site Hamiltonians.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine block_qtensor(Tens, idxl, idxr, Mats, nunique, Lmap, Rmap, &
Rowcut, Colcut, nts_row, nts_col, deghash, &
idxhash, ham, errst)
type(qtensor), intent(inout) :: Tens
integer, dimension(:), intent(in) :: idxl, idxr
type(tensorlist), intent(inout) :: Mats
integer, intent(out) :: nunique
type(vector_int), dimension(:), allocatable, intent(inout) :: Lmap
type(vector_int), dimension(:), allocatable, intent(inout) :: Rmap
type(vector_int), dimension(:), allocatable, intent(inout) :: Rowcut
type(vector_int), dimension(:), allocatable, intent(inout) :: Colcut
integer, dimension(:), allocatable, intent(inout) :: nts_row, nts_col, deghash
integer, dimension(:), allocatable, intent(inout) :: idxhash
logical, intent(in), optional :: ham
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! indices from backmapping
integer :: j1, j2
! lower/upper bound of slice
integer :: r1, r2, c1, c2
! dimension of legs on the left/right
integer :: nl, nr
! Permutation before building blocks
integer, dimension(:), allocatable :: perm
! Array of hashes of all subtensors
real(KIND=rKIND), dimension(:), allocatable :: allhash
! For degenerate sorting (all others are necessary for the calling
! routine)
real(KIND=rKIND), dimension(:), allocatable :: littlehash
! number of blocks
integer :: nt
! Mapping the index inside a block to the degenerate subblock
! (only needed for constructing matrices)
integer, dimension(:), allocatable :: lbackmap, rbackmap
! temporary dimension left/right
integer :: dml, dmr
! stride to access degenerate blocks
integer :: stride
! total number of quantum numbers / sum of quantum numbers
integer :: snqs
integer, dimension(:), allocatable :: qq
! temporary array for matrix
real(KIND=rKIND), dimension(:, :), allocatable :: mat
!if(present(errst)) errst = 0
! To-do: check size(idxl) < 3, size(idxr) < 3
! Permute legs of tensors
! -----------------------
nl = size(idxl)
nr = size(idxr)
allocate(perm(nl + nr))
perm(:nl) = idxl
perm(nl + 1:) = idxr
call transposed(Tens, perm, errst=errst)
!if(prop_error('qr_block_qtensor: transpose failed', &
! errst=errst)) return
deallocate(perm)
! Collect possible hashes and sort them
! -------------------------------------
allocate(allhash(Tens%nb), littlehash(Tens%nb), idxhash(Tens%nb), &
deghash(Tens%nb + 1))
snqs = sum(Tens%nqs)
allocate(qq(snqs))
do ii = 1, Tens%nb
qq = Tens%Data(ii)%qq(:snqs)
do jj = 2, nl
qq = sumq(qq, Tens%Data(ii)%qq((jj - 1) * snqs + 1:jj * snqs), Tens%nqs)
end do
allhash(ii) = prime_hash(qq, [1], Tens%nqs)
end do
deallocate(qq)
call ascending_hsort(allhash, littlehash, idxhash, nunique, deghash)
call create(Mats, nunique)
allocate(rowcut(nunique), colcut(nunique), &
nts_row(nunique), nts_col(nunique), &
Lmap(nunique), Rmap(nunique))
stride = 0
do ii = 1, nunique
! How many tensors build this block?
nt = deghash(ii + 1) - deghash(ii)
if(present(ham)) then
call block_subhash(Tens, stride, nt, idxl, -nl, idxhash, &
nts_row(ii), dml, rowcut(ii)%elem, &
Lmap(ii)%elem, lbackmap)
call block_subhash(Tens, stride, nt, idxr, nl, idxhash, &
nts_col(ii), dmr, colcut(ii)%elem, &
Rmap(ii)%elem, rbackmap)
else
call block_subhash(Tens, stride, nt, [1], -nl, idxhash, &
nts_row(ii), dml, rowcut(ii)%elem, &
Lmap(ii)%elem, lbackmap)
call block_subhash(Tens, stride, nt, [nl + nr], nl, idxhash, &
nts_col(ii), dmr, colcut(ii)%elem, &
Rmap(ii)%elem, rbackmap)
end if
allocate(mat(dml, dmr))
mat = 0.0_rKind
call create(Mats%Li(ii), [dml, dmr])
do jj = 1, nt
j1 = lbackmap(jj)
r1 = rowcut(ii)%elem(j1) + 1
r2 = rowcut(ii)%elem(j1 + 1)
j2 = rbackmap(jj)
c1 = colcut(ii)%elem(j2) + 1
c2 = colcut(ii)%elem(j2 + 1)
kk = idxhash(stride + jj)
!if(r2 - r1 + 1 /= product(Tens%Data(kk)%Tens%dl(:nl))) then
! errst = raise_error('block_qtensor : dim '//&
! 'mismatch r.', 99, errst=errst)
! return
!end if
!if(c2 - c1 + 1 /= product(Tens%Data(kk)%Tens%dl(nl + 1:))) then
! errst = raise_error('block_qtensor : dim '//&
! 'mismatch c.', 99, errst=errst)
! return
!end if
mat(r1:r2, c1:c2) = mat(r1:r2, c1:c2) &
+ reshape(Tens%Data(kk)%Tens%elem, &
[r2 - r1 + 1, c2 - c1 + 1])
end do
Mats%Li(ii)%elem = reshape(mat, [dml * dmr])
deallocate(mat, lbackmap, rbackmap)
stride = stride + nt
end do
end subroutine block_qtensor
"""
return
[docs]def block_qtensorc():
"""
fortran-subroutine - April 2017 (dj, based on mlw)
Build the blocks for a bipartition of links prior to a decomposition.
**Arguments**
Tens : type(qtensorc), inout
This tensor should be decomposed. Might be changed on exit,
e.g. due to permutations.
idxl : INTEGER(\*), in
Contains the indices of the links going to the rows.
idxr : INTEGER(\*), in
Contains the indices of the links going to the columns.
Mats : TYPE(tensorlistc), inout
Contains the matrices to be decomposed back into tensors.
Deallocated on exit.
nunique : INTEGER, out
On exit the number of unique blocks corresponding to the number
of matrices in Mats.
Lmap : TYPE(VECTOR_INT)(\*), inout
Map for finding a representative of each irrep for the rows
to retrieve the quantum numbers. Allocated during this suboutine.
Rmap : TYPE(VECTOR_INT)(\*), inout
Map for finding a representative of each irrep for the columns
to retrieve the quantum numbers. Allocated during this subroutine.
Rowcut : TYPE(VECTOR_INT)(\*), inout
Contains the first and last index of rows for each irreps.
Allocated during this subroutine.
Colcut : TYPE(VECTOR_INT)(\*), inout
Contains the first and last index of columns for each irreps.
Allocated during this subroutine.
nts_row : INTEGER(\*), inout
Contains the number of irreps in each block for the rows.
Allocated during this subroutine.
nts_col : INTEGER(\*), inout
Contains the number of irreps in each block for the columns.
Allocated during this subroutine.
idxhash : INTEGER(\*), in
Sorting the hashes for the splitting. Allocated during this
subroutine.
ham : LOGICAL, in
If present (independent of value), the hash is build based
on all links on the left and respectively right side. This
allows us to split 2-site Hamiltonians.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine block_qtensorc(Tens, idxl, idxr, Mats, nunique, Lmap, Rmap, &
Rowcut, Colcut, nts_row, nts_col, deghash, &
idxhash, ham, errst)
type(qtensorc), intent(inout) :: Tens
integer, dimension(:), intent(in) :: idxl, idxr
type(tensorlistc), intent(inout) :: Mats
integer, intent(out) :: nunique
type(vector_int), dimension(:), allocatable, intent(inout) :: Lmap
type(vector_int), dimension(:), allocatable, intent(inout) :: Rmap
type(vector_int), dimension(:), allocatable, intent(inout) :: Rowcut
type(vector_int), dimension(:), allocatable, intent(inout) :: Colcut
integer, dimension(:), allocatable, intent(inout) :: nts_row, nts_col, deghash
integer, dimension(:), allocatable, intent(inout) :: idxhash
logical, intent(in), optional :: ham
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! indices from backmapping
integer :: j1, j2
! lower/upper bound of slice
integer :: r1, r2, c1, c2
! dimension of legs on the left/right
integer :: nl, nr
! Permutation before building blocks
integer, dimension(:), allocatable :: perm
! Array of hashes of all subtensors
real(KIND=rKIND), dimension(:), allocatable :: allhash
! For degenerate sorting (all others are necessary for the calling
! routine)
real(KIND=rKIND), dimension(:), allocatable :: littlehash
! number of blocks
integer :: nt
! Mapping the index inside a block to the degenerate subblock
! (only needed for constructing matrices)
integer, dimension(:), allocatable :: lbackmap, rbackmap
! temporary dimension left/right
integer :: dml, dmr
! stride to access degenerate blocks
integer :: stride
! total number of quantum numbers / sum of quantum numbers
integer :: snqs
integer, dimension(:), allocatable :: qq
! temporary array for matrix
complex(KIND=rKIND), dimension(:, :), allocatable :: mat
!if(present(errst)) errst = 0
! To-do: check size(idxl) < 3, size(idxr) < 3
! Permute legs of tensors
! -----------------------
nl = size(idxl)
nr = size(idxr)
allocate(perm(nl + nr))
perm(:nl) = idxl
perm(nl + 1:) = idxr
call transposed(Tens, perm, errst=errst)
!if(prop_error('qr_block_qtensorc: transpose failed', &
! errst=errst)) return
deallocate(perm)
! Collect possible hashes and sort them
! -------------------------------------
allocate(allhash(Tens%nb), littlehash(Tens%nb), idxhash(Tens%nb), &
deghash(Tens%nb + 1))
snqs = sum(Tens%nqs)
allocate(qq(snqs))
do ii = 1, Tens%nb
qq = Tens%Data(ii)%qq(:snqs)
do jj = 2, nl
qq = sumq(qq, Tens%Data(ii)%qq((jj - 1) * snqs + 1:jj * snqs), Tens%nqs)
end do
allhash(ii) = prime_hash(qq, [1], Tens%nqs)
end do
deallocate(qq)
call ascending_hsort(allhash, littlehash, idxhash, nunique, deghash)
call create(Mats, nunique)
allocate(rowcut(nunique), colcut(nunique), &
nts_row(nunique), nts_col(nunique), &
Lmap(nunique), Rmap(nunique))
stride = 0
do ii = 1, nunique
! How many tensors build this block?
nt = deghash(ii + 1) - deghash(ii)
if(present(ham)) then
call block_subhash(Tens, stride, nt, idxl, -nl, idxhash, &
nts_row(ii), dml, rowcut(ii)%elem, &
Lmap(ii)%elem, lbackmap)
call block_subhash(Tens, stride, nt, idxr, nl, idxhash, &
nts_col(ii), dmr, colcut(ii)%elem, &
Rmap(ii)%elem, rbackmap)
else
call block_subhash(Tens, stride, nt, [1], -nl, idxhash, &
nts_row(ii), dml, rowcut(ii)%elem, &
Lmap(ii)%elem, lbackmap)
call block_subhash(Tens, stride, nt, [nl + nr], nl, idxhash, &
nts_col(ii), dmr, colcut(ii)%elem, &
Rmap(ii)%elem, rbackmap)
end if
allocate(mat(dml, dmr))
mat = 0.0_rKind
call create(Mats%Li(ii), [dml, dmr])
do jj = 1, nt
j1 = lbackmap(jj)
r1 = rowcut(ii)%elem(j1) + 1
r2 = rowcut(ii)%elem(j1 + 1)
j2 = rbackmap(jj)
c1 = colcut(ii)%elem(j2) + 1
c2 = colcut(ii)%elem(j2 + 1)
kk = idxhash(stride + jj)
!if(r2 - r1 + 1 /= product(Tens%Data(kk)%Tens%dl(:nl))) then
! errst = raise_error('block_qtensorc : dim '//&
! 'mismatch r.', 99, errst=errst)
! return
!end if
!if(c2 - c1 + 1 /= product(Tens%Data(kk)%Tens%dl(nl + 1:))) then
! errst = raise_error('block_qtensorc : dim '//&
! 'mismatch c.', 99, errst=errst)
! return
!end if
mat(r1:r2, c1:c2) = mat(r1:r2, c1:c2) &
+ reshape(Tens%Data(kk)%Tens%elem, &
[r2 - r1 + 1, c2 - c1 + 1])
end do
Mats%Li(ii)%elem = reshape(mat, [dml * dmr])
deallocate(mat, lbackmap, rbackmap)
stride = stride + nt
end do
end subroutine block_qtensorc
"""
return
[docs]def block_subhash_qtensor():
"""
fortran-subroutine - April 2017 (dj)
Build the subhash of all tensors with the same quantum number on
the link of the splitting.
**Arguments**
Tens : TYPE(qtensor), in
This tensor should be decomposed.
stride : INTEGER, in
Used to identify the offset after sorting the complete hash.
nt : INTEGER, in
Number of tensors in this subblock to be sorted.
idx : INTEGER(\*), in
Contains the link(s) to be hashed for the subblock.
nl : INTEGER, in
Number of indices building the left bipartitions for splitting
the tensor.
idxhash : INTEGER(\*), in
Sorting the hashes for the splitting. Allocated during this
subroutine.
nuniqueii : INTEGER, out
Number of unique hashes in the subblock.
dim : INTEGER, out
The dimension of a subblock is the number of rows (left
bipartition) or number of columns (right bipartition).
cutii : INTEGER(\*), inout
Contains the first and last entry of each irrep, where the ii-th
irrep is in cutii(ii) + 1:cutii(ii + 1). Allocated during this
subroutine.
map : INTEGER(\*), inout
Contains one representative (example) of each irrep to retrieve
the quantum numbers at the end. Allocated during this subroutine.
bmap : INTEGER(\*), inout
Returns the block when inputting the index. Allocated during
this subroutine.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine block_subhash_qtensor(Tens, stride, nt, idx, nl, idxhash, &
nuniqueii, dim, cutii, map, bmap)
type(qtensor), intent(in) :: Tens
integer, intent(in) :: stride, nt
integer, dimension(:), intent(in) :: idx
integer, intent(in) :: nl
integer, dimension(:), intent(in) :: idxhash
integer, intent(out) :: nuniqueii, dim
integer, dimension(:), allocatable, intent(inout) :: cutii, map, bmap
! Local variables
! ---------------
! looping / indices
integer :: jj, kk
! temporary index from search
integer :: tmpjj
! for degenerate sorting
integer, dimension(:), allocatable :: subidx, subdeg
real(KIND=rKIND), dimension(:), allocatable :: subhash, sublittle
allocate(subhash(nt), sublittle(nt), subidx(nt), subdeg(nt + 1))
do jj = 1, nt
subhash(jj) = get_hash(Tens, idx, idxhash(stride + jj))
end do
call ascending_hsort(subhash, sublittle, subidx, nuniqueii, subdeg)
! Number of rows in block
allocate(cutii(nuniqueii + 1), map(nuniqueii), bmap(nt))
cutii(1) = 0
dim = 0
do jj = 1, nuniqueii
! Dimensions and cut of rows/cols
tmpjj = idxhash(stride + subidx(subdeg(jj) + 1))
if(nl < 0) then
dim = dim + product(Tens%Data(tmpjj)%Tens%dl(:-nl))
else
dim = dim + product(Tens%Data(tmpjj)%Tens%dl(nl + 1:))
end if
cutii(jj + 1) = dim
! mapping
map(jj) = subidx(subdeg(jj) + 1)
do kk = subdeg(jj) + 1, subdeg(jj + 1)
bmap(subidx(kk)) = jj
end do
end do
deallocate(subhash, sublittle, subidx, subdeg)
end subroutine block_subhash_qtensor
"""
return
[docs]def block_subhash_qtensorc():
"""
fortran-subroutine - April 2017 (dj)
Build the subhash of all tensors with the same quantum number on
the link of the splitting.
**Arguments**
Tens : TYPE(qtensorc), in
This tensor should be decomposed.
stride : INTEGER, in
Used to identify the offset after sorting the complete hash.
nt : INTEGER, in
Number of tensors in this subblock to be sorted.
idx : INTEGER(\*), in
Contains the link(s) to be hashed for the subblock.
nl : INTEGER, in
Number of indices building the left bipartitions for splitting
the tensor.
idxhash : INTEGER(\*), in
Sorting the hashes for the splitting. Allocated during this
subroutine.
nuniqueii : INTEGER, out
Number of unique hashes in the subblock.
dim : INTEGER, out
The dimension of a subblock is the number of rows (left
bipartition) or number of columns (right bipartition).
cutii : INTEGER(\*), inout
Contains the first and last entry of each irrep, where the ii-th
irrep is in cutii(ii) + 1:cutii(ii + 1). Allocated during this
subroutine.
map : INTEGER(\*), inout
Contains one representative (example) of each irrep to retrieve
the quantum numbers at the end. Allocated during this subroutine.
bmap : INTEGER(\*), inout
Returns the block when inputting the index. Allocated during
this subroutine.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine block_subhash_qtensorc(Tens, stride, nt, idx, nl, idxhash, &
nuniqueii, dim, cutii, map, bmap)
type(qtensorc), intent(in) :: Tens
integer, intent(in) :: stride, nt
integer, dimension(:), intent(in) :: idx
integer, intent(in) :: nl
integer, dimension(:), intent(in) :: idxhash
integer, intent(out) :: nuniqueii, dim
integer, dimension(:), allocatable, intent(inout) :: cutii, map, bmap
! Local variables
! ---------------
! looping / indices
integer :: jj, kk
! temporary index from search
integer :: tmpjj
! for degenerate sorting
integer, dimension(:), allocatable :: subidx, subdeg
real(KIND=rKIND), dimension(:), allocatable :: subhash, sublittle
allocate(subhash(nt), sublittle(nt), subidx(nt), subdeg(nt + 1))
do jj = 1, nt
subhash(jj) = get_hash(Tens, idx, idxhash(stride + jj))
end do
call ascending_hsort(subhash, sublittle, subidx, nuniqueii, subdeg)
! Number of rows in block
allocate(cutii(nuniqueii + 1), map(nuniqueii), bmap(nt))
cutii(1) = 0
dim = 0
do jj = 1, nuniqueii
! Dimensions and cut of rows/cols
tmpjj = idxhash(stride + subidx(subdeg(jj) + 1))
if(nl < 0) then
dim = dim + product(Tens%Data(tmpjj)%Tens%dl(:-nl))
else
dim = dim + product(Tens%Data(tmpjj)%Tens%dl(nl + 1:))
end if
cutii(jj + 1) = dim
! mapping
map(jj) = subidx(subdeg(jj) + 1)
do kk = subdeg(jj) + 1, subdeg(jj + 1)
bmap(subidx(kk)) = jj
end do
end do
deallocate(subhash, sublittle, subidx, subdeg)
end subroutine block_subhash_qtensorc
"""
return
[docs]def block2tensor_left_qtensor():
"""
fortran-subroutine - April 2017 (dj, based on mlw)
Rewrite the matrices of a decomposition again as tensor.
**Arguments**
Ltens : TYPE(qtensor), inout
The decomposed tensor is stored here.
Tens : TYPE(qtensor), in
The original tensor which was decomposed. It is required to
track the quantum numbers.
Mats : TYPE(tensorlist), inout
Contains the matrices to be decomposed back into tensors.
Deallocated on exit.
nl : INTEGER, in
Number of indices encoded in the rows.
nunique : INTEGER, in
Number of unique blocks corresponding to the number of matrices
in Mats.
chi : INTEGER, in
Total bond dimension for last index.
Lmap : TYPE(VECTOR_INT)(\*), inout
Map for finding a representative of each irrep to retrieve
the quantum numbers. Deallocate on exit.
Rowcut : TYPE(VECTOR_INT)(\*), inout
Contains the first and last index of rows for each irreps.
Deallocated on exit.
nts_row : INTEGER(\*), inout
Contains the number of irreps in each block. Deallocated on
exit.
idxhash : INTEGER(\*), in
Sorting the hashes for the splitting.
lamblk : INTEGER(\*), OPTIONAL, in
Contains the block for the singular value at the i-th position.
lamind : INTEGER(\*), OPTIONAL, in
Contains the indices to sort the array of singular values.
caller : CHARACTER, OPTIONAL, in
'S' for singular value decomposition and 'E' for eigenvalue
decomposition. The first has descending values, the latter
ascending information. So when truncation is used, this flag
determines which eigenvectors belong to the truncated values.
**Details**
(template defined in qTensors_include.f90)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine block2tensor_left_qtensor(Ltens, Tens, Mats, nl, &
nunique, chi, Lmap, Rowcut, &
nts_row, deghash, idxhash, lamblk, &
lamind, caller, errst)
type(qtensor), intent(inout) :: Ltens
type(qtensor), intent(in) :: Tens
type(tensorlist), intent(inout) :: Mats
integer, intent(in) :: nl, nunique, chi
type(vector_int), dimension(:), allocatable, intent(inout) :: Lmap
type(vector_int), dimension(:), allocatable, intent(inout) :: Rowcut
integer, dimension(:), allocatable, intent(inout) :: nts_row, deghash
integer, dimension(:), intent(in) :: idxhash
integer, dimension(:), allocatable, intent(inout), optional :: lamblk, &
lamind
character, intent(in), optional :: caller
integer, intent(out), optional :: errst
! Local variables
! ---------------
! Looping / indices
integer :: ii, jj, kk, nn
! lower/upper bound of slice
integer :: r1, r2, c1, c2
! example index for irrep
integer :: irrep
! effective chi for each block
integer :: effchi
! stride for number of blocks (outer-most loop)
integer :: stride
! array for dimension of tensors
integer, dimension(:), allocatable :: dl
! Temporary quantum numbers
integer, dimension(:), allocatable :: qq
! Norm for tensor to be constructed
real(KIND=rKind) :: normtens
! temporary array for matrix
real(KIND=rKIND), dimension(:, :), allocatable :: mat
!if(present(errst)) errst = 0
allocate(dl(nl + 1), qq(sum(Tens%nqs)))
call create(Ltens, Tens%nqs, Tens%nb)
stride = 0
do ii = 1, nunique
if(present(lamblk)) then
effchi = count(ii == lamblk(lamind(:chi)))
if(effchi == 0) then
deallocate(Lmap(ii)%elem, Rowcut(ii)%elem)
call destroy(Mats%Li(ii))
stride = stride + deghash(ii + 1) - deghash(ii)
cycle
end if
else
effchi = Mats%Li(ii)%dl(2)
end if
! Get array in matrix form
allocate(mat(Mats%Li(ii)%dl(1), Mats%Li(ii)%dl(2)))
mat = reshape(Mats%Li(ii)%elem, &
[Mats%Li(ii)%dl(1), Mats%Li(ii)%dl(2)])
call destroy(Mats%Li(ii))
! Iterate over independent left irreps
do jj = 1, nts_row(ii)
! Identify rows
r1 = Rowcut(ii)%elem(jj) + 1
r2 = Rowcut(ii)%elem(jj + 1)
! Identify columns
if(present(caller)) then
if(caller == 'S') then
c1 = 1
c2 = effchi
elseif(caller == 'E') then
c2 = Mats%Li(ii)%dl(2)
c1 = c2 - effchi + 1
end if
else
c1 = 1
c2 = effchi
end if
! Get an estimate for the norm
normtens = sum(abs(mat(r1:r2, c1:c2)))
if(normtens < 1e-14) cycle
! Recall example for representative of this irrep
irrep = idxhash(stride + Lmap(ii)%elem(jj))
! Create new tensor in symmetric tensor
Ltens%nb = Ltens%nb + 1
nn = Ltens%nb
! Fix the dimension of the legs (indices)
dl(:nl) = Tens%Data(irrep)%Tens%dl(:nl)
dl(nl + 1) = effchi
!if(r2 - r1 + 1 /= product(dl(:nl))) then
! errst = raise_error('block2tensor_left_'//&
! 'qtensor : dim mismatch.', &
! 99, errst=errst)
! return
!end if
call create(Ltens%Data(nn)%Tens, dl)
Ltens%Data(nn)%Tens%elem = reshape(mat(r1:r2, c1:c2), &
[(r2 - r1 + 1) * effchi])
allocate(Ltens%Data(nn)%qq((nl + 1) * sum(Tens%nqs)))
! Identify left-right index
r1 = 1
r2 = sum(Tens%nqs)
do kk = 1, nl
Ltens%Data(nn)%qq(r1:r2) = Tens%Data(irrep)%qq(r1:r2)
if(kk == 1) qq = Tens%Data(irrep)%qq(r1:r2)
if(kk /= 1) qq = sumq(qq, Tens%Data(irrep)%qq(r1:r2), &
Tens%nqs)
r1 = r1 + sum(Tens%nqs)
r2 = r2 + sum(Tens%nqs)
end do
Ltens%Data(nn)%qq(r1:r2) = qq
end do
deallocate(Lmap(ii)%elem, Rowcut(ii)%elem, mat)
stride = stride + deghash(ii + 1) - deghash(ii)
end do
deallocate(dl, qq, Lmap, Rowcut, nts_row, Mats%Li)
end subroutine block2tensor_left_qtensor
"""
return
[docs]def block2tensor_left_qtensorc():
"""
fortran-subroutine - April 2017 (dj, based on mlw)
Rewrite the matrices of a decomposition again as tensor.
**Arguments**
Ltens : TYPE(qtensorc), inout
The decomposed tensor is stored here.
Tens : TYPE(qtensorc), in
The original tensor which was decomposed. It is required to
track the quantum numbers.
Mats : TYPE(tensorlistc), inout
Contains the matrices to be decomposed back into tensors.
Deallocated on exit.
nl : INTEGER, in
Number of indices encoded in the rows.
nunique : INTEGER, in
Number of unique blocks corresponding to the number of matrices
in Mats.
chi : INTEGER, in
Total bond dimension for last index.
Lmap : TYPE(VECTOR_INT)(\*), inout
Map for finding a representative of each irrep to retrieve
the quantum numbers. Deallocate on exit.
Rowcut : TYPE(VECTOR_INT)(\*), inout
Contains the first and last index of rows for each irreps.
Deallocated on exit.
nts_row : INTEGER(\*), inout
Contains the number of irreps in each block. Deallocated on
exit.
idxhash : INTEGER(\*), in
Sorting the hashes for the splitting.
lamblk : INTEGER(\*), OPTIONAL, in
Contains the block for the singular value at the i-th position.
lamind : INTEGER(\*), OPTIONAL, in
Contains the indices to sort the array of singular values.
caller : CHARACTER, OPTIONAL, in
'S' for singular value decomposition and 'E' for eigenvalue
decomposition. The first has descending values, the latter
ascending information. So when truncation is used, this flag
determines which eigenvectors belong to the truncated values.
**Details**
(template defined in qTensors_include.f90)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine block2tensor_left_qtensorc(Ltens, Tens, Mats, nl, &
nunique, chi, Lmap, Rowcut, &
nts_row, deghash, idxhash, lamblk, &
lamind, caller, errst)
type(qtensorc), intent(inout) :: Ltens
type(qtensorc), intent(in) :: Tens
type(tensorlistc), intent(inout) :: Mats
integer, intent(in) :: nl, nunique, chi
type(vector_int), dimension(:), allocatable, intent(inout) :: Lmap
type(vector_int), dimension(:), allocatable, intent(inout) :: Rowcut
integer, dimension(:), allocatable, intent(inout) :: nts_row, deghash
integer, dimension(:), intent(in) :: idxhash
integer, dimension(:), allocatable, intent(inout), optional :: lamblk, &
lamind
character, intent(in), optional :: caller
integer, intent(out), optional :: errst
! Local variables
! ---------------
! Looping / indices
integer :: ii, jj, kk, nn
! lower/upper bound of slice
integer :: r1, r2, c1, c2
! example index for irrep
integer :: irrep
! effective chi for each block
integer :: effchi
! stride for number of blocks (outer-most loop)
integer :: stride
! array for dimension of tensors
integer, dimension(:), allocatable :: dl
! Temporary quantum numbers
integer, dimension(:), allocatable :: qq
! Norm for tensor to be constructed
real(KIND=rKind) :: normtens
! temporary array for matrix
complex(KIND=rKIND), dimension(:, :), allocatable :: mat
!if(present(errst)) errst = 0
allocate(dl(nl + 1), qq(sum(Tens%nqs)))
call create(Ltens, Tens%nqs, Tens%nb)
stride = 0
do ii = 1, nunique
if(present(lamblk)) then
effchi = count(ii == lamblk(lamind(:chi)))
if(effchi == 0) then
deallocate(Lmap(ii)%elem, Rowcut(ii)%elem)
call destroy(Mats%Li(ii))
stride = stride + deghash(ii + 1) - deghash(ii)
cycle
end if
else
effchi = Mats%Li(ii)%dl(2)
end if
! Get array in matrix form
allocate(mat(Mats%Li(ii)%dl(1), Mats%Li(ii)%dl(2)))
mat = reshape(Mats%Li(ii)%elem, &
[Mats%Li(ii)%dl(1), Mats%Li(ii)%dl(2)])
call destroy(Mats%Li(ii))
! Iterate over independent left irreps
do jj = 1, nts_row(ii)
! Identify rows
r1 = Rowcut(ii)%elem(jj) + 1
r2 = Rowcut(ii)%elem(jj + 1)
! Identify columns
if(present(caller)) then
if(caller == 'S') then
c1 = 1
c2 = effchi
elseif(caller == 'E') then
c2 = Mats%Li(ii)%dl(2)
c1 = c2 - effchi + 1
end if
else
c1 = 1
c2 = effchi
end if
! Get an estimate for the norm
normtens = sum(abs(mat(r1:r2, c1:c2)))
if(normtens < 1e-14) cycle
! Recall example for representative of this irrep
irrep = idxhash(stride + Lmap(ii)%elem(jj))
! Create new tensor in symmetric tensor
Ltens%nb = Ltens%nb + 1
nn = Ltens%nb
! Fix the dimension of the legs (indices)
dl(:nl) = Tens%Data(irrep)%Tens%dl(:nl)
dl(nl + 1) = effchi
!if(r2 - r1 + 1 /= product(dl(:nl))) then
! errst = raise_error('block2tensor_left_'//&
! 'qtensorc : dim mismatch.', &
! 99, errst=errst)
! return
!end if
call create(Ltens%Data(nn)%Tens, dl)
Ltens%Data(nn)%Tens%elem = reshape(mat(r1:r2, c1:c2), &
[(r2 - r1 + 1) * effchi])
allocate(Ltens%Data(nn)%qq((nl + 1) * sum(Tens%nqs)))
! Identify left-right index
r1 = 1
r2 = sum(Tens%nqs)
do kk = 1, nl
Ltens%Data(nn)%qq(r1:r2) = Tens%Data(irrep)%qq(r1:r2)
if(kk == 1) qq = Tens%Data(irrep)%qq(r1:r2)
if(kk /= 1) qq = sumq(qq, Tens%Data(irrep)%qq(r1:r2), &
Tens%nqs)
r1 = r1 + sum(Tens%nqs)
r2 = r2 + sum(Tens%nqs)
end do
Ltens%Data(nn)%qq(r1:r2) = qq
end do
deallocate(Lmap(ii)%elem, Rowcut(ii)%elem, mat)
stride = stride + deghash(ii + 1) - deghash(ii)
end do
deallocate(dl, qq, Lmap, Rowcut, nts_row, Mats%Li)
end subroutine block2tensor_left_qtensorc
"""
return
[docs]def block2tensor_right_qtensor():
"""
fortran-subroutine - April 2017 (dj, based on mlw)
Rewrite the matrices of a decomposition again as tensor.
**Arguments**
Rtens : TYPE(qtensor), inout
The decomposed tensor is stored here.
Tens : TYPE(qtensor), in
The original tensor which was decomposed. It is required to
track the quantum numbers.
Mats : TYPE(tensorlist), inout
Contains the matrices to be decomposed back into tensors.
Deallocated on exit.
nl : INTEGER, in
Number of indices encoded in the rows.
nr : INTEGER, in
Number of indices encoded in the columns.
nunique : INTEGER, in
Number of unique blocks corresponding to the number of matrices
in Mats.
chi : INTEGER, in
Total bond dimension for last index.
Rmap : TYPE(VECTOR_INT)(\*), inout
Map for finding a representative of each irrep to retrieve
the quantum numbers. Deallocate on exit.
Colcut : TYPE(VECTOR_INT)(\*), inout
Contains the first and last index of columns for each irreps.
Deallocated on exit.
nts_col : INTEGER(\*), inout
Contains the number of irreps in each block. Deallocated on
exit.
idxhash : INTEGER(\*), in
Sorting the hashes for the splitting.
lamblk : INTEGER(\*), OPTIONAL, in
Contains the block for the singular value at the i-th position.
lamind : INTEGER(\*), OPTIONAL, in
Contains the indices to sort the array of singular values.
caller : CHARACTER, OPTIONAL, in
'S' for singular value decomposition and 'E' for eigenvalue
decomposition. The first has descending values, the latter
ascending information. So when truncation is used, this flag
determines which eigenvectors belong to the truncated values.
**Details**
(template defined in qTensors_include.f90)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine block2tensor_right_qtensor(Rtens, Tens, Mats, nl, nr, &
nunique, chi, Rmap, Colcut, &
nts_col, deghash, idxhash, lamblk, &
lamind, caller, errst)
type(qtensor), intent(inout) :: Rtens
type(qtensor), intent(in) :: Tens
type(tensorlist), intent(inout) :: Mats
integer, intent(in) :: nl, nr, nunique, chi
type(vector_int), dimension(:), allocatable, intent(inout) :: Rmap
type(vector_int), dimension(:), allocatable, intent(inout) :: Colcut
integer, dimension(:), allocatable, intent(inout) :: nts_col, deghash
integer, dimension(:), intent(in) :: idxhash
integer, dimension(:), allocatable, intent(inout), optional :: lamblk, &
lamind
character, intent(in), optional :: caller
integer, intent(out), optional :: errst
! Local variables
! ---------------
! Looping / indices
integer :: ii, jj, kk, nn, k1, k2
! indices for columns (upper and lower bound) and rows (bond dimension)
integer :: c1, c2, r1, r2
! example index for irrep
integer :: irrep
! effective chi for each block
integer :: effchi
! stride for number of blocks (outer-most loop)
integer :: stride
! array for dimension of tensors
integer, dimension(:), allocatable :: dl
! Temporary quantum numbers
integer, dimension(:), allocatable :: qq
! Norm of tensor to be created
real(KIND=rKind) :: normtens
! temporary array for matrix
real(KIND=rKIND), dimension(:, :), allocatable :: mat
!if(present(errst)) errst = 0
allocate(dl(nr + 1), qq(sum(Tens%nqs)))
call create(Rtens, Tens%nqs, Tens%nb)
stride = 0
do ii = 1, nunique
if(present(lamblk)) then
effchi = count(ii == lamblk(lamind(:chi)))
if(effchi == 0) then
deallocate(Rmap(ii)%elem, Colcut(ii)%elem)
call destroy(Mats%Li(ii))
stride = stride + deghash(ii + 1) - deghash(ii)
cycle
end if
else
effchi = Mats%Li(ii)%dl(1)
end if
! Get array in matrix form
allocate(mat(Mats%Li(ii)%dl(1), Mats%Li(ii)%dl(2)))
mat = reshape(Mats%Li(ii)%elem, &
[Mats%Li(ii)%dl(1), Mats%Li(ii)%dl(2)])
call destroy(Mats%Li(ii))
! Iterate over independent right irreps
do jj = 1, nts_col(ii)
! Identify columns
c1 = Colcut(ii)%elem(jj) + 1
c2 = Colcut(ii)%elem(jj + 1)
if(present(caller)) then
if(caller == 'S') then
r1 = 1
r2 = effchi
elseif(caller == 'E') then
r2 = Mats%Li(ii)%dl(1)
r1 = r2 - effchi + 1
end if
else
r1 = 1
r2 = effchi
end if
! Estimate norm
normtens = sum(abs(mat(r1:r2, c1:c2)))
if(normtens < 1e-14) cycle
! Rcall example for reprentative of this irreps
irrep = idxhash(stride + Rmap(ii)%elem(jj))
! Create new tensor in symmetric tensor
Rtens%nb = Rtens%nb + 1
nn = Rtens%nb
! Fix the dimension of the legs (indices)
dl(1) = effchi
dl(2:) = Tens%Data(irrep)%Tens%dl(nl + 1:)
call create(Rtens%Data(nn)%Tens, dl)
Rtens%Data(nn)%Tens%elem = reshape(mat(r1:r2, c1:c2), &
[effchi * (c2 - c1 + 1)])
allocate(Rtens%Data(nn)%qq((nr + 1) * sum(Tens%nqs)))
! Identify left-right index
c1 = 1
c2 = sum(Tens%nqs)
qq = Tens%Data(irrep)%qq(c1:c2)
do kk = 2, nl
c1 = c1 + sum(Tens%nqs)
c2 = c2 + sum(Tens%nqs)
qq = sumq(qq, Tens%Data(irrep)%qq(c1:c2), Tens%nqs)
end do
k1 = 1
k2 = sum(Tens%nqs)
Rtens%Data(nn)%qq(k1:k2) = qq
do kk = 1, nr
c1 = c1 + sum(Tens%nqs)
c2 = c2 + sum(Tens%nqs)
k1 = k1 + sum(Tens%nqs)
k2 = k2 + sum(Tens%nqs)
Rtens%Data(nn)%qq(k1:k2) = Tens%Data(irrep)%qq(c1:c2)
end do
end do
deallocate(Rmap(ii)%elem, Colcut(ii)%elem, mat)
stride = stride + deghash(ii + 1) - deghash(ii)
end do
deallocate(dl, qq, Rmap, Colcut, nts_col, Mats%Li)
end subroutine block2tensor_right_qtensor
"""
return
[docs]def block2tensor_right_qtensorc():
"""
fortran-subroutine - April 2017 (dj, based on mlw)
Rewrite the matrices of a decomposition again as tensor.
**Arguments**
Rtens : TYPE(qtensorc), inout
The decomposed tensor is stored here.
Tens : TYPE(qtensorc), in
The original tensor which was decomposed. It is required to
track the quantum numbers.
Mats : TYPE(tensorlistc), inout
Contains the matrices to be decomposed back into tensors.
Deallocated on exit.
nl : INTEGER, in
Number of indices encoded in the rows.
nr : INTEGER, in
Number of indices encoded in the columns.
nunique : INTEGER, in
Number of unique blocks corresponding to the number of matrices
in Mats.
chi : INTEGER, in
Total bond dimension for last index.
Rmap : TYPE(VECTOR_INT)(\*), inout
Map for finding a representative of each irrep to retrieve
the quantum numbers. Deallocate on exit.
Colcut : TYPE(VECTOR_INT)(\*), inout
Contains the first and last index of columns for each irreps.
Deallocated on exit.
nts_col : INTEGER(\*), inout
Contains the number of irreps in each block. Deallocated on
exit.
idxhash : INTEGER(\*), in
Sorting the hashes for the splitting.
lamblk : INTEGER(\*), OPTIONAL, in
Contains the block for the singular value at the i-th position.
lamind : INTEGER(\*), OPTIONAL, in
Contains the indices to sort the array of singular values.
caller : CHARACTER, OPTIONAL, in
'S' for singular value decomposition and 'E' for eigenvalue
decomposition. The first has descending values, the latter
ascending information. So when truncation is used, this flag
determines which eigenvectors belong to the truncated values.
**Details**
(template defined in qTensors_include.f90)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine block2tensor_right_qtensorc(Rtens, Tens, Mats, nl, nr, &
nunique, chi, Rmap, Colcut, &
nts_col, deghash, idxhash, lamblk, &
lamind, caller, errst)
type(qtensorc), intent(inout) :: Rtens
type(qtensorc), intent(in) :: Tens
type(tensorlistc), intent(inout) :: Mats
integer, intent(in) :: nl, nr, nunique, chi
type(vector_int), dimension(:), allocatable, intent(inout) :: Rmap
type(vector_int), dimension(:), allocatable, intent(inout) :: Colcut
integer, dimension(:), allocatable, intent(inout) :: nts_col, deghash
integer, dimension(:), intent(in) :: idxhash
integer, dimension(:), allocatable, intent(inout), optional :: lamblk, &
lamind
character, intent(in), optional :: caller
integer, intent(out), optional :: errst
! Local variables
! ---------------
! Looping / indices
integer :: ii, jj, kk, nn, k1, k2
! indices for columns (upper and lower bound) and rows (bond dimension)
integer :: c1, c2, r1, r2
! example index for irrep
integer :: irrep
! effective chi for each block
integer :: effchi
! stride for number of blocks (outer-most loop)
integer :: stride
! array for dimension of tensors
integer, dimension(:), allocatable :: dl
! Temporary quantum numbers
integer, dimension(:), allocatable :: qq
! Norm of tensor to be created
real(KIND=rKind) :: normtens
! temporary array for matrix
complex(KIND=rKIND), dimension(:, :), allocatable :: mat
!if(present(errst)) errst = 0
allocate(dl(nr + 1), qq(sum(Tens%nqs)))
call create(Rtens, Tens%nqs, Tens%nb)
stride = 0
do ii = 1, nunique
if(present(lamblk)) then
effchi = count(ii == lamblk(lamind(:chi)))
if(effchi == 0) then
deallocate(Rmap(ii)%elem, Colcut(ii)%elem)
call destroy(Mats%Li(ii))
stride = stride + deghash(ii + 1) - deghash(ii)
cycle
end if
else
effchi = Mats%Li(ii)%dl(1)
end if
! Get array in matrix form
allocate(mat(Mats%Li(ii)%dl(1), Mats%Li(ii)%dl(2)))
mat = reshape(Mats%Li(ii)%elem, &
[Mats%Li(ii)%dl(1), Mats%Li(ii)%dl(2)])
call destroy(Mats%Li(ii))
! Iterate over independent right irreps
do jj = 1, nts_col(ii)
! Identify columns
c1 = Colcut(ii)%elem(jj) + 1
c2 = Colcut(ii)%elem(jj + 1)
if(present(caller)) then
if(caller == 'S') then
r1 = 1
r2 = effchi
elseif(caller == 'E') then
r2 = Mats%Li(ii)%dl(1)
r1 = r2 - effchi + 1
end if
else
r1 = 1
r2 = effchi
end if
! Estimate norm
normtens = sum(abs(mat(r1:r2, c1:c2)))
if(normtens < 1e-14) cycle
! Rcall example for reprentative of this irreps
irrep = idxhash(stride + Rmap(ii)%elem(jj))
! Create new tensor in symmetric tensor
Rtens%nb = Rtens%nb + 1
nn = Rtens%nb
! Fix the dimension of the legs (indices)
dl(1) = effchi
dl(2:) = Tens%Data(irrep)%Tens%dl(nl + 1:)
call create(Rtens%Data(nn)%Tens, dl)
Rtens%Data(nn)%Tens%elem = reshape(mat(r1:r2, c1:c2), &
[effchi * (c2 - c1 + 1)])
allocate(Rtens%Data(nn)%qq((nr + 1) * sum(Tens%nqs)))
! Identify left-right index
c1 = 1
c2 = sum(Tens%nqs)
qq = Tens%Data(irrep)%qq(c1:c2)
do kk = 2, nl
c1 = c1 + sum(Tens%nqs)
c2 = c2 + sum(Tens%nqs)
qq = sumq(qq, Tens%Data(irrep)%qq(c1:c2), Tens%nqs)
end do
k1 = 1
k2 = sum(Tens%nqs)
Rtens%Data(nn)%qq(k1:k2) = qq
do kk = 1, nr
c1 = c1 + sum(Tens%nqs)
c2 = c2 + sum(Tens%nqs)
k1 = k1 + sum(Tens%nqs)
k2 = k2 + sum(Tens%nqs)
Rtens%Data(nn)%qq(k1:k2) = Tens%Data(irrep)%qq(c1:c2)
end do
end do
deallocate(Rmap(ii)%elem, Colcut(ii)%elem, mat)
stride = stride + deghash(ii + 1) - deghash(ii)
end do
deallocate(dl, qq, Rmap, Colcut, nts_col, Mats%Li)
end subroutine block2tensor_right_qtensorc
"""
return
[docs]def block2tensor_center_qtensor():
"""
fortran-subroutine - April 2017 (dj)
Rewrite the matrices of the singular values again as a tensor.
**Arguments**
Lambda : TYPE(qtensor), inout
The singular values between the decomposed tensors (or
other possible weights).
Tens : TYPE(qtensor), in
The original tensor which was decomposed. It is required to
track the quantum numbers.
Lam : TYPE(tensorlist), inout
Contains the vectors for singular values to be stored
with their quantum numbers.
nl : INTEGER, in
Number of indices encoded in the rows.
nunique : INTEGER, in
Number of unique blocks corresponding to the number of matrices
in Mats.
chi : INTEGER, in
Total bond dimension for last index.
Rmap : TYPE(VECTOR_INT)(\*), inout
Map for finding a representative of each irrep to retrieve
the quantum numbers.
nts_col : INTEGER(\*), inout
Contains the number of irreps in each block.
idxhash : INTEGER(\*), in
Sorting the hashes for the splitting.
lamblk : INTEGER(\*), in
Contains the block for the singular value at the i-th position.
lamind : INTEGER(\*), in
Contains the indices to sort the array of singular values.
caller : CHARACTER, in
For values from eigenvalue decomposition, use 'E'. The square root
is taken. Values are ascending. In contrast, for the singular value
decomposition, use 'S'. The values are copied and are sorting in
ascending order.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine block2tensor_center_qtensor(Lambda, Tens, Lam, nl, &
nunique, chi, Rmap, &
nts_col, deghash, idxhash, &
lamblk, lamind, caller, errst)
type(qtensor), intent(inout) :: Lambda
type(qtensor), intent(in) :: Tens
type(tensorlist), intent(inout) :: Lam
integer, intent(in) :: nl, nunique, chi
type(vector_int), dimension(:), allocatable, intent(inout) :: Rmap
integer, dimension(:), allocatable, intent(inout) :: nts_col, deghash
integer, dimension(:), intent(in) :: idxhash
integer, dimension(:), allocatable, intent(inout) :: lamblk, lamind
character, intent(in) :: caller
integer, intent(out), optional :: errst
! Local variables
! ---------------
! Looping / indices
integer :: ii, kk, nn
! lower/upper bound of slice
integer :: c1, c2
! example index for irrep
integer :: irrep
! effective chi for each block
integer :: effchi
! stride for number of blocks (outer-most loop)
integer :: stride
! Temporary quantum numbers
integer, dimension(:), allocatable :: qq
!if(present(errst)) errst = 0
allocate(qq(sum(Tens%nqs)))
call create(Lambda, Tens%nqs, Tens%nb)
stride = 0
do ii = 1, nunique
effchi = count(ii == lamblk(lamind(:chi)))
if(effchi == 0) then
stride = stride + deghash(ii + 1) - deghash(ii)
cycle
end if
! No need to iterate over independent right irreps
! They have all the same quantum numbers on this link
! Recall example for representative of this irreps
irrep = idxhash(stride + Rmap(ii)%elem(1))
Lambda%nb = Lambda%nb + 1
nn = Lambda%nb
call create(Lambda%Data(nn)%Tens, [effchi])
if(caller == 'S') then
Lambda%Data(nn)%Tens%elem = Lam%Li(ii)%elem(:effchi)
elseif(caller == 'E') then
c1 = Lam%Li(ii)%dl(1) - effchi + 1
c2 = Lam%Li(ii)%dl(2)
Lambda%Data(nn)%Tens%elem = sqrt(Lam%Li(ii)%elem(c1:c2))
end if
allocate(Lambda%Data(nn)%qq(sum(Tens%nqs)))
c1 = 1
c2 = sum(Tens%nqs)
qq = Tens%Data(irrep)%qq(c1:c2)
do kk = 2, nl
c1 = c1 + sum(Tens%nqs)
c2 = c2 + sum(Tens%nqs)
qq = sumq(qq, Tens%Data(irrep)%qq(c1:c2), Tens%nqs)
end do
Lambda%Data(nn)%qq = qq
stride = stride + deghash(ii + 1) - deghash(ii)
end do
deallocate(qq)
end subroutine block2tensor_center_qtensor
"""
return
[docs]def block2tensor_center_qtensorc():
"""
fortran-subroutine - April 2017 (dj)
Rewrite the matrices of the singular values again as a tensor.
**Arguments**
Lambda : TYPE(qtensor), inout
The singular values between the decomposed tensors (or
other possible weights).
Tens : TYPE(qtensorc), in
The original tensor which was decomposed. It is required to
track the quantum numbers.
Lam : TYPE(tensorlist), inout
Contains the vectors for singular values to be stored
with their quantum numbers.
nl : INTEGER, in
Number of indices encoded in the rows.
nunique : INTEGER, in
Number of unique blocks corresponding to the number of matrices
in Mats.
chi : INTEGER, in
Total bond dimension for last index.
Rmap : TYPE(VECTOR_INT)(\*), inout
Map for finding a representative of each irrep to retrieve
the quantum numbers.
nts_col : INTEGER(\*), inout
Contains the number of irreps in each block.
idxhash : INTEGER(\*), in
Sorting the hashes for the splitting.
lamblk : INTEGER(\*), in
Contains the block for the singular value at the i-th position.
lamind : INTEGER(\*), in
Contains the indices to sort the array of singular values.
caller : CHARACTER, in
For values from eigenvalue decomposition, use 'E'. The square root
is taken. Values are ascending. In contrast, for the singular value
decomposition, use 'S'. The values are copied and are sorting in
ascending order.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine block2tensor_center_qtensorc(Lambda, Tens, Lam, nl, &
nunique, chi, Rmap, &
nts_col, deghash, idxhash, &
lamblk, lamind, caller, errst)
type(qtensor), intent(inout) :: Lambda
type(qtensorc), intent(in) :: Tens
type(tensorlist), intent(inout) :: Lam
integer, intent(in) :: nl, nunique, chi
type(vector_int), dimension(:), allocatable, intent(inout) :: Rmap
integer, dimension(:), allocatable, intent(inout) :: nts_col, deghash
integer, dimension(:), intent(in) :: idxhash
integer, dimension(:), allocatable, intent(inout) :: lamblk, lamind
character, intent(in) :: caller
integer, intent(out), optional :: errst
! Local variables
! ---------------
! Looping / indices
integer :: ii, kk, nn
! lower/upper bound of slice
integer :: c1, c2
! example index for irrep
integer :: irrep
! effective chi for each block
integer :: effchi
! stride for number of blocks (outer-most loop)
integer :: stride
! Temporary quantum numbers
integer, dimension(:), allocatable :: qq
!if(present(errst)) errst = 0
allocate(qq(sum(Tens%nqs)))
call create(Lambda, Tens%nqs, Tens%nb)
stride = 0
do ii = 1, nunique
effchi = count(ii == lamblk(lamind(:chi)))
if(effchi == 0) then
stride = stride + deghash(ii + 1) - deghash(ii)
cycle
end if
! No need to iterate over independent right irreps
! They have all the same quantum numbers on this link
! Recall example for representative of this irreps
irrep = idxhash(stride + Rmap(ii)%elem(1))
Lambda%nb = Lambda%nb + 1
nn = Lambda%nb
call create(Lambda%Data(nn)%Tens, [effchi])
if(caller == 'S') then
Lambda%Data(nn)%Tens%elem = Lam%Li(ii)%elem(:effchi)
elseif(caller == 'E') then
c1 = Lam%Li(ii)%dl(1) - effchi + 1
c2 = Lam%Li(ii)%dl(2)
Lambda%Data(nn)%Tens%elem = sqrt(Lam%Li(ii)%elem(c1:c2))
end if
allocate(Lambda%Data(nn)%qq(sum(Tens%nqs)))
c1 = 1
c2 = sum(Tens%nqs)
qq = Tens%Data(irrep)%qq(c1:c2)
do kk = 2, nl
c1 = c1 + sum(Tens%nqs)
c2 = c2 + sum(Tens%nqs)
qq = sumq(qq, Tens%Data(irrep)%qq(c1:c2), Tens%nqs)
end do
Lambda%Data(nn)%qq = qq
stride = stride + deghash(ii + 1) - deghash(ii)
end do
deallocate(qq)
end subroutine block2tensor_center_qtensorc
"""
return
[docs]def block2tensor_both_qtensor():
"""
fortran-subroutine - April 2017 (dj)
Rewrite the matrices of a decomposition again into the original
tensor. This subroutine is useful for evaluating matrix functions.
**Arguments**
Tens : TYPE(qtensor), inout
The original tensor which was decomposed. It will be
overwritten.
Mats : TYPE(tensorlist), inout
Contains the matrices to be decomposed back into tensors.
Deallocated on exit.
Mats : TYPE(tensorlist), inout
Contains the matrices to be decomposed back into tensors.
Deallocated on exit.
Lmap : TYPE(VECTOR_INT)(\*), inout
Map for finding a representative of each irrep to retrieve
the quantum numbers of a row. Deallocate on exit.
Rmap : TYPE(VECTOR_INT)(\*), inout
Map for finding a representative of each irrep to retrieve
the quantum numbers of a column. Deallocate on exit.
Rowcut : TYPE(VECTOR_INT)(\*), inout
Contains the first and last index of rows for each irreps.
Deallocated on exit.
Colcut : TYPE(VECTOR_INT)(\*), inout
Contains the first and last index of columns for each irreps.
Deallocated on exit.
nts_row : INTEGER(\*), inout
Contains the number of irreps in each block for the rows.
Deallocated on exit.
nts_col : INTEGER(\*), inout
Contains the number of irreps in each block for the columns.
Deallocated on exit.
idxhash : INTEGER(\*), in
Sorting the hashes for the splitting.
nunique : INTEGER, in
Number of unique blocks corresponding to the number of matrices
in Mats.
nl : INTEGER, in
Number of links in the left block.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine block2tensor_both_qtensor(Tens, Mats, Lmap, Rmap, &
Rowcut, Colcut, nts_row, &
nts_col, deghash, idxhash, &
nunique, nl, errst)
type(qtensor), intent(inout) :: Tens
type(tensorlist), intent(inout) :: Mats
type(vector_int), dimension(:), allocatable, intent(inout) :: Lmap
type(vector_int), dimension(:), allocatable, intent(inout) :: Rmap
type(vector_int), dimension(:), allocatable, intent(inout) :: Rowcut
type(vector_int), dimension(:), allocatable, intent(inout) :: Colcut
integer, dimension(:), allocatable, intent(inout) :: nts_row, nts_col, deghash
integer, dimension(:), intent(in) :: idxhash
integer, intent(in) :: nunique
integer, intent(in) :: nl
integer, intent(out), optional :: errst
! Local variables
! ---------------
! Looping / indices
integer :: ii, jj, kk, idx
! lower/upper bound of slice
integer :: r1, r2, c1, c2
! example index for irrep
integer :: irrep, irrepr
! temporary shortcut to dimension
integer :: dim
! stride for number of blocks (outer-most loop)
integer :: stride
! Array of logicals to see what has been accessed
logical, dimension(:), allocatable :: accessed
! collect tensors to be kept
integer, dimension(:), allocatable :: idxkeep
! temporary tensor
type(qtensor) :: Tmp
integer, dimension(:), allocatable :: dims
! number of conserved quanitites
integer :: snqs
! temporary array for matrix
real(KIND=rKIND), dimension(:, :), allocatable :: mat
!if(present(errst)) errst = 0
allocate(accessed(Tens%nb), idxkeep(Tens%nb), dims(rank(Tens)))
accessed = .false.
dim = sum(nts_row(:nunique) * nts_col(:nunique))
call create(Tmp, Tens%nqs, dim)
stride = 0
snqs = sum(Tens%nqs)
do ii = 1, nunique
! Get array in matrix form
allocate(mat(Mats%Li(ii)%dl(1), Mats%Li(ii)%dl(2)))
mat = reshape(Mats%Li(ii)%elem, &
[Mats%Li(ii)%dl(1), Mats%Li(ii)%dl(2)])
call destroy(Mats%Li(ii))
do jj = 1, nts_row(ii)
! Identify rows
r1 = Rowcut(ii)%elem(jj) + 1
r2 = Rowcut(ii)%elem(jj + 1)
irrep = idxhash(stride + Lmap(ii)%elem(jj))
do kk = 1, nts_col(ii)
! Identify colums
c1 = Colcut(ii)%elem(kk) + 1
c2 = Colcut(ii)%elem(kk + 1)
irrepr = idxhash(stride + Rmap(ii)%elem(kk))
if(sum(abs(mat(r1:r2, c1:c2))) < 1e-15) cycle
dim = (r2 - r1 + 1) * (c2 - c1 + 1)
Tmp%nb = Tmp%nb + 1
dims(:nl) = Tens%Data(irrep)%Tens%dl(:nl)
dims(nl + 1:) = Tens%Data(irrepr)%Tens%dl(nl + 1:)
call create(Tmp%Data(Tmp%nb)%Tens, dims)
Tmp%Data(Tmp%nb)%Tens%elem = reshape(mat(r1:r2, c1:c2), &
[dim])
allocate(Tmp%Data(Tmp%nb)%qq(4 * sum(Tmp%nqs)))
Tmp%Data(Tmp%nb)%qq(:nl * snqs) = Tens%Data(irrep)%qq(:nl * snqs)
Tmp%Data(Tmp%nb)%qq(nl * snqs + 1:) = Tens%Data(irrepr)%qq(nl * snqs + 1:)
end do
end do
deallocate(mat, Lmap(ii)%elem, Rmap(ii)%elem, &
Rowcut(ii)%elem, Colcut(ii)%elem)
stride = stride + deghash(ii + 1) - deghash(ii)
end do
call destroy(Tens)
call pointto(Tens, Tmp)
!call copy(Tens, Tmp)
!call destroy(Tmp)
deallocate(Lmap, Rmap, Rowcut, Colcut, nts_row, nts_col, Mats%Li, dims)
end subroutine block2tensor_both_qtensor
"""
return
[docs]def block2tensor_both_qtensorc():
"""
fortran-subroutine - April 2017 (dj)
Rewrite the matrices of a decomposition again into the original
tensor. This subroutine is useful for evaluating matrix functions.
**Arguments**
Tens : TYPE(qtensorc), inout
The original tensor which was decomposed. It will be
overwritten.
Mats : TYPE(tensorlistc), inout
Contains the matrices to be decomposed back into tensors.
Deallocated on exit.
Mats : TYPE(tensorlistc), inout
Contains the matrices to be decomposed back into tensors.
Deallocated on exit.
Lmap : TYPE(VECTOR_INT)(\*), inout
Map for finding a representative of each irrep to retrieve
the quantum numbers of a row. Deallocate on exit.
Rmap : TYPE(VECTOR_INT)(\*), inout
Map for finding a representative of each irrep to retrieve
the quantum numbers of a column. Deallocate on exit.
Rowcut : TYPE(VECTOR_INT)(\*), inout
Contains the first and last index of rows for each irreps.
Deallocated on exit.
Colcut : TYPE(VECTOR_INT)(\*), inout
Contains the first and last index of columns for each irreps.
Deallocated on exit.
nts_row : INTEGER(\*), inout
Contains the number of irreps in each block for the rows.
Deallocated on exit.
nts_col : INTEGER(\*), inout
Contains the number of irreps in each block for the columns.
Deallocated on exit.
idxhash : INTEGER(\*), in
Sorting the hashes for the splitting.
nunique : INTEGER, in
Number of unique blocks corresponding to the number of matrices
in Mats.
nl : INTEGER, in
Number of links in the left block.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine block2tensor_both_qtensorc(Tens, Mats, Lmap, Rmap, &
Rowcut, Colcut, nts_row, &
nts_col, deghash, idxhash, &
nunique, nl, errst)
type(qtensorc), intent(inout) :: Tens
type(tensorlistc), intent(inout) :: Mats
type(vector_int), dimension(:), allocatable, intent(inout) :: Lmap
type(vector_int), dimension(:), allocatable, intent(inout) :: Rmap
type(vector_int), dimension(:), allocatable, intent(inout) :: Rowcut
type(vector_int), dimension(:), allocatable, intent(inout) :: Colcut
integer, dimension(:), allocatable, intent(inout) :: nts_row, nts_col, deghash
integer, dimension(:), intent(in) :: idxhash
integer, intent(in) :: nunique
integer, intent(in) :: nl
integer, intent(out), optional :: errst
! Local variables
! ---------------
! Looping / indices
integer :: ii, jj, kk, idx
! lower/upper bound of slice
integer :: r1, r2, c1, c2
! example index for irrep
integer :: irrep, irrepr
! temporary shortcut to dimension
integer :: dim
! stride for number of blocks (outer-most loop)
integer :: stride
! Array of logicals to see what has been accessed
logical, dimension(:), allocatable :: accessed
! collect tensors to be kept
integer, dimension(:), allocatable :: idxkeep
! temporary tensor
type(qtensorc) :: Tmp
integer, dimension(:), allocatable :: dims
! number of conserved quanitites
integer :: snqs
! temporary array for matrix
complex(KIND=rKIND), dimension(:, :), allocatable :: mat
!if(present(errst)) errst = 0
allocate(accessed(Tens%nb), idxkeep(Tens%nb), dims(rank(Tens)))
accessed = .false.
dim = sum(nts_row(:nunique) * nts_col(:nunique))
call create(Tmp, Tens%nqs, dim)
stride = 0
snqs = sum(Tens%nqs)
do ii = 1, nunique
! Get array in matrix form
allocate(mat(Mats%Li(ii)%dl(1), Mats%Li(ii)%dl(2)))
mat = reshape(Mats%Li(ii)%elem, &
[Mats%Li(ii)%dl(1), Mats%Li(ii)%dl(2)])
call destroy(Mats%Li(ii))
do jj = 1, nts_row(ii)
! Identify rows
r1 = Rowcut(ii)%elem(jj) + 1
r2 = Rowcut(ii)%elem(jj + 1)
irrep = idxhash(stride + Lmap(ii)%elem(jj))
do kk = 1, nts_col(ii)
! Identify colums
c1 = Colcut(ii)%elem(kk) + 1
c2 = Colcut(ii)%elem(kk + 1)
irrepr = idxhash(stride + Rmap(ii)%elem(kk))
if(sum(abs(mat(r1:r2, c1:c2))) < 1e-15) cycle
dim = (r2 - r1 + 1) * (c2 - c1 + 1)
Tmp%nb = Tmp%nb + 1
dims(:nl) = Tens%Data(irrep)%Tens%dl(:nl)
dims(nl + 1:) = Tens%Data(irrepr)%Tens%dl(nl + 1:)
call create(Tmp%Data(Tmp%nb)%Tens, dims)
Tmp%Data(Tmp%nb)%Tens%elem = reshape(mat(r1:r2, c1:c2), &
[dim])
allocate(Tmp%Data(Tmp%nb)%qq(4 * sum(Tmp%nqs)))
Tmp%Data(Tmp%nb)%qq(:nl * snqs) = Tens%Data(irrep)%qq(:nl * snqs)
Tmp%Data(Tmp%nb)%qq(nl * snqs + 1:) = Tens%Data(irrepr)%qq(nl * snqs + 1:)
end do
end do
deallocate(mat, Lmap(ii)%elem, Rmap(ii)%elem, &
Rowcut(ii)%elem, Colcut(ii)%elem)
stride = stride + deghash(ii + 1) - deghash(ii)
end do
call destroy(Tens)
call pointto(Tens, Tmp)
!call copy(Tens, Tmp)
!call destroy(Tmp)
deallocate(Lmap, Rmap, Rowcut, Colcut, nts_row, nts_col, Mats%Li, dims)
end subroutine block2tensor_both_qtensorc
"""
return
[docs]def check_qnum_tensdim_qtensor():
"""
fortran-subroutine - August 2018 (dj)
Check for entries with same quantum number, but different tensor dimension.
**Arguments**
Tens : TYPE(qtensor), in
Tensor to be checked.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine check_qnum_tensdim_qtensor(Tens, errst)
type(qtensor), intent(in) :: Tens
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj
!if(present(errst)) errst = 0
do ii = 1, (Tens%nb - 1)
do jj = (ii + 1), Tens%nb
if(all(Tens%Data(ii)%qq == Tens%Data(jj)%qq)) then
if(any(Tens%Data(ii)%Tens%dl /= Tens%Data(jj)%Tens%dl)) then
errst = raise_error('check_qnum_tensdim_'//&
'qtensor: check qnum & dim.', &
99, 'qTensors_include.f90:1809', errst=errst)
return
end if
end if
end do
end do
end subroutine check_qnum_tensdim_qtensor
"""
return
[docs]def check_qnum_tensdim_qtensorc():
"""
fortran-subroutine - August 2018 (dj)
Check for entries with same quantum number, but different tensor dimension.
**Arguments**
Tens : TYPE(qtensorc), in
Tensor to be checked.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine check_qnum_tensdim_qtensorc(Tens, errst)
type(qtensorc), intent(in) :: Tens
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj
!if(present(errst)) errst = 0
do ii = 1, (Tens%nb - 1)
do jj = (ii + 1), Tens%nb
if(all(Tens%Data(ii)%qq == Tens%Data(jj)%qq)) then
if(any(Tens%Data(ii)%Tens%dl /= Tens%Data(jj)%Tens%dl)) then
errst = raise_error('check_qnum_tensdim_'//&
'qtensorc: check qnum & dim.', &
99, 'qTensors_include.f90:1809', errst=errst)
return
end if
end if
end do
end do
end subroutine check_qnum_tensdim_qtensorc
"""
return
[docs]def conj_qtensor():
"""
fortran-subroutine - October 2016 (dj)
Complex-conjugated elements in the tensor.
**Arguments**
Tens : TYPE(qtensor), inout
Take the complex conjugate of each element
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine conj_qtensor(Tens, errst)
type(qtensor), intent(inout) :: Tens
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
!if(present(errst)) errst = 0
return
do ii = 1, Tens%nb
call conj(Tens%Data(ii)%Tens, errst=errst)
!if(prop_error('conjg_qtensor: conjg failed', &
! errst=errst)) return
end do
end subroutine conj_qtensor
"""
return
[docs]def conj_qtensorc():
"""
fortran-subroutine - October 2016 (dj)
Complex-conjugated elements in the tensor.
**Arguments**
Tens : TYPE(qtensorc), inout
Take the complex conjugate of each element
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine conj_qtensorc(Tens, errst)
type(qtensorc), intent(inout) :: Tens
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
!if(present(errst)) errst = 0
!return
do ii = 1, Tens%nb
call conj(Tens%Data(ii)%Tens, errst=errst)
!if(prop_error('conjg_qtensorc: conjg failed', &
! errst=errst)) return
end do
end subroutine conj_qtensorc
"""
return
[docs]def copy_qtensor_qtensor():
"""
fortran-subroutine - January 2016 (update dj)
Copy a qtensor.
details (template defined in qTensors_include.f90)
**Arguments**
Objout : TYPE(VECTOR_TYPE), out
Store copy of Objin in this vector.
Objin : TYPE(VECTOR_TYPE), in
Copy this vector to a new vector Objout.
scalar : real, OPTIONAL, in
Multiply input tensor with scalar during copying replacing
a copy + scale action.
trans : CHARACTER, OPTIONAL, in
The following transformation can be applied: complex conjugate ('C'),
transposition ('T', simple transposition, no permutation), conjugate
transposed ('H', simple transposition). No transformation is 'N'.
Default to 'N'.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine copy_qtensor_qtensor(Objout, Objin, scalar, trans, &
errst)
type(qtensor), intent(out) :: Objout
type(qtensor), intent(in) :: Objin
real(KIND=rKind), intent(in), optional :: scalar
character, intent(in), optional :: trans
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
!if(present(errst)) errst = 0
call Create(Objout, Objin%nqs, capacity=Objin%capacity, errst=errst)
!if(prop_error('Copy_qtensor_qtensor: create', &
! errst=errst)) return
Objout%nb = Objin%nb
do ii = 1, Objout%nb
call copy(Objout%Data(ii)%Tens, Objin%Data(ii)%Tens, &
scalar=scalar, trans=trans, errst=errst)
!if(prop_error('Copy_qtensor_qtensor: copy', &
! errst=errst)) return
allocate(Objout%Data(ii)%qq(size(Objin%Data(ii)%qq)))
Objout%Data(ii)%qq = Objin%Data(ii)%qq
Objout%hash(ii) = Objin%hash(ii)
end do
if(present(trans)) then
if((trans == 'T') .or. (trans == 'H')) then
call permute_qnumbers(Objout, errst=errst)
!if(prop_error('copy_qtensor_qtensor : '//&
! 'permute_qnumbers failed.', &
! errst=errst)) return
end if
end if
end subroutine copy_qtensor_qtensor
"""
return
[docs]def copy_qtensorc_qtensor():
"""
fortran-subroutine - January 2016 (update dj)
Copy a qtensor.
details (template defined in qTensors_include.f90)
**Arguments**
Objout : TYPE(VECTOR_TYPE), out
Store copy of Objin in this vector.
Objin : TYPE(VECTOR_TYPE), in
Copy this vector to a new vector Objout.
scalar : complex, OPTIONAL, in
Multiply input tensor with scalar during copying replacing
a copy + scale action.
trans : CHARACTER, OPTIONAL, in
The following transformation can be applied: complex conjugate ('C'),
transposition ('T', simple transposition, no permutation), conjugate
transposed ('H', simple transposition). No transformation is 'N'.
Default to 'N'.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine copy_qtensorc_qtensor(Objout, Objin, scalar, trans, &
errst)
type(qtensorc), intent(out) :: Objout
type(qtensor), intent(in) :: Objin
complex(KIND=rKind), intent(in), optional :: scalar
character, intent(in), optional :: trans
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
!if(present(errst)) errst = 0
call Create(Objout, Objin%nqs, capacity=Objin%capacity, errst=errst)
!if(prop_error('Copy_qtensorc_qtensor: create', &
! errst=errst)) return
Objout%nb = Objin%nb
do ii = 1, Objout%nb
call copy(Objout%Data(ii)%Tens, Objin%Data(ii)%Tens, &
scalar=scalar, trans=trans, errst=errst)
!if(prop_error('Copy_qtensorc_qtensor: copy', &
! errst=errst)) return
allocate(Objout%Data(ii)%qq(size(Objin%Data(ii)%qq)))
Objout%Data(ii)%qq = Objin%Data(ii)%qq
Objout%hash(ii) = Objin%hash(ii)
end do
if(present(trans)) then
if((trans == 'T') .or. (trans == 'H')) then
call permute_qnumbers(Objout, errst=errst)
!if(prop_error('copy_qtensorc_qtensor : '//&
! 'permute_qnumbers failed.', &
! errst=errst)) return
end if
end if
end subroutine copy_qtensorc_qtensor
"""
return
[docs]def copy_qtensorc_qtensorc():
"""
fortran-subroutine - January 2016 (update dj)
Copy a qtensorc.
details (template defined in qTensors_include.f90)
**Arguments**
Objout : TYPE(VECTOR_TYPE), out
Store copy of Objin in this vector.
Objin : TYPE(VECTOR_TYPE), in
Copy this vector to a new vector Objout.
scalar : complex, OPTIONAL, in
Multiply input tensor with scalar during copying replacing
a copy + scale action.
trans : CHARACTER, OPTIONAL, in
The following transformation can be applied: complex conjugate ('C'),
transposition ('T', simple transposition, no permutation), conjugate
transposed ('H', simple transposition). No transformation is 'N'.
Default to 'N'.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine copy_qtensorc_qtensorc(Objout, Objin, scalar, trans, &
errst)
type(qtensorc), intent(out) :: Objout
type(qtensorc), intent(in) :: Objin
complex(KIND=rKind), intent(in), optional :: scalar
character, intent(in), optional :: trans
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
!if(present(errst)) errst = 0
call Create(Objout, Objin%nqs, capacity=Objin%capacity, errst=errst)
!if(prop_error('Copy_qtensorc_qtensorc: create', &
! errst=errst)) return
Objout%nb = Objin%nb
do ii = 1, Objout%nb
call copy(Objout%Data(ii)%Tens, Objin%Data(ii)%Tens, &
scalar=scalar, trans=trans, errst=errst)
!if(prop_error('Copy_qtensorc_qtensorc: copy', &
! errst=errst)) return
allocate(Objout%Data(ii)%qq(size(Objin%Data(ii)%qq)))
Objout%Data(ii)%qq = Objin%Data(ii)%qq
Objout%hash(ii) = Objin%hash(ii)
end do
if(present(trans)) then
if((trans == 'T') .or. (trans == 'H')) then
call permute_qnumbers(Objout, errst=errst)
!if(prop_error('copy_qtensorc_qtensorc : '//&
! 'permute_qnumbers failed.', &
! errst=errst)) return
end if
end if
end subroutine copy_qtensorc_qtensorc
"""
return
[docs]def copy_qtensorlist():
"""
fortran-subroutine - ?? ()
Copy a qtensor list.
**Arguments**
Objout : TYPE(qtensorlist), out
Copy the entries of `Objin` here.
Objin : TYPE(qtensorlist), in
source for copy into `Dest`.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine copy_qtensorlist(Objout, Objin, errst)
type(qtensorlist), intent(out) :: Objout
type(qtensorlist), intent(in) :: Objin
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
!if(present(errst)) errst = 0
allocate(Objout%Li(size(Objin%Li)))
do ii = 1, size(Objin%Li)
call copy(Objout%Li(ii), Objin%Li(ii))
end do
end subroutine copy_qtensorlist
"""
return
[docs]def copy_qtensorclist():
"""
fortran-subroutine - ?? ()
Copy a qtensorc list.
**Arguments**
Objout : TYPE(qtensorclist), out
Copy the entries of `Objin` here.
Objin : TYPE(qtensorclist), in
source for copy into `Dest`.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine copy_qtensorclist(Objout, Objin, errst)
type(qtensorclist), intent(out) :: Objout
type(qtensorclist), intent(in) :: Objin
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
!if(present(errst)) errst = 0
allocate(Objout%Li(size(Objin%Li)))
do ii = 1, size(Objin%Li)
call copy(Objout%Li(ii), Objin%Li(ii))
end do
end subroutine copy_qtensorclist
"""
return
[docs]def copy_qtensorlistarray():
"""
fortran-subroutine - ?? ()
Copy an array of qtensor lists.
**Arguments**
Objout : TYPE(qtensorlist)(\*), out
Copy the entries of `Objin` here.
Objin : TYPE(qtensorlist)(\*), in
source for copy into `Objout`
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine copy_qtensorlistarray(Objout, Objin, errst)
type(qtensorlist), pointer, intent(out) :: Objout(:)
type(qtensorlist), pointer, intent(in) :: Objin(:)
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
!if(present(errst)) errst = 0
allocate(Objout(size(Objin)))
do ii = 1, size(Objin)
call copy(Objout(ii), Objin(ii))
end do
end subroutine copy_qtensorlistarray
"""
return
[docs]def copy_qtensorclistarray():
"""
fortran-subroutine - ?? ()
Copy an array of qtensorc lists.
**Arguments**
Objout : TYPE(qtensorclist)(\*), out
Copy the entries of `Objin` here.
Objin : TYPE(qtensorclist)(\*), in
source for copy into `Objout`
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine copy_qtensorclistarray(Objout, Objin, errst)
type(qtensorclist), pointer, intent(out) :: Objout(:)
type(qtensorclist), pointer, intent(in) :: Objin(:)
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
!if(present(errst)) errst = 0
allocate(Objout(size(Objin)))
do ii = 1, size(Objin)
call copy(Objout(ii), Objin(ii))
end do
end subroutine copy_qtensorclistarray
"""
return
[docs]def create_qtensor():
"""
fortran-subroutine - ?? (mlw)
Create an empty qtensor with capacity "capacity".
details (template defined in qTensors_include.f90)
**Arguments**
Qt : TYPE(qtensor), out
Allocate the array to store the tensors for each set of quantum numbers.
nqs : INTEGER(2), in
NUmber of conserved quantum numbers on each link.
capacity : INTEGER, OPTIONAL, in
Estimation of the maximal number of sets of quantum numbers. Will be
extended when needed.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine create_qtensor(Qt, nqs, capacity, errst)
type(qtensor), intent(out) :: Qt
integer, dimension(2), intent(in) :: nqs
integer, intent(in), optional :: capacity ! optional
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! duplicate for optional argument
integer :: cap
!if(present(errst)) errst = 0
if(present(capacity)) then
cap = max(1, capacity)
else
cap = default_capacity
end if
allocate(Qt%Data(1:capacity))
do ii = 1, capacity
! Nullify all of them
Qt%Data(ii)%Tens%dl => null()
Qt%Data(ii)%Tens%mdl => null()
Qt%Data(ii)%Tens%idx => null()
Qt%Data(ii)%Tens%elem => null()
end do
allocate(Qt%hash(1:capacity))
!Qt%hash = 0.0_rKind
Qt%nb = 0
Qt%nqs = nqs
Qt%capacity = capacity
end subroutine create_qtensor
"""
return
[docs]def create_qtensorc():
"""
fortran-subroutine - ?? (mlw)
Create an empty qtensorc with capacity "capacity".
details (template defined in qTensors_include.f90)
**Arguments**
Qt : TYPE(qtensorc), out
Allocate the array to store the tensors for each set of quantum numbers.
nqs : INTEGER(2), in
NUmber of conserved quantum numbers on each link.
capacity : INTEGER, OPTIONAL, in
Estimation of the maximal number of sets of quantum numbers. Will be
extended when needed.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine create_qtensorc(Qt, nqs, capacity, errst)
type(qtensorc), intent(out) :: Qt
integer, dimension(2), intent(in) :: nqs
integer, intent(in), optional :: capacity ! optional
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! duplicate for optional argument
integer :: cap
!if(present(errst)) errst = 0
if(present(capacity)) then
cap = max(1, capacity)
else
cap = default_capacity
end if
allocate(Qt%Data(1:capacity))
do ii = 1, capacity
! Nullify all of them
Qt%Data(ii)%Tens%dl => null()
Qt%Data(ii)%Tens%mdl => null()
Qt%Data(ii)%Tens%idx => null()
Qt%Data(ii)%Tens%elem => null()
end do
allocate(Qt%hash(1:capacity))
!Qt%hash = 0.0_rKind
Qt%nb = 0
Qt%nqs = nqs
Qt%capacity = capacity
end subroutine create_qtensorc
"""
return
[docs]def create_qtensorlist():
"""
fortran-subroutine - January 2016 (update dj)
Create a qtensor list of length d1.
**Arguments**
Mats : TYPE(qtensorlist), inout
Allocate an array of size d1.
d1 : INTEGER, in
Length of the matrix list to be allocated.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine create_qtensorlist(Mats, d1, errst)
type(qtensorlist), intent(inout) :: Mats
integer, intent(in) :: d1
integer, intent(out), optional :: errst
!if(present(errst)) errst = 0
allocate(Mats%Li(d1))
end subroutine create_qtensorlist
"""
return
[docs]def create_qtensorclist():
"""
fortran-subroutine - January 2016 (update dj)
Create a qtensorc list of length d1.
**Arguments**
Mats : TYPE(qtensorclist), inout
Allocate an array of size d1.
d1 : INTEGER, in
Length of the matrix list to be allocated.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine create_qtensorclist(Mats, d1, errst)
type(qtensorclist), intent(inout) :: Mats
integer, intent(in) :: d1
integer, intent(out), optional :: errst
!if(present(errst)) errst = 0
allocate(Mats%Li(d1))
end subroutine create_qtensorclist
"""
return
[docs]def create_id_qtensor():
"""
fortran-subroutine - March 2016 (updated dj)
Create an identity matrix (or delta function).
details (template defined in qTensors_include_matrix.f90)
**Arguments**
Qm : TYPE(qtensor), out
Create and identity matrix of dimension `dim x dim`.
Qt : TYPE(qtensor), inout
Needed to extract dimension for identity matrix.
side : INTEGER, in
Either `1` or `3` depending if identity matrix should be created
as LeftDelta (`1`, first index) or RightDelta (`3`, last/third index).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine create_id_qtensor(Qm, Qt, side, errst)
type(qtensor), intent(out) :: Qm
type(qtensor), intent(inout) :: Qt
integer, intent(in) :: side
integer, intent(out), optional :: errst
! Local variables
! ---------------
! specifies range for quantum numbers
integer :: s1, s2
! for looping / indexing
integer :: ii
! num of nqs
integer :: snqs
! for sorting
integer, allocatable :: ind(:)
! store hashes
real(KIND=rKind), dimension(:), allocatable :: hashes
!if(present(errst)) errst = 0
!if(.not. ((side == 1) .or. (side == 3))) then
! errst = raise_error('create_id_qtensor: side.', &
! 99, errst=errst)
! return
!end if
snqs = sum(Qt%nqs)
s1 = snqs * (side - 1) + 1
s2 = snqs * side
! Get first/last quantum number
allocate(hashes(Qt%nb), ind(Qt%nb))
hashes = get_hash(Qt, [side])
call ascending_hsort(Qt%hash(1:Qt%nb), ind)
call create(Qm, Qt%nqs, Qt%nb)
! Create L with smallest q_{\alpha} in Qt
ii = 1
Qm%nb = Qm%nb + 1
call create_id(Qm%Data(Qm%nb)%Tens, Qt%Data(ind(ii))%Tens, side)
allocate(Qm%Data(Qm%nb)%qq(2 * snqs))
Qm%Data(Qm%nb)%qq = [Qt%Data(ind(ii))%qq(s1:s2), &
Qt%Data(ind(ii))%qq(s1:s2)]
Qm%hash(Qm%nb) = Qt%hash(ind(ii))
! Check other blocks for different quantum numbers
do ii = 2, Qt%nb
! If different, add a new block to the delta function
if(Qt%hash(ind(ii)) /= Qt%hash(ind(ii - 1))) then
Qm%nb = Qm%nb + 1
call create_id(Qm%Data(Qm%nb)%Tens, Qt%Data(ind(ii))%Tens, side)
allocate(Qm%Data(Qm%nb)%qq(2 * snqs))
Qm%Data(Qm%nb)%qq = [Qt%Data(ind(ii))%qq(s1:s2), &
Qt%Data(ind(ii))%qq(s1:s2)]
Qm%hash(Qm%nb) = Qt%hash(ind(ii))
end if
end do
deallocate(hashes, ind)
end subroutine create_id_qtensor
"""
return
[docs]def create_id_qtensorc():
"""
fortran-subroutine - March 2016 (updated dj)
Create an identity matrix (or delta function).
details (template defined in qTensors_include_matrix.f90)
**Arguments**
Qm : TYPE(qtensorc), out
Create and identity matrix of dimension `dim x dim`.
Qt : TYPE(qtensorc), inout
Needed to extract dimension for identity matrix.
side : INTEGER, in
Either `1` or `3` depending if identity matrix should be created
as LeftDelta (`1`, first index) or RightDelta (`3`, last/third index).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine create_id_qtensorc(Qm, Qt, side, errst)
type(qtensorc), intent(out) :: Qm
type(qtensorc), intent(inout) :: Qt
integer, intent(in) :: side
integer, intent(out), optional :: errst
! Local variables
! ---------------
! specifies range for quantum numbers
integer :: s1, s2
! for looping / indexing
integer :: ii
! num of nqs
integer :: snqs
! for sorting
integer, allocatable :: ind(:)
! store hashes
real(KIND=rKind), dimension(:), allocatable :: hashes
!if(present(errst)) errst = 0
!if(.not. ((side == 1) .or. (side == 3))) then
! errst = raise_error('create_id_qtensorc: side.', &
! 99, errst=errst)
! return
!end if
snqs = sum(Qt%nqs)
s1 = snqs * (side - 1) + 1
s2 = snqs * side
! Get first/last quantum number
allocate(hashes(Qt%nb), ind(Qt%nb))
hashes = get_hash(Qt, [side])
call ascending_hsort(Qt%hash(1:Qt%nb), ind)
call create(Qm, Qt%nqs, Qt%nb)
! Create L with smallest q_{\alpha} in Qt
ii = 1
Qm%nb = Qm%nb + 1
call create_id(Qm%Data(Qm%nb)%Tens, Qt%Data(ind(ii))%Tens, side)
allocate(Qm%Data(Qm%nb)%qq(2 * snqs))
Qm%Data(Qm%nb)%qq = [Qt%Data(ind(ii))%qq(s1:s2), &
Qt%Data(ind(ii))%qq(s1:s2)]
Qm%hash(Qm%nb) = Qt%hash(ind(ii))
! Check other blocks for different quantum numbers
do ii = 2, Qt%nb
! If different, add a new block to the delta function
if(Qt%hash(ind(ii)) /= Qt%hash(ind(ii - 1))) then
Qm%nb = Qm%nb + 1
call create_id(Qm%Data(Qm%nb)%Tens, Qt%Data(ind(ii))%Tens, side)
allocate(Qm%Data(Qm%nb)%qq(2 * snqs))
Qm%Data(Qm%nb)%qq = [Qt%Data(ind(ii))%qq(s1:s2), &
Qt%Data(ind(ii))%qq(s1:s2)]
Qm%hash(Qm%nb) = Qt%hash(ind(ii))
end if
end do
deallocate(hashes, ind)
end subroutine create_id_qtensorc
"""
return
[docs]def dagger_qtensor():
"""
fortran-subroutine - October 2016 (dj)
Taking complex conjugate followed by transposition of indices or
permutation.
**Arguments**
Tens : QTYPE(TENSOR_TYPE), inout
Save a transposition/permutation on the indices of this tensor.
Complex conjugated values are taken during this subroutine.
perm : INTEGER(\*), OPTIONAL, in
permutation array has length equal to the rank of the tensor with
unique entries 1 to rank.
Default to rank, rank - 1, ..., 2, 1 (transpose)
**Details**
For details of permutation look into
Tensors.f90:transpose_qtensor
(template defined in Tensors_include.f90)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine dagger_qtensor(Tens, perm, errst)
type(qtensor), intent(inout) :: Tens
integer, dimension(:), intent(in), optional :: perm
integer, intent(out), optional :: errst
call transposed(Tens, perm, errst=errst)
!if(prop_error('dagger_qtensor: transpose failed.', &
! errst=errst)) return
call conj(Tens, errst=errst)
!if(prop_error('dagger_qtensor: conjg failed.', &
! errst=errst)) return
end subroutine dagger_qtensor
"""
return
[docs]def dagger_qtensorc():
"""
fortran-subroutine - October 2016 (dj)
Taking complex conjugate followed by transposition of indices or
permutation.
**Arguments**
Tens : QTYPE(TENSOR_TYPE), inout
Save a transposition/permutation on the indices of this tensor.
Complex conjugated values are taken during this subroutine.
perm : INTEGER(\*), OPTIONAL, in
permutation array has length equal to the rank of the tensor with
unique entries 1 to rank.
Default to rank, rank - 1, ..., 2, 1 (transpose)
**Details**
For details of permutation look into
Tensors.f90:transpose_qtensorc
(template defined in Tensors_include.f90)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine dagger_qtensorc(Tens, perm, errst)
type(qtensorc), intent(inout) :: Tens
integer, dimension(:), intent(in), optional :: perm
integer, intent(out), optional :: errst
call transposed(Tens, perm, errst=errst)
!if(prop_error('dagger_qtensorc: transpose failed.', &
! errst=errst)) return
call conj(Tens, errst=errst)
!if(prop_error('dagger_qtensorc: conjg failed.', &
! errst=errst)) return
end subroutine dagger_qtensorc
"""
return
[docs]def destroy_qtensor():
"""
fortran-subroutine - January 2016 (update dj)
Destroy the contents of the vector and then the vector itself using the
``destroy(.)`` method of the data itself.
details (template defined in qTensors_include.f90)
**Arguments**
Qt : TYPE(qtensor) , inout
Deallocate all blocks and the arrays of the qtensor.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine destroy_qtensor(Qt, errst)
type(qtensor), intent(inout) :: Qt
integer, intent(out), optional :: errst
! Local Variables
! ---------------
! for looping
integer :: ii
do ii = 1, Qt%nb
call destroy(Qt%Data(ii)%Tens, errst=errst)
!if(prop_error('destroy_qtensor: destroy failed', &
! errst=errst)) return
deallocate(Qt%Data(ii)%qq)
end do
!if(.not. associated(Qt%hash)) then
! errst = raise_error('destroy_qtensor: hash not '//&
! 'allocated.', 99, 'qTensors_include.f90:2367', &
! errst=errst)
!end if
deallocate(Qt%hash)
deallocate(Qt%Data)
Qt%nb = -1
Qt%capacity = 0
Qt%nqs = 0
end subroutine destroy_qtensor
"""
return
[docs]def destroy_qtensorc():
"""
fortran-subroutine - January 2016 (update dj)
Destroy the contents of the vector and then the vector itself using the
``destroy(.)`` method of the data itself.
details (template defined in qTensors_include.f90)
**Arguments**
Qt : TYPE(qtensorc) , inout
Deallocate all blocks and the arrays of the qtensorc.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine destroy_qtensorc(Qt, errst)
type(qtensorc), intent(inout) :: Qt
integer, intent(out), optional :: errst
! Local Variables
! ---------------
! for looping
integer :: ii
do ii = 1, Qt%nb
call destroy(Qt%Data(ii)%Tens, errst=errst)
!if(prop_error('destroy_qtensorc: destroy failed', &
! errst=errst)) return
deallocate(Qt%Data(ii)%qq)
end do
!if(.not. associated(Qt%hash)) then
! errst = raise_error('destroy_qtensorc: hash not '//&
! 'allocated.', 99, 'qTensors_include.f90:2367', &
! errst=errst)
!end if
deallocate(Qt%hash)
deallocate(Qt%Data)
Qt%nb = -1
Qt%capacity = 0
Qt%nqs = 0
end subroutine destroy_qtensorc
"""
return
[docs]def destroy_qtensorlist():
"""
fortran-subroutine - January 2016 (update dj)
Destroy a list of qtensor.
**Arguments**
Mats : TYPE(qtensorlist) , inout
Deallocate the array of matrixs (including each matrix).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine destroy_qtensorlist(Mats)
type(qtensorlist), intent(inout) :: Mats
! Local variables
! ---------------
! for looping
integer :: ii
do ii = 1, size(Mats%Li)
call destroy(Mats%Li(ii))
end do
deallocate(Mats%Li)
end subroutine destroy_qtensorlist
"""
return
[docs]def destroy_qtensorclist():
"""
fortran-subroutine - January 2016 (update dj)
Destroy a list of qtensorc.
**Arguments**
Mats : TYPE(qtensorclist) , inout
Deallocate the array of matrixs (including each matrix).
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine destroy_qtensorclist(Mats)
type(qtensorclist), intent(inout) :: Mats
! Local variables
! ---------------
! for looping
integer :: ii
do ii = 1, size(Mats%Li)
call destroy(Mats%Li(ii))
end do
deallocate(Mats%Li)
end subroutine destroy_qtensorclist
"""
return
[docs]def dot_qtensor():
"""
fortran-function - March 2016 (update dj)
Compute dot product <A, B> for qtensor.
details (template defined in qTensors_include.f90)
**Arguments**
Qta : TYPE(qtensor), inout
First vector in the dot product (taken with complex conjugated values
for complex arrays).
Qtb : TYPE(qtensor), inout
Second vector in the dot product. Has to be the same size as first
vector.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function dot_qtensor(Qta, Qtb, errst) result(dotprod)
type(qtensor), intent(inout) :: Qta, Qtb
integer, intent(out), optional :: errst
real(KIND=rKind) :: dotprod
! Local variables
! ---------------
! for looping / indexing
integer :: ii
! number of tensors to contract
integer :: ni
! contraction of those legs (all legs)
integer, dimension(:), allocatable :: idxab
! contraction indices
integer, dimension(:, :), allocatable :: cidx
integer, dimension(:), allocatable :: indout, degout
!if(present(errst)) errst = 0
dotprod = 0.0_rKind
! Fast return
if((Qta%nb == 0) .or. (Qtb%nb == 0)) return
!if(size(Qta%Data(1)%qq, 1) /= size(Qtb%Data(1)%qq, 1)) then
! errst = raise_error('dot_qtensor: mismatch.', &
! 2, errst=errst)
! return
!end if
allocate(idxab(size(Qta%Data(1)%qq, 1) / sum(Qta%nqs)), &
cidx(2, Qta%nb * Qtb%nb))
idxab = [(ii, ii = 1, size(Qta%Data(1)%qq, 1) / sum(Qta%nqs))]
call get_contr_idx(Qta, idxab, Qtb, idxab, [.false., .false.], &
cidx, ni, indout, degout, errst=errst)
!if(prop_error('dot_qtensor: contr idx failed.', &
! 'qTensors_include.f90:2490', errst=errst)) return
if(ni > 0) then
do ii = 1, degout(ni + 1)
dotprod = dotprod + dot(Qta%Data(cidx(1, ii))%Tens, &
Qtb%Data(cidx(2, ii))%Tens, errst=errst)
!if(prop_error('dot_qtensor: dot ii failed', &
! 'qTensors_include.f90:2497', errst=errst)) return
end do
end if
deallocate(idxab, cidx)
if(ni > 0) deallocate(degout, indout)
end function dot_qtensor
"""
return
[docs]def dot_qtensorc():
"""
fortran-function - March 2016 (update dj)
Compute dot product <A, B> for qtensorc.
details (template defined in qTensors_include.f90)
**Arguments**
Qta : TYPE(qtensorc), inout
First vector in the dot product (taken with complex conjugated values
for complex arrays).
Qtb : TYPE(qtensorc), inout
Second vector in the dot product. Has to be the same size as first
vector.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function dot_qtensorc(Qta, Qtb, errst) result(dotprod)
type(qtensorc), intent(inout) :: Qta, Qtb
integer, intent(out), optional :: errst
complex(KIND=rKind) :: dotprod
! Local variables
! ---------------
! for looping / indexing
integer :: ii
! number of tensors to contract
integer :: ni
! contraction of those legs (all legs)
integer, dimension(:), allocatable :: idxab
! contraction indices
integer, dimension(:, :), allocatable :: cidx
integer, dimension(:), allocatable :: indout, degout
!if(present(errst)) errst = 0
dotprod = 0.0_rKind
! Fast return
if((Qta%nb == 0) .or. (Qtb%nb == 0)) return
!if(size(Qta%Data(1)%qq, 1) /= size(Qtb%Data(1)%qq, 1)) then
! errst = raise_error('dot_qtensorc: mismatch.', &
! 2, errst=errst)
! return
!end if
allocate(idxab(size(Qta%Data(1)%qq, 1) / sum(Qta%nqs)), &
cidx(2, Qta%nb * Qtb%nb))
idxab = [(ii, ii = 1, size(Qta%Data(1)%qq, 1) / sum(Qta%nqs))]
call get_contr_idx(Qta, idxab, Qtb, idxab, [.false., .false.], &
cidx, ni, indout, degout, errst=errst)
!if(prop_error('dot_qtensorc: contr idx failed.', &
! 'qTensors_include.f90:2490', errst=errst)) return
if(ni > 0) then
do ii = 1, degout(ni + 1)
dotprod = dotprod + dot(Qta%Data(cidx(1, ii))%Tens, &
Qtb%Data(cidx(2, ii))%Tens, errst=errst)
!if(prop_error('dot_qtensorc: dot ii failed', &
! 'qTensors_include.f90:2497', errst=errst)) return
end do
end if
deallocate(idxab, cidx)
if(ni > 0) deallocate(degout, indout)
end function dot_qtensorc
"""
return
[docs]def expm_qtensor_real_qtensor():
"""
fortran-subroutine - ?? (dj)
Take the exponential of a tensor assuming an underlying matrix.
**Arguments**
Texp : TYPE(qtensor), out
This is on exit the exponetial. Has rank and dimensions of
the input tensor.
sc : real, in
Additional scalar inside exp-function.
Tens : TYPE(qtensor), inout
Take the exponential of this tensor.
last_row_idx : INTEGER, in
The dimension for the rows are calculated as
product(Tens%dl(:last_row_idx)). The remaining indices
build the column.
**Details**
All diagonal blocks of the identity must be set, either with
values or as dummy zero block. Blocks of zeros will be an identity
after epx, but blocks not present will be still zero.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine expm_qtensor_real_qtensor(Texp, sc, Tens, &
last_row_idx, errst)
type(qtensor), intent(out) :: Texp
real(KIND=rKind), intent(in) :: sc
type(qtensor), intent(inout) :: Tens
integer, intent(in) :: last_row_idx
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! rank of the tensor
integer :: rnk
! the indices for the rows / columns
integer, dimension(:), allocatable :: ridx, cidx
! number of quantum numbers at splitting
integer :: nunique
!
type(vector_int), dimension(:), allocatable :: Lmap, Rmap
!
type(vector_int), dimension(:), allocatable :: Rowcut, Colcut
!
integer, dimension(:), allocatable :: nts_row, nts_col, deghash, idxhash
! matrices to be exponentiated
type(tensorlist) :: Mats
! result of the exponential
type(tensorlist) :: Mexp
!if(present(errst)) errst = 0
! Fast return (Identity)
if(Tens%nb == 0) then
call create(Texp, Tens%nqs, 0)
errst = raise_error('exp_real_qtensor : Id '//&
'for zero missing.', 99, errst=errst)
return
end if
rnk = rank(Tens)
allocate(ridx(last_row_idx), cidx(rnk - last_row_idx))
ridx = [(ii, ii = 1, last_row_idx)]
cidx = [(ii, ii = last_row_idx + 1, rnk)]
call block(Tens, ridx, cidx, Mats, nunique, Lmap, Rmap, &
Rowcut, Colcut, nts_row, nts_col, deghash, &
idxhash, ham=.true., errst=errst)
!if(prop_error('exp_real_qtensor : block failed.', &
! errst=errst)) return
! Get array for exponential
call create(Mexp, nunique)
! Exponentiate all blocks
do ii = 1, nunique
call expm(Mexp%Li(ii), sc, Mats%Li(ii), 1, errst=errst)
!if(prop_error('exp_real_qtensor : '//&
! 'exp failed.', errst=errst)) return
end do
! Can destroy the actual matrices now
call destroy(Mats)
call copy(Texp, Tens)
call block2tensor_both(Texp, Mexp, Lmap, Rmap, Rowcut, Colcut, &
nts_row, nts_col, deghash, idxhash, nunique, &
last_row_idx, errst=errst)
!if(prop_error('exp_real_qtensor : block2tensor'//&
! '_both failed.', errst=errst)) return
deallocate(deghash, idxhash, ridx, cidx)
end subroutine expm_qtensor_real_qtensor
"""
return
[docs]def expm_qtensorc_real_qtensor():
"""
fortran-subroutine - ?? (dj)
Take the exponential of a tensor assuming an underlying matrix.
**Arguments**
Texp : TYPE(qtensorc), out
This is on exit the exponetial. Has rank and dimensions of
the input tensor.
sc : real, in
Additional scalar inside exp-function.
Tens : TYPE(qtensor), inout
Take the exponential of this tensor.
last_row_idx : INTEGER, in
The dimension for the rows are calculated as
product(Tens%dl(:last_row_idx)). The remaining indices
build the column.
**Details**
All diagonal blocks of the identity must be set, either with
values or as dummy zero block. Blocks of zeros will be an identity
after epx, but blocks not present will be still zero.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine expm_qtensorc_real_qtensor(Texp, sc, Tens, &
last_row_idx, errst)
type(qtensorc), intent(out) :: Texp
real(KIND=rKind), intent(in) :: sc
type(qtensor), intent(inout) :: Tens
integer, intent(in) :: last_row_idx
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! rank of the tensor
integer :: rnk
! the indices for the rows / columns
integer, dimension(:), allocatable :: ridx, cidx
! number of quantum numbers at splitting
integer :: nunique
!
type(vector_int), dimension(:), allocatable :: Lmap, Rmap
!
type(vector_int), dimension(:), allocatable :: Rowcut, Colcut
!
integer, dimension(:), allocatable :: nts_row, nts_col, deghash, idxhash
! matrices to be exponentiated
type(tensorlist) :: Mats
! result of the exponential
type(tensorlistc) :: Mexp
!if(present(errst)) errst = 0
! Fast return (Identity)
if(Tens%nb == 0) then
call create(Texp, Tens%nqs, 0)
errst = raise_error('exp_real_qtensor : Id '//&
'for zero missing.', 99, errst=errst)
return
end if
rnk = rank(Tens)
allocate(ridx(last_row_idx), cidx(rnk - last_row_idx))
ridx = [(ii, ii = 1, last_row_idx)]
cidx = [(ii, ii = last_row_idx + 1, rnk)]
call block(Tens, ridx, cidx, Mats, nunique, Lmap, Rmap, &
Rowcut, Colcut, nts_row, nts_col, deghash, &
idxhash, ham=.true., errst=errst)
!if(prop_error('exp_real_qtensor : block failed.', &
! errst=errst)) return
! Get array for exponential
call create(Mexp, nunique)
! Exponentiate all blocks
do ii = 1, nunique
call expm(Mexp%Li(ii), sc, Mats%Li(ii), 1, errst=errst)
!if(prop_error('exp_real_qtensor : '//&
! 'exp failed.', errst=errst)) return
end do
! Can destroy the actual matrices now
call destroy(Mats)
call copy(Texp, Tens)
call block2tensor_both(Texp, Mexp, Lmap, Rmap, Rowcut, Colcut, &
nts_row, nts_col, deghash, idxhash, nunique, &
last_row_idx, errst=errst)
!if(prop_error('exp_real_qtensor : block2tensor'//&
! '_both failed.', errst=errst)) return
deallocate(deghash, idxhash, ridx, cidx)
end subroutine expm_qtensorc_real_qtensor
"""
return
[docs]def expm_qtensorc_complex_qtensor():
"""
fortran-subroutine - ?? (dj)
Take the exponential of a tensor assuming an underlying matrix.
**Arguments**
Texp : TYPE(qtensorc), out
This is on exit the exponetial. Has rank and dimensions of
the input tensor.
sc : complex, in
Additional scalar inside exp-function.
Tens : TYPE(qtensor), inout
Take the exponential of this tensor.
last_row_idx : INTEGER, in
The dimension for the rows are calculated as
product(Tens%dl(:last_row_idx)). The remaining indices
build the column.
**Details**
All diagonal blocks of the identity must be set, either with
values or as dummy zero block. Blocks of zeros will be an identity
after epx, but blocks not present will be still zero.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine expm_qtensorc_complex_qtensor(Texp, sc, Tens, &
last_row_idx, errst)
type(qtensorc), intent(out) :: Texp
complex(KIND=rKind), intent(in) :: sc
type(qtensor), intent(inout) :: Tens
integer, intent(in) :: last_row_idx
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! rank of the tensor
integer :: rnk
! the indices for the rows / columns
integer, dimension(:), allocatable :: ridx, cidx
! number of quantum numbers at splitting
integer :: nunique
!
type(vector_int), dimension(:), allocatable :: Lmap, Rmap
!
type(vector_int), dimension(:), allocatable :: Rowcut, Colcut
!
integer, dimension(:), allocatable :: nts_row, nts_col, deghash, idxhash
! matrices to be exponentiated
type(tensorlist) :: Mats
! result of the exponential
type(tensorlistc) :: Mexp
!if(present(errst)) errst = 0
! Fast return (Identity)
if(Tens%nb == 0) then
call create(Texp, Tens%nqs, 0)
errst = raise_error('exp_complex_qtensor : Id '//&
'for zero missing.', 99, errst=errst)
return
end if
rnk = rank(Tens)
allocate(ridx(last_row_idx), cidx(rnk - last_row_idx))
ridx = [(ii, ii = 1, last_row_idx)]
cidx = [(ii, ii = last_row_idx + 1, rnk)]
call block(Tens, ridx, cidx, Mats, nunique, Lmap, Rmap, &
Rowcut, Colcut, nts_row, nts_col, deghash, &
idxhash, ham=.true., errst=errst)
!if(prop_error('exp_complex_qtensor : block failed.', &
! errst=errst)) return
! Get array for exponential
call create(Mexp, nunique)
! Exponentiate all blocks
do ii = 1, nunique
call expm(Mexp%Li(ii), sc, Mats%Li(ii), 1, errst=errst)
!if(prop_error('exp_complex_qtensor : '//&
! 'exp failed.', errst=errst)) return
end do
! Can destroy the actual matrices now
call destroy(Mats)
call copy(Texp, Tens)
call block2tensor_both(Texp, Mexp, Lmap, Rmap, Rowcut, Colcut, &
nts_row, nts_col, deghash, idxhash, nunique, &
last_row_idx, errst=errst)
!if(prop_error('exp_complex_qtensor : block2tensor'//&
! '_both failed.', errst=errst)) return
deallocate(deghash, idxhash, ridx, cidx)
end subroutine expm_qtensorc_complex_qtensor
"""
return
[docs]def expm_qtensorc_real_qtensorc():
"""
fortran-subroutine - ?? (dj)
Take the exponential of a tensor assuming an underlying matrix.
**Arguments**
Texp : TYPE(qtensorc), out
This is on exit the exponetial. Has rank and dimensions of
the input tensor.
sc : real, in
Additional scalar inside exp-function.
Tens : TYPE(qtensorc), inout
Take the exponential of this tensor.
last_row_idx : INTEGER, in
The dimension for the rows are calculated as
product(Tens%dl(:last_row_idx)). The remaining indices
build the column.
**Details**
All diagonal blocks of the identity must be set, either with
values or as dummy zero block. Blocks of zeros will be an identity
after epx, but blocks not present will be still zero.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine expm_qtensorc_real_qtensorc(Texp, sc, Tens, &
last_row_idx, errst)
type(qtensorc), intent(out) :: Texp
real(KIND=rKind), intent(in) :: sc
type(qtensorc), intent(inout) :: Tens
integer, intent(in) :: last_row_idx
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! rank of the tensor
integer :: rnk
! the indices for the rows / columns
integer, dimension(:), allocatable :: ridx, cidx
! number of quantum numbers at splitting
integer :: nunique
!
type(vector_int), dimension(:), allocatable :: Lmap, Rmap
!
type(vector_int), dimension(:), allocatable :: Rowcut, Colcut
!
integer, dimension(:), allocatable :: nts_row, nts_col, deghash, idxhash
! matrices to be exponentiated
type(tensorlistc) :: Mats
! result of the exponential
type(tensorlistc) :: Mexp
!if(present(errst)) errst = 0
! Fast return (Identity)
if(Tens%nb == 0) then
call create(Texp, Tens%nqs, 0)
errst = raise_error('exp_real_qtensorc : Id '//&
'for zero missing.', 99, errst=errst)
return
end if
rnk = rank(Tens)
allocate(ridx(last_row_idx), cidx(rnk - last_row_idx))
ridx = [(ii, ii = 1, last_row_idx)]
cidx = [(ii, ii = last_row_idx + 1, rnk)]
call block(Tens, ridx, cidx, Mats, nunique, Lmap, Rmap, &
Rowcut, Colcut, nts_row, nts_col, deghash, &
idxhash, ham=.true., errst=errst)
!if(prop_error('exp_real_qtensorc : block failed.', &
! errst=errst)) return
! Get array for exponential
call create(Mexp, nunique)
! Exponentiate all blocks
do ii = 1, nunique
call expm(Mexp%Li(ii), sc, Mats%Li(ii), 1, errst=errst)
!if(prop_error('exp_real_qtensorc : '//&
! 'exp failed.', errst=errst)) return
end do
! Can destroy the actual matrices now
call destroy(Mats)
call copy(Texp, Tens)
call block2tensor_both(Texp, Mexp, Lmap, Rmap, Rowcut, Colcut, &
nts_row, nts_col, deghash, idxhash, nunique, &
last_row_idx, errst=errst)
!if(prop_error('exp_real_qtensorc : block2tensor'//&
! '_both failed.', errst=errst)) return
deallocate(deghash, idxhash, ridx, cidx)
end subroutine expm_qtensorc_real_qtensorc
"""
return
[docs]def expm_qtensorc_complex_qtensorc():
"""
fortran-subroutine - ?? (dj)
Take the exponential of a tensor assuming an underlying matrix.
**Arguments**
Texp : TYPE(qtensorc), out
This is on exit the exponetial. Has rank and dimensions of
the input tensor.
sc : complex, in
Additional scalar inside exp-function.
Tens : TYPE(qtensorc), inout
Take the exponential of this tensor.
last_row_idx : INTEGER, in
The dimension for the rows are calculated as
product(Tens%dl(:last_row_idx)). The remaining indices
build the column.
**Details**
All diagonal blocks of the identity must be set, either with
values or as dummy zero block. Blocks of zeros will be an identity
after epx, but blocks not present will be still zero.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine expm_qtensorc_complex_qtensorc(Texp, sc, Tens, &
last_row_idx, errst)
type(qtensorc), intent(out) :: Texp
complex(KIND=rKind), intent(in) :: sc
type(qtensorc), intent(inout) :: Tens
integer, intent(in) :: last_row_idx
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! rank of the tensor
integer :: rnk
! the indices for the rows / columns
integer, dimension(:), allocatable :: ridx, cidx
! number of quantum numbers at splitting
integer :: nunique
!
type(vector_int), dimension(:), allocatable :: Lmap, Rmap
!
type(vector_int), dimension(:), allocatable :: Rowcut, Colcut
!
integer, dimension(:), allocatable :: nts_row, nts_col, deghash, idxhash
! matrices to be exponentiated
type(tensorlistc) :: Mats
! result of the exponential
type(tensorlistc) :: Mexp
!if(present(errst)) errst = 0
! Fast return (Identity)
if(Tens%nb == 0) then
call create(Texp, Tens%nqs, 0)
errst = raise_error('exp_complex_qtensorc : Id '//&
'for zero missing.', 99, errst=errst)
return
end if
rnk = rank(Tens)
allocate(ridx(last_row_idx), cidx(rnk - last_row_idx))
ridx = [(ii, ii = 1, last_row_idx)]
cidx = [(ii, ii = last_row_idx + 1, rnk)]
call block(Tens, ridx, cidx, Mats, nunique, Lmap, Rmap, &
Rowcut, Colcut, nts_row, nts_col, deghash, &
idxhash, ham=.true., errst=errst)
!if(prop_error('exp_complex_qtensorc : block failed.', &
! errst=errst)) return
! Get array for exponential
call create(Mexp, nunique)
! Exponentiate all blocks
do ii = 1, nunique
call expm(Mexp%Li(ii), sc, Mats%Li(ii), 1, errst=errst)
!if(prop_error('exp_complex_qtensorc : '//&
! 'exp failed.', errst=errst)) return
end do
! Can destroy the actual matrices now
call destroy(Mats)
call copy(Texp, Tens)
call block2tensor_both(Texp, Mexp, Lmap, Rmap, Rowcut, Colcut, &
nts_row, nts_col, deghash, idxhash, nunique, &
last_row_idx, errst=errst)
!if(prop_error('exp_complex_qtensorc : block2tensor'//&
! '_both failed.', errst=errst)) return
deallocate(deghash, idxhash, ridx, cidx)
end subroutine expm_qtensorc_complex_qtensorc
"""
return
[docs]def expmh_real_qtensor():
"""
fortran-subroutine - ?? (dj)
Take the exponential of a tensor assuming an underlying hermitian
matrix.
**Arguments**
Texp : TYPE(qtensor), out
This is on exit the exponetial. Has rank and dimensions of
the input tensor.
sc : real, in
Additional scalar inside exp-function.
Tens : TYPE(qtensor), inout
Take the exponential of this tensor.
last_row_idx : INTEGER, in
The dimension for the rows are calculated as
product(Tens%dl(:last_row_idx)). The remaining indices
build the column.
**Details**
Subroutines does not check if matrix is actually hermitian.
All diagonal blocks of the identity must be set, either with values
or as dummy zero block. Blocks of zeros will be an identity after epxh,
but blocks not present will be still zero.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine expmh_real_qtensor(Texp, sc, Tens, last_row_idx, &
errst)
type(qtensor), intent(out) :: Texp
real(KIND=rKind), intent(in) :: sc
type(qtensor), intent(inout) :: Tens
integer, intent(in) :: last_row_idx
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! rank of the tensor
integer :: rnk
! the indices for the rows / columns
integer, dimension(:), allocatable :: ridx, cidx
! number of quantum numbers at splitting
integer :: nunique
!
type(vector_int), dimension(:), allocatable :: Lmap, Rmap
!
type(vector_int), dimension(:), allocatable :: Rowcut, Colcut
!
integer, dimension(:), allocatable :: nts_row, nts_col, deghash, idxhash
! matrices to be exponentiated
type(tensorlist) :: Mats
! result of the exponential
type(tensorlist) :: Mexp
!if(present(errst)) errst = 0
! Fast return (Identity)
if(Tens%nb == 0) then
call create(Texp, Tens%nqs, 0)
errst = raise_error('exph_real_qtensor : Id '//&
'for zero missing.', 99, errst=errst)
return
end if
rnk = rank(Tens)
allocate(ridx(last_row_idx), cidx(rnk - last_row_idx))
ridx = [(ii, ii = 1, last_row_idx)]
cidx = [(ii, ii = last_row_idx + 1, rnk)]
call block(Tens, ridx, cidx, Mats, nunique, Lmap, Rmap, &
Rowcut, Colcut, nts_row, nts_col, deghash, &
idxhash, ham=.true., errst=errst)
!if(prop_error('exph_real_qtensor : block failed.', &
! errst=errst)) return
! Get array for exponential
call create(Mexp, nunique)
! Exponentiate all blocks
do ii = 1, nunique
call expmh(Mexp%Li(ii), sc, Mats%Li(ii), 1, errst=errst)
!if(prop_error('exph_real_qtensor : '//&
! 'exph failed.', errst=errst)) return
end do
! Can destroy the actual matrices now
call destroy(Mats)
call copy(Texp, Tens)
call block2tensor_both(Texp, Mexp, Lmap, Rmap, Rowcut, Colcut, &
nts_row, nts_col, deghash, idxhash, nunique, &
last_row_idx, errst=errst)
!if(prop_error('exph_real_qtensor : block2tensor'//&
! '_both failed.', errst=errst)) return
deallocate(deghash, idxhash, ridx, cidx)
end subroutine expmh_real_qtensor
"""
return
[docs]def expmh_complex_qtensor():
"""
fortran-subroutine - ?? (dj)
Take the exponential of a tensor assuming an underlying hermitian
matrix.
**Arguments**
Texp : TYPE(qtensorc), out
This is on exit the exponetial. Has rank and dimensions of
the input tensor.
sc : complex, in
Additional scalar inside exp-function.
Tens : TYPE(qtensor), inout
Take the exponential of this tensor.
last_row_idx : INTEGER, in
The dimension for the rows are calculated as
product(Tens%dl(:last_row_idx)). The remaining indices
build the column.
**Details**
Subroutines does not check if matrix is actually hermitian.
All diagonal blocks of the identity must be set, either with values
or as dummy zero block. Blocks of zeros will be an identity after epxh,
but blocks not present will be still zero.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine expmh_complex_qtensor(Texp, sc, Tens, last_row_idx, &
errst)
type(qtensorc), intent(out) :: Texp
complex(KIND=rKind), intent(in) :: sc
type(qtensor), intent(inout) :: Tens
integer, intent(in) :: last_row_idx
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! rank of the tensor
integer :: rnk
! the indices for the rows / columns
integer, dimension(:), allocatable :: ridx, cidx
! number of quantum numbers at splitting
integer :: nunique
!
type(vector_int), dimension(:), allocatable :: Lmap, Rmap
!
type(vector_int), dimension(:), allocatable :: Rowcut, Colcut
!
integer, dimension(:), allocatable :: nts_row, nts_col, deghash, idxhash
! matrices to be exponentiated
type(tensorlist) :: Mats
! result of the exponential
type(tensorlistc) :: Mexp
!if(present(errst)) errst = 0
! Fast return (Identity)
if(Tens%nb == 0) then
call create(Texp, Tens%nqs, 0)
errst = raise_error('exph_complex_qtensor : Id '//&
'for zero missing.', 99, errst=errst)
return
end if
rnk = rank(Tens)
allocate(ridx(last_row_idx), cidx(rnk - last_row_idx))
ridx = [(ii, ii = 1, last_row_idx)]
cidx = [(ii, ii = last_row_idx + 1, rnk)]
call block(Tens, ridx, cidx, Mats, nunique, Lmap, Rmap, &
Rowcut, Colcut, nts_row, nts_col, deghash, &
idxhash, ham=.true., errst=errst)
!if(prop_error('exph_complex_qtensor : block failed.', &
! errst=errst)) return
! Get array for exponential
call create(Mexp, nunique)
! Exponentiate all blocks
do ii = 1, nunique
call expmh(Mexp%Li(ii), sc, Mats%Li(ii), 1, errst=errst)
!if(prop_error('exph_complex_qtensor : '//&
! 'exph failed.', errst=errst)) return
end do
! Can destroy the actual matrices now
call destroy(Mats)
call copy(Texp, Tens)
call block2tensor_both(Texp, Mexp, Lmap, Rmap, Rowcut, Colcut, &
nts_row, nts_col, deghash, idxhash, nunique, &
last_row_idx, errst=errst)
!if(prop_error('exph_complex_qtensor : block2tensor'//&
! '_both failed.', errst=errst)) return
deallocate(deghash, idxhash, ridx, cidx)
end subroutine expmh_complex_qtensor
"""
return
[docs]def expmh_real_qtensorc():
"""
fortran-subroutine - ?? (dj)
Take the exponential of a tensor assuming an underlying hermitian
matrix.
**Arguments**
Texp : TYPE(qtensorc), out
This is on exit the exponetial. Has rank and dimensions of
the input tensor.
sc : real, in
Additional scalar inside exp-function.
Tens : TYPE(qtensorc), inout
Take the exponential of this tensor.
last_row_idx : INTEGER, in
The dimension for the rows are calculated as
product(Tens%dl(:last_row_idx)). The remaining indices
build the column.
**Details**
Subroutines does not check if matrix is actually hermitian.
All diagonal blocks of the identity must be set, either with values
or as dummy zero block. Blocks of zeros will be an identity after epxh,
but blocks not present will be still zero.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine expmh_real_qtensorc(Texp, sc, Tens, last_row_idx, &
errst)
type(qtensorc), intent(out) :: Texp
real(KIND=rKind), intent(in) :: sc
type(qtensorc), intent(inout) :: Tens
integer, intent(in) :: last_row_idx
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! rank of the tensor
integer :: rnk
! the indices for the rows / columns
integer, dimension(:), allocatable :: ridx, cidx
! number of quantum numbers at splitting
integer :: nunique
!
type(vector_int), dimension(:), allocatable :: Lmap, Rmap
!
type(vector_int), dimension(:), allocatable :: Rowcut, Colcut
!
integer, dimension(:), allocatable :: nts_row, nts_col, deghash, idxhash
! matrices to be exponentiated
type(tensorlistc) :: Mats
! result of the exponential
type(tensorlistc) :: Mexp
!if(present(errst)) errst = 0
! Fast return (Identity)
if(Tens%nb == 0) then
call create(Texp, Tens%nqs, 0)
errst = raise_error('exph_real_qtensorc : Id '//&
'for zero missing.', 99, errst=errst)
return
end if
rnk = rank(Tens)
allocate(ridx(last_row_idx), cidx(rnk - last_row_idx))
ridx = [(ii, ii = 1, last_row_idx)]
cidx = [(ii, ii = last_row_idx + 1, rnk)]
call block(Tens, ridx, cidx, Mats, nunique, Lmap, Rmap, &
Rowcut, Colcut, nts_row, nts_col, deghash, &
idxhash, ham=.true., errst=errst)
!if(prop_error('exph_real_qtensorc : block failed.', &
! errst=errst)) return
! Get array for exponential
call create(Mexp, nunique)
! Exponentiate all blocks
do ii = 1, nunique
call expmh(Mexp%Li(ii), sc, Mats%Li(ii), 1, errst=errst)
!if(prop_error('exph_real_qtensorc : '//&
! 'exph failed.', errst=errst)) return
end do
! Can destroy the actual matrices now
call destroy(Mats)
call copy(Texp, Tens)
call block2tensor_both(Texp, Mexp, Lmap, Rmap, Rowcut, Colcut, &
nts_row, nts_col, deghash, idxhash, nunique, &
last_row_idx, errst=errst)
!if(prop_error('exph_real_qtensorc : block2tensor'//&
! '_both failed.', errst=errst)) return
deallocate(deghash, idxhash, ridx, cidx)
end subroutine expmh_real_qtensorc
"""
return
[docs]def expmh_complex_qtensorc():
"""
fortran-subroutine - ?? (dj)
Take the exponential of a tensor assuming an underlying hermitian
matrix.
**Arguments**
Texp : TYPE(qtensorc), out
This is on exit the exponetial. Has rank and dimensions of
the input tensor.
sc : complex, in
Additional scalar inside exp-function.
Tens : TYPE(qtensorc), inout
Take the exponential of this tensor.
last_row_idx : INTEGER, in
The dimension for the rows are calculated as
product(Tens%dl(:last_row_idx)). The remaining indices
build the column.
**Details**
Subroutines does not check if matrix is actually hermitian.
All diagonal blocks of the identity must be set, either with values
or as dummy zero block. Blocks of zeros will be an identity after epxh,
but blocks not present will be still zero.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine expmh_complex_qtensorc(Texp, sc, Tens, last_row_idx, &
errst)
type(qtensorc), intent(out) :: Texp
complex(KIND=rKind), intent(in) :: sc
type(qtensorc), intent(inout) :: Tens
integer, intent(in) :: last_row_idx
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! rank of the tensor
integer :: rnk
! the indices for the rows / columns
integer, dimension(:), allocatable :: ridx, cidx
! number of quantum numbers at splitting
integer :: nunique
!
type(vector_int), dimension(:), allocatable :: Lmap, Rmap
!
type(vector_int), dimension(:), allocatable :: Rowcut, Colcut
!
integer, dimension(:), allocatable :: nts_row, nts_col, deghash, idxhash
! matrices to be exponentiated
type(tensorlistc) :: Mats
! result of the exponential
type(tensorlistc) :: Mexp
!if(present(errst)) errst = 0
! Fast return (Identity)
if(Tens%nb == 0) then
call create(Texp, Tens%nqs, 0)
errst = raise_error('exph_complex_qtensorc : Id '//&
'for zero missing.', 99, errst=errst)
return
end if
rnk = rank(Tens)
allocate(ridx(last_row_idx), cidx(rnk - last_row_idx))
ridx = [(ii, ii = 1, last_row_idx)]
cidx = [(ii, ii = last_row_idx + 1, rnk)]
call block(Tens, ridx, cidx, Mats, nunique, Lmap, Rmap, &
Rowcut, Colcut, nts_row, nts_col, deghash, &
idxhash, ham=.true., errst=errst)
!if(prop_error('exph_complex_qtensorc : block failed.', &
! errst=errst)) return
! Get array for exponential
call create(Mexp, nunique)
! Exponentiate all blocks
do ii = 1, nunique
call expmh(Mexp%Li(ii), sc, Mats%Li(ii), 1, errst=errst)
!if(prop_error('exph_complex_qtensorc : '//&
! 'exph failed.', errst=errst)) return
end do
! Can destroy the actual matrices now
call destroy(Mats)
call copy(Texp, Tens)
call block2tensor_both(Texp, Mexp, Lmap, Rmap, Rowcut, Colcut, &
nts_row, nts_col, deghash, idxhash, nunique, &
last_row_idx, errst=errst)
!if(prop_error('exph_complex_qtensorc : block2tensor'//&
! '_both failed.', errst=errst)) return
deallocate(deghash, idxhash, ridx, cidx)
end subroutine expmh_complex_qtensorc
"""
return
[docs]def extend_qtensor():
"""
fortran-subroutine - October 2016 (dj)
Extend space for n new elements. If the required space is less than
capacity, nothing happens. Otherwise, increase the capacity.
details (template defined in qTensors_include.f90)
**Arguments**
Qt : TYPE(qtensor), inout
qTensor which should be checked for its capacity.
nn : INTEGER, in
Number of new elements to be stored in the qTensor.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine extend_qtensor(Qt, nn, errst)
type(qtensor), intent(inout) :: Qt
integer, intent(in) :: nn
integer, intent(out), optional :: errst
!if(present(errst)) errst = 0
if(Qt%nb + nn .ge. Qt%capacity) then
call Increase_Capacity_qtensor(Qt, Qt%nb + nn)
end if
end subroutine extend_qtensor
"""
return
[docs]def extend_qtensorc():
"""
fortran-subroutine - October 2016 (dj)
Extend space for n new elements. If the required space is less than
capacity, nothing happens. Otherwise, increase the capacity.
details (template defined in qTensors_include.f90)
**Arguments**
Qt : TYPE(qtensorc), inout
qTensor which should be checked for its capacity.
nn : INTEGER, in
Number of new elements to be stored in the qTensor.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine extend_qtensorc(Qt, nn, errst)
type(qtensorc), intent(inout) :: Qt
integer, intent(in) :: nn
integer, intent(out), optional :: errst
!if(present(errst)) errst = 0
if(Qt%nb + nn .ge. Qt%capacity) then
call Increase_Capacity_qtensorc(Qt, Qt%nb + nn)
end if
end subroutine extend_qtensorc
"""
return
[docs]def fuse_all_qtensor():
"""
fortran-subroutine - October 2017 (dj)
Fuse equally sized subsets of links containing in total all links in
the tensor.
**Arguments**
Qt : TYPE(qtensor), inout
Fuse links in this tensor.
idx : INTEGER(\*, \*), in
Each column is merged together. ii-th column is ii-th new index.
method : CHARACTER, in
'U' : update nqs flag (do on last fuse)
'N' : leave nqs flag as is
'A' : just add quantum numbers (not reversible, nqs left unchanged)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine fuse_all_qtensor(Qt, idx, method, errst)
type(qtensor), intent(inout) :: Qt
integer, dimension(:, :), intent(in) :: idx
character, intent(in) :: method
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! for indexing while looping
integer :: i1, i2, k1, k2
! temporary copy of quantum numbers
integer, dimension(:), allocatable :: qq
! number of all quantum numbers (incoming tensor)
integer :: snqs
! permutation to simplify things
integer, dimension(:), allocatable :: perm
!if(present(errst)) errst = 0
! Quick return for empty tensor
if(Qt%nb == 0) return
snqs = sum(Qt%nqs)
allocate(qq(snqs * rank(Qt)))
! Permute into nice order
allocate(perm(rank(Qt)))
perm = reshape(idx, [rank(Qt)])
call transposed(Qt, perm, doperm=.true., errst=errst)
!if(prop_error('fuse_all_qtensor : transpose failed.', &
! 'qTensors_include.f90:2894', errst=errst)) return
do ii = 1, Qt%nb
! idx is just a dummy not referenced. method, too.
call fuse(Qt%Data(ii)%Tens, idx, method, ordered=.true., errst=errst)
!if(prop_error('fuse_qtensor : fuse failed.', &
! 'qTensors_include.f90:2900', errst=errst)) return
qq = Qt%Data(ii)%qq
i2 = 0
do jj = 1, size(idx, 2)
! Collect abelian quantum numbers
do kk = 1, size(idx, 1)
! Indices of target array
i1 = i2 + 1
i2 = i2 + Qt%nqs(1)
! Determine index of link for source
k1 = (jj - 1) * size(idx, 1) + kk
! Indices of source array
k1 = (k1 - 1) * snqs + 1
k2 = k1 - 1 + Qt%nqs(1)
! Copy quantum numbers
Qt%Data(ii)%qq(i1:i2) = qq(k1:k2)
end do
! Collect discrete quantum numbers
do kk = 1, size(idx, 1)
! Indices of target array
i1 = i2 + 1
i2 = i2 + Qt%nqs(2)
! Determine index of link for source
k1 = (jj - 1) * size(idx, 1) + kk
! Indices of source array
k1 = (k1 - 1) * snqs + Qt%nqs(1) + 1
k2 = k1 - 1 + Qt%nqs(2)
! Copy quantum numbers
Qt%Data(ii)%qq(i1:i2) = qq(k1:k2)
end do
end do
end do
! Increase quantum in nqs
Qt%nqs = size(idx, 1) * Qt%nqs
deallocate(qq, perm)
end subroutine fuse_all_qtensor
"""
return
[docs]def fuse_all_qtensorc():
"""
fortran-subroutine - October 2017 (dj)
Fuse equally sized subsets of links containing in total all links in
the tensor.
**Arguments**
Qt : TYPE(qtensorc), inout
Fuse links in this tensor.
idx : INTEGER(\*, \*), in
Each column is merged together. ii-th column is ii-th new index.
method : CHARACTER, in
'U' : update nqs flag (do on last fuse)
'N' : leave nqs flag as is
'A' : just add quantum numbers (not reversible, nqs left unchanged)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine fuse_all_qtensorc(Qt, idx, method, errst)
type(qtensorc), intent(inout) :: Qt
integer, dimension(:, :), intent(in) :: idx
character, intent(in) :: method
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! for indexing while looping
integer :: i1, i2, k1, k2
! temporary copy of quantum numbers
integer, dimension(:), allocatable :: qq
! number of all quantum numbers (incoming tensor)
integer :: snqs
! permutation to simplify things
integer, dimension(:), allocatable :: perm
!if(present(errst)) errst = 0
! Quick return for empty tensor
if(Qt%nb == 0) return
snqs = sum(Qt%nqs)
allocate(qq(snqs * rank(Qt)))
! Permute into nice order
allocate(perm(rank(Qt)))
perm = reshape(idx, [rank(Qt)])
call transposed(Qt, perm, doperm=.true., errst=errst)
!if(prop_error('fuse_all_qtensorc : transpose failed.', &
! 'qTensors_include.f90:2894', errst=errst)) return
do ii = 1, Qt%nb
! idx is just a dummy not referenced. method, too.
call fuse(Qt%Data(ii)%Tens, idx, method, ordered=.true., errst=errst)
!if(prop_error('fuse_qtensorc : fuse failed.', &
! 'qTensors_include.f90:2900', errst=errst)) return
qq = Qt%Data(ii)%qq
i2 = 0
do jj = 1, size(idx, 2)
! Collect abelian quantum numbers
do kk = 1, size(idx, 1)
! Indices of target array
i1 = i2 + 1
i2 = i2 + Qt%nqs(1)
! Determine index of link for source
k1 = (jj - 1) * size(idx, 1) + kk
! Indices of source array
k1 = (k1 - 1) * snqs + 1
k2 = k1 - 1 + Qt%nqs(1)
! Copy quantum numbers
Qt%Data(ii)%qq(i1:i2) = qq(k1:k2)
end do
! Collect discrete quantum numbers
do kk = 1, size(idx, 1)
! Indices of target array
i1 = i2 + 1
i2 = i2 + Qt%nqs(2)
! Determine index of link for source
k1 = (jj - 1) * size(idx, 1) + kk
! Indices of source array
k1 = (k1 - 1) * snqs + Qt%nqs(1) + 1
k2 = k1 - 1 + Qt%nqs(2)
! Copy quantum numbers
Qt%Data(ii)%qq(i1:i2) = qq(k1:k2)
end do
end do
end do
! Increase quantum in nqs
Qt%nqs = size(idx, 1) * Qt%nqs
deallocate(qq, perm)
end subroutine fuse_all_qtensorc
"""
return
[docs]def gaxpy_qtensor_real_qtensor():
"""
fortran-subroutine - ?? (mlw)
Y = Y + a * X for REAL_OR_COMPLEX a
details (template defined in qTensors_include.f90)
**Arguments**
Yy : TYPE(qtensor), inout
On entry, qtensor. On exit, other qtensor times scalar
added to this qtensor. (No duplicates allowed for hashing
quantum numbers.)
sc : REAL_OR_COMPLEX, in
Scalar multiplied with X.
Xx : TYPE(TENSOR_TYPE), inout
qtensor added to tensor Y. Is scaled with constant `sc`.
(No duplicates allowed for hashing quantum numbers.)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine gaxpy_qtensor_real_qtensor(Yy, sc, Xx, errst)
type(qtensor), intent(inout) :: Yy
real(KIND=rKind), intent(in) :: sc
type(qtensor), intent(in) :: Xx
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping / indexing
integer :: ii, i1, i2
!
integer :: ni
! contraction of those legs (all legs)
integer, dimension(:), allocatable :: idxab
! adding indices
integer, dimension(:, :), allocatable :: cidx
integer, dimension(:), allocatable :: indout, degout
! keeping track of unadded tensors in Xx (new indices)
logical, dimension(:), allocatable :: nidx
!if(present(errst)) errst = 0
! Fast return
if(Yy%nb == 0) then
call destroy(Yy)
call copy(Yy, Xx)
call scale(sc, Yy)
return
end if
if(Xx%nb == 0) then
return
end if
!if(size(Yy%Data(1)%qq, 1) /= size(Xx%Data(1)%qq, 1)) then
! errst = raise_error(&
! 'gaxpy_qtensor_real_qtensor'&
! //': mismatch.', 2, errst=errst)
! return
!end if
allocate(idxab(size(Yy%Data(1)%qq, 1) / sum(Yy%nqs)), &
cidx(2, min(Yy%nb, Xx%nb)), &
nidx(Xx%nb))
idxab = [(ii, ii = 1, size(Yy%Data(1)%qq, 1) / sum(Yy%nqs))]
nidx = .true.
! Unique indices since all quantum numbers are hashed
call get_contr_idx(Yy, idxab, Xx, idxab, [.false., .false.], cidx, &
ni, indout, degout, errst=errst)
!if(prop_error('gaxpy_qtensor: contr idx failed.', &
! 'qTensors_include.f90:3050', errst=errst)) return
! Add tensors with equal hashes
! .............................
if(ni > 0) then
do ii = 1, ni
do i2 = degout(ii) + 1, degout(ii + 1)
i1 = indout(i2)
nidx(cidx(2, i1)) = .false.
call gaxpy(Yy%Data(cidx(1, i1))%Tens, sc, &
Xx%Data(cidx(2, i1))%Tens, errst=errst)
!if(prop_error('gaxpy_qtensor: gaxpy failed.', &
! 'qTensors_include.f90:3064', errst=errst)) return
end do
end do
end if
! Extend Yy with tensor of new hashes
! ...................................
if(count(nidx) > 0) then
call extend(Yy, count(nidx))
do ii = 1, Xx%nb
if(nidx(ii)) then
! Not in Y, add to it. Note that only ONE such realization
! of q can occur in X, so we don't need to add the q/hash
! to the vector ind and re-sort.
if(norm(Xx%Data(ii)%Tens) < 1e-14) cycle
Yy%nb = Yy%nb + 1
call create(Yy%Data(Yy%nb)%Tens, Xx%Data(ii)%Tens%dl, &
init='N')
Yy%Data(Yy%nb)%Tens%elem = sc * Xx%Data(ii)%Tens%elem
allocate(Yy%Data(Yy%nb)%qq(size(Xx%Data(ii)%qq)))
Yy%Data(Yy%nb)%qq = Xx%Data(ii)%qq
Yy%hash(Yy%nb) = Xx%hash(ii)
end if
end do
end if
deallocate(idxab, cidx, nidx)
if(ni > 0) deallocate(indout, degout)
end subroutine gaxpy_qtensor_real_qtensor
"""
return
[docs]def gaxpy_qtensorc_complex_qtensorc():
"""
fortran-subroutine - ?? (mlw)
Y = Y + a * X for REAL_OR_COMPLEX a
details (template defined in qTensors_include.f90)
**Arguments**
Yy : TYPE(qtensorc), inout
On entry, qtensorc. On exit, other qtensorc times scalar
added to this qtensorc. (No duplicates allowed for hashing
quantum numbers.)
sc : REAL_OR_COMPLEX, in
Scalar multiplied with X.
Xx : TYPE(TENSOR_TYPE), inout
qtensorc added to tensor Y. Is scaled with constant `sc`.
(No duplicates allowed for hashing quantum numbers.)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine gaxpy_qtensorc_complex_qtensorc(Yy, sc, Xx, errst)
type(qtensorc), intent(inout) :: Yy
complex(KIND=rKind), intent(in) :: sc
type(qtensorc), intent(in) :: Xx
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping / indexing
integer :: ii, i1, i2
!
integer :: ni
! contraction of those legs (all legs)
integer, dimension(:), allocatable :: idxab
! adding indices
integer, dimension(:, :), allocatable :: cidx
integer, dimension(:), allocatable :: indout, degout
! keeping track of unadded tensors in Xx (new indices)
logical, dimension(:), allocatable :: nidx
!if(present(errst)) errst = 0
! Fast return
if(Yy%nb == 0) then
call destroy(Yy)
call copy(Yy, Xx)
call scale(sc, Yy)
return
end if
if(Xx%nb == 0) then
return
end if
!if(size(Yy%Data(1)%qq, 1) /= size(Xx%Data(1)%qq, 1)) then
! errst = raise_error(&
! 'gaxpy_qtensorc_complex_qtensorc'&
! //': mismatch.', 2, errst=errst)
! return
!end if
allocate(idxab(size(Yy%Data(1)%qq, 1) / sum(Yy%nqs)), &
cidx(2, min(Yy%nb, Xx%nb)), &
nidx(Xx%nb))
idxab = [(ii, ii = 1, size(Yy%Data(1)%qq, 1) / sum(Yy%nqs))]
nidx = .true.
! Unique indices since all quantum numbers are hashed
call get_contr_idx(Yy, idxab, Xx, idxab, [.false., .false.], cidx, &
ni, indout, degout, errst=errst)
!if(prop_error('gaxpy_qtensorc: contr idx failed.', &
! 'qTensors_include.f90:3050', errst=errst)) return
! Add tensors with equal hashes
! .............................
if(ni > 0) then
do ii = 1, ni
do i2 = degout(ii) + 1, degout(ii + 1)
i1 = indout(i2)
nidx(cidx(2, i1)) = .false.
call gaxpy(Yy%Data(cidx(1, i1))%Tens, sc, &
Xx%Data(cidx(2, i1))%Tens, errst=errst)
!if(prop_error('gaxpy_qtensorc: gaxpy failed.', &
! 'qTensors_include.f90:3064', errst=errst)) return
end do
end do
end if
! Extend Yy with tensor of new hashes
! ...................................
if(count(nidx) > 0) then
call extend(Yy, count(nidx))
do ii = 1, Xx%nb
if(nidx(ii)) then
! Not in Y, add to it. Note that only ONE such realization
! of q can occur in X, so we don't need to add the q/hash
! to the vector ind and re-sort.
if(norm(Xx%Data(ii)%Tens) < 1e-14) cycle
Yy%nb = Yy%nb + 1
call create(Yy%Data(Yy%nb)%Tens, Xx%Data(ii)%Tens%dl, &
init='N')
Yy%Data(Yy%nb)%Tens%elem = sc * Xx%Data(ii)%Tens%elem
allocate(Yy%Data(Yy%nb)%qq(size(Xx%Data(ii)%qq)))
Yy%Data(Yy%nb)%qq = Xx%Data(ii)%qq
Yy%hash(Yy%nb) = Xx%hash(ii)
end if
end do
end if
deallocate(idxab, cidx, nidx)
if(ni > 0) deallocate(indout, degout)
end subroutine gaxpy_qtensorc_complex_qtensorc
"""
return
[docs]def gaxpy_qtensorc_real_qtensor():
"""
fortran-subroutine - ?? (mlw)
Y = Y + a * X for REAL_OR_COMPLEX a
details (template defined in qTensors_include.f90)
**Arguments**
Yy : TYPE(qtensor), inout
On entry, qtensor. On exit, other qtensor times scalar
added to this qtensor. (No duplicates allowed for hashing
quantum numbers.)
sc : REAL_OR_COMPLEX, in
Scalar multiplied with X.
Xx : TYPE(TENSOR_TYPE), inout
qtensor added to tensor Y. Is scaled with constant `sc`.
(No duplicates allowed for hashing quantum numbers.)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine gaxpy_qtensorc_real_qtensor(Yy, sc, Xx, errst)
type(qtensorc), intent(inout) :: Yy
real(KIND=rKind), intent(in) :: sc
type(qtensor), intent(in) :: Xx
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping / indexing
integer :: ii, i1, i2
!
integer :: ni
! contraction of those legs (all legs)
integer, dimension(:), allocatable :: idxab
! adding indices
integer, dimension(:, :), allocatable :: cidx
integer, dimension(:), allocatable :: indout, degout
! keeping track of unadded tensors in Xx (new indices)
logical, dimension(:), allocatable :: nidx
!if(present(errst)) errst = 0
! Fast return
if(Yy%nb == 0) then
call destroy(Yy)
call copy(Yy, Xx)
call scale(sc, Yy)
return
end if
if(Xx%nb == 0) then
return
end if
!if(size(Yy%Data(1)%qq, 1) /= size(Xx%Data(1)%qq, 1)) then
! errst = raise_error(&
! 'gaxpy_qtensorc_real_qtensor'&
! //': mismatch.', 2, errst=errst)
! return
!end if
allocate(idxab(size(Yy%Data(1)%qq, 1) / sum(Yy%nqs)), &
cidx(2, min(Yy%nb, Xx%nb)), &
nidx(Xx%nb))
idxab = [(ii, ii = 1, size(Yy%Data(1)%qq, 1) / sum(Yy%nqs))]
nidx = .true.
! Unique indices since all quantum numbers are hashed
call get_contr_idx(Yy, idxab, Xx, idxab, [.false., .false.], cidx, &
ni, indout, degout, errst=errst)
!if(prop_error('gaxpy_qtensor: contr idx failed.', &
! 'qTensors_include.f90:3050', errst=errst)) return
! Add tensors with equal hashes
! .............................
if(ni > 0) then
do ii = 1, ni
do i2 = degout(ii) + 1, degout(ii + 1)
i1 = indout(i2)
nidx(cidx(2, i1)) = .false.
call gaxpy(Yy%Data(cidx(1, i1))%Tens, sc, &
Xx%Data(cidx(2, i1))%Tens, errst=errst)
!if(prop_error('gaxpy_qtensor: gaxpy failed.', &
! 'qTensors_include.f90:3064', errst=errst)) return
end do
end do
end if
! Extend Yy with tensor of new hashes
! ...................................
if(count(nidx) > 0) then
call extend(Yy, count(nidx))
do ii = 1, Xx%nb
if(nidx(ii)) then
! Not in Y, add to it. Note that only ONE such realization
! of q can occur in X, so we don't need to add the q/hash
! to the vector ind and re-sort.
if(norm(Xx%Data(ii)%Tens) < 1e-14) cycle
Yy%nb = Yy%nb + 1
call create(Yy%Data(Yy%nb)%Tens, Xx%Data(ii)%Tens%dl, &
init='N')
Yy%Data(Yy%nb)%Tens%elem = sc * Xx%Data(ii)%Tens%elem
allocate(Yy%Data(Yy%nb)%qq(size(Xx%Data(ii)%qq)))
Yy%Data(Yy%nb)%qq = Xx%Data(ii)%qq
Yy%hash(Yy%nb) = Xx%hash(ii)
end if
end do
end if
deallocate(idxab, cidx, nidx)
if(ni > 0) deallocate(indout, degout)
end subroutine gaxpy_qtensorc_real_qtensor
"""
return
[docs]def gaxpy_qtensorc_complex_qtensor():
"""
fortran-subroutine - ?? (mlw)
Y = Y + a * X for REAL_OR_COMPLEX a
details (template defined in qTensors_include.f90)
**Arguments**
Yy : TYPE(qtensor), inout
On entry, qtensor. On exit, other qtensor times scalar
added to this qtensor. (No duplicates allowed for hashing
quantum numbers.)
sc : REAL_OR_COMPLEX, in
Scalar multiplied with X.
Xx : TYPE(TENSOR_TYPE), inout
qtensor added to tensor Y. Is scaled with constant `sc`.
(No duplicates allowed for hashing quantum numbers.)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine gaxpy_qtensorc_complex_qtensor(Yy, sc, Xx, errst)
type(qtensorc), intent(inout) :: Yy
complex(KIND=rKind), intent(in) :: sc
type(qtensor), intent(in) :: Xx
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping / indexing
integer :: ii, i1, i2
!
integer :: ni
! contraction of those legs (all legs)
integer, dimension(:), allocatable :: idxab
! adding indices
integer, dimension(:, :), allocatable :: cidx
integer, dimension(:), allocatable :: indout, degout
! keeping track of unadded tensors in Xx (new indices)
logical, dimension(:), allocatable :: nidx
!if(present(errst)) errst = 0
! Fast return
if(Yy%nb == 0) then
call destroy(Yy)
call copy(Yy, Xx)
call scale(sc, Yy)
return
end if
if(Xx%nb == 0) then
return
end if
!if(size(Yy%Data(1)%qq, 1) /= size(Xx%Data(1)%qq, 1)) then
! errst = raise_error(&
! 'gaxpy_qtensorc_complex_qtensor'&
! //': mismatch.', 2, errst=errst)
! return
!end if
allocate(idxab(size(Yy%Data(1)%qq, 1) / sum(Yy%nqs)), &
cidx(2, min(Yy%nb, Xx%nb)), &
nidx(Xx%nb))
idxab = [(ii, ii = 1, size(Yy%Data(1)%qq, 1) / sum(Yy%nqs))]
nidx = .true.
! Unique indices since all quantum numbers are hashed
call get_contr_idx(Yy, idxab, Xx, idxab, [.false., .false.], cidx, &
ni, indout, degout, errst=errst)
!if(prop_error('gaxpy_qtensor: contr idx failed.', &
! 'qTensors_include.f90:3050', errst=errst)) return
! Add tensors with equal hashes
! .............................
if(ni > 0) then
do ii = 1, ni
do i2 = degout(ii) + 1, degout(ii + 1)
i1 = indout(i2)
nidx(cidx(2, i1)) = .false.
call gaxpy(Yy%Data(cidx(1, i1))%Tens, sc, &
Xx%Data(cidx(2, i1))%Tens, errst=errst)
!if(prop_error('gaxpy_qtensor: gaxpy failed.', &
! 'qTensors_include.f90:3064', errst=errst)) return
end do
end do
end if
! Extend Yy with tensor of new hashes
! ...................................
if(count(nidx) > 0) then
call extend(Yy, count(nidx))
do ii = 1, Xx%nb
if(nidx(ii)) then
! Not in Y, add to it. Note that only ONE such realization
! of q can occur in X, so we don't need to add the q/hash
! to the vector ind and re-sort.
if(norm(Xx%Data(ii)%Tens) < 1e-14) cycle
Yy%nb = Yy%nb + 1
call create(Yy%Data(Yy%nb)%Tens, Xx%Data(ii)%Tens%dl, &
init='N')
Yy%Data(Yy%nb)%Tens%elem = sc * Xx%Data(ii)%Tens%elem
allocate(Yy%Data(Yy%nb)%qq(size(Xx%Data(ii)%qq)))
Yy%Data(Yy%nb)%qq = Xx%Data(ii)%qq
Yy%hash(Yy%nb) = Xx%hash(ii)
end if
end do
end if
deallocate(idxab, cidx, nidx)
if(ni > 0) deallocate(indout, degout)
end subroutine gaxpy_qtensorc_complex_qtensor
"""
return
[docs]def gaxpy_qtensorc_real_qtensorc():
"""
fortran-subroutine - ?? (mlw)
Y = Y + a * X for REAL_OR_COMPLEX a
details (template defined in qTensors_include.f90)
**Arguments**
Yy : TYPE(qtensorc), inout
On entry, qtensorc. On exit, other qtensorc times scalar
added to this qtensorc. (No duplicates allowed for hashing
quantum numbers.)
sc : REAL_OR_COMPLEX, in
Scalar multiplied with X.
Xx : TYPE(TENSOR_TYPE), inout
qtensorc added to tensor Y. Is scaled with constant `sc`.
(No duplicates allowed for hashing quantum numbers.)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine gaxpy_qtensorc_real_qtensorc(Yy, sc, Xx, errst)
type(qtensorc), intent(inout) :: Yy
real(KIND=rKind), intent(in) :: sc
type(qtensorc), intent(in) :: Xx
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping / indexing
integer :: ii, i1, i2
!
integer :: ni
! contraction of those legs (all legs)
integer, dimension(:), allocatable :: idxab
! adding indices
integer, dimension(:, :), allocatable :: cidx
integer, dimension(:), allocatable :: indout, degout
! keeping track of unadded tensors in Xx (new indices)
logical, dimension(:), allocatable :: nidx
!if(present(errst)) errst = 0
! Fast return
if(Yy%nb == 0) then
call destroy(Yy)
call copy(Yy, Xx)
call scale(sc, Yy)
return
end if
if(Xx%nb == 0) then
return
end if
!if(size(Yy%Data(1)%qq, 1) /= size(Xx%Data(1)%qq, 1)) then
! errst = raise_error(&
! 'gaxpy_qtensorc_real_qtensorc'&
! //': mismatch.', 2, errst=errst)
! return
!end if
allocate(idxab(size(Yy%Data(1)%qq, 1) / sum(Yy%nqs)), &
cidx(2, min(Yy%nb, Xx%nb)), &
nidx(Xx%nb))
idxab = [(ii, ii = 1, size(Yy%Data(1)%qq, 1) / sum(Yy%nqs))]
nidx = .true.
! Unique indices since all quantum numbers are hashed
call get_contr_idx(Yy, idxab, Xx, idxab, [.false., .false.], cidx, &
ni, indout, degout, errst=errst)
!if(prop_error('gaxpy_qtensorc: contr idx failed.', &
! 'qTensors_include.f90:3050', errst=errst)) return
! Add tensors with equal hashes
! .............................
if(ni > 0) then
do ii = 1, ni
do i2 = degout(ii) + 1, degout(ii + 1)
i1 = indout(i2)
nidx(cidx(2, i1)) = .false.
call gaxpy(Yy%Data(cidx(1, i1))%Tens, sc, &
Xx%Data(cidx(2, i1))%Tens, errst=errst)
!if(prop_error('gaxpy_qtensorc: gaxpy failed.', &
! 'qTensors_include.f90:3064', errst=errst)) return
end do
end do
end if
! Extend Yy with tensor of new hashes
! ...................................
if(count(nidx) > 0) then
call extend(Yy, count(nidx))
do ii = 1, Xx%nb
if(nidx(ii)) then
! Not in Y, add to it. Note that only ONE such realization
! of q can occur in X, so we don't need to add the q/hash
! to the vector ind and re-sort.
if(norm(Xx%Data(ii)%Tens) < 1e-14) cycle
Yy%nb = Yy%nb + 1
call create(Yy%Data(Yy%nb)%Tens, Xx%Data(ii)%Tens%dl, &
init='N')
Yy%Data(Yy%nb)%Tens%elem = sc * Xx%Data(ii)%Tens%elem
allocate(Yy%Data(Yy%nb)%qq(size(Xx%Data(ii)%qq)))
Yy%Data(Yy%nb)%qq = Xx%Data(ii)%qq
Yy%hash(Yy%nb) = Xx%hash(ii)
end if
end do
end if
deallocate(idxab, cidx, nidx)
if(ni > 0) deallocate(indout, degout)
end subroutine gaxpy_qtensorc_real_qtensorc
"""
return
[docs]def get_3rddim_qtensor():
"""
fortran-function - September 2014 (dj)
Get the maximal bond dimension (integer) of a q-tensor.
details (template defined in qTensors_include.f90)
**Arguments**
Qtens : TYPE(qtensor), in
Get the maximal dimension of the 3rd leg. Explanation how to do
this with q-tensor should go here ....
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function get_3rddim_qtensor(Qtens, errst) result(dim3)
type(qtensor), intent(in) :: Qtens
integer, intent(out), optional :: errst
integer :: dim3
!if(present(errst)) errst = 0
! To-do:
! Initialize maximum with zero
dim3 = 0
! Fast return if no block tensors
if(Qtens%nb == 0) return
! Cannot figure out how this works at the moment
! Check that disabled for matrices when implementing
stop 'get_3rdDim_qtensor: not implemented.'
end function get_3rddim_qtensor
"""
return
[docs]def get_3rddim_qtensorc():
"""
fortran-function - September 2014 (dj)
Get the maximal bond dimension (integer) of a q-tensor.
details (template defined in qTensors_include.f90)
**Arguments**
Qtens : TYPE(qtensorc), in
Get the maximal dimension of the 3rd leg. Explanation how to do
this with q-tensor should go here ....
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function get_3rddim_qtensorc(Qtens, errst) result(dim3)
type(qtensorc), intent(in) :: Qtens
integer, intent(out), optional :: errst
integer :: dim3
!if(present(errst)) errst = 0
! To-do:
! Initialize maximum with zero
dim3 = 0
! Fast return if no block tensors
if(Qtens%nb == 0) return
! Cannot figure out how this works at the moment
! Check that disabled for matrices when implementing
stop 'get_3rdDim_qtensorc: not implemented.'
end function get_3rddim_qtensorc
"""
return
[docs]def get_contr_idx_qtensor_qtensor():
"""
fortran-subroutine - October 2016 (dj)
Find the indices of the tensors in the array to be contracted with
each other.
**Arguments**
Qta : TYPE(qtensor), in
First tensor for contraction.
idxa : INTEGER(\*), in
The following legs in Qta should be contracted over.
Qtb : TYPE(qtensor), in
Second tensor for contraction.
idxb : INTEGER(\*), in
The following legs in Qtb should be contracted over.
deg : LOGICAL(2), in
If deg(1) = .true., hashes in Qta may be degenerate and a
degenerate sorting is applied. If deg(1) .false., hashes in
Qta must be unique in regard to the contraction inidces
idxa. Analog definition for deg(2) and Qtb.
cidx : INTEGER(2, \*), out
Storing the index of the tensors in the array of tensors to be
contracted together. Second dimension should be at least
the minumum of Qta%nb and Qtb%nb.
niunique : INTEGER, out
Number of unique matches found. To execute contraction, loop to
cidx(:, degout(niunique + 1)).
degout : INTEGER(\*), out
Allocated on exit and filled with the degenerate subsets
for the contractions. degout(ii) + 1 : degout(ii + 1) have
the same final quantum number.
qqq : INTEGER(\*, \*), OPTIONAL, inout
If present, it is allocated on exit and filled with the
quantum numbers remaining after the contraction. do_degout
must be true if qqq are calculated.
By default, the quantum numbers are not stored.
do_degout : LOGICAL, in
If .true., the hashes of the new tensor are sorted. If false,
the quantum numbers and hashes are not calculated for the output
tensor.
Default to .true.
**Details**
Disregarding the degeneracies, it is the best approach to
sort the smaller array and then look for corresponding hashes of
the bigger array in the smaller array. With :math:`n_1` the size
of the smaller array and :math:`n_2` the size of the bigger array,
it scales as :math:`n_1 log(n_1) + n_2 log(n_1)`. Sorting both
arrays and then looking for matches scales approximately with
:math:`n_1 log(n_1) + n_2 log(n_2) + min(n_1, n_2)`. For degeneracies,
it might depend on the number of unique hashes, which is not
predictable beforehand.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine get_contr_idx_qtensor_qtensor(Qta, idxa, Qtb, idxb, &
deg, cidx, niunique, indout, degout, qqq, do_degout, errst)
type(qtensor), intent(in) :: Qta
type(qtensor), intent(in) :: Qtb
integer, intent(in) :: idxa(:), idxb(:)
logical, dimension(2), intent(in) :: deg
integer, intent(out) :: cidx(:, :)
integer, intent(out) :: niunique
integer, dimension(:), allocatable, intent(out) :: indout, degout
integer, dimension(:, :), allocatable, intent(inout), optional :: qqq
logical, intent(in), optional :: do_degout
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for indexing
integer :: ii, jj, kk, i1, j1, pp, p1, p2, p3, p4
! control while do
logical :: loop
! duplicate for optional variable
logical :: dodegout
! Hashes for the two qtensors
real(KIND=rKind), dimension(Qta%nb) :: hasha
real(KIND=rKind), dimension(Qtb%nb) :: hashb
! For sorting
integer, dimension(Qta%nb) :: inda
integer, dimension(Qtb%nb) :: indb
! For degenerate sorting
integer :: na, nb
integer, dimension(:), allocatable :: dega, degb
real(KIND=rKind), dimension(:), allocatable :: littlea, littleb
! uncontracted indices
logical, dimension(:), allocatable :: uncontr
integer, dimension(:), allocatable :: unca, uncb, idxall
! total number of matches
integer :: ni
! for final quantum numbers and their sorting
integer :: snqs
integer, dimension(:), allocatable :: qq
real(KIND=rKind), dimension(:), allocatable :: hashout, littleout
!if(present(errst)) errst = 0
!if(size(idxa) /= size(idxb)) then
! errst = raise_error('get_contr_idx_qtensor:'//&
! ' size(idxa) /= size(idxb)', 2, errst=errst)
! return
!end if
! Fast return
if((Qta%nb == 0) .or. (Qtb%nb == 0)) then
niunique = 0
return
end if
dodegout = .true.
if(present(do_degout)) dodegout = do_degout
!if((.not. dodegout) .and. present(qqq)) then
! errst = raise_error('get_contr_idx_qtensor_'//&
! 'qtensor: qqq and no do_degout.', &
! 99, 'qTensors_include.f90:3318', errst=errst)
! return
!end if
! Generate hashes
hasha = get_hash(Qta, idxa)
hashb = get_hash(Qtb, idxb)
! Array for hashes of output
if(dodegout) then
! Find uncontracted indices
allocate(uncontr(rank(Qta)), unca(rank(Qta) - size(idxa)))
uncontr = .true.
uncontr(idxa) = .false.
jj = 1
do ii = 1, rank(Qta)
if(uncontr(ii)) then
unca(jj) = ii
jj = jj + 1
end if
end do
deallocate(uncontr)
allocate(uncontr(rank(Qtb)), uncb(rank(Qtb) - size(idxb)))
uncontr = .true.
uncontr(idxb) = .false.
jj = 1
do ii = 1, rank(Qtb)
if(uncontr(ii)) then
uncb(jj) = ii
jj = jj + 1
end if
end do
deallocate(uncontr)
allocate(idxall(size(unca) + size(uncb)))
idxall = [(ii, ii = 1, size(idxall))]
! Store number of quantum numbers
snqs = sum(Qta%nqs)
allocate(qq(snqs * (size(unca) + size(uncb))))
allocate(hashout(Qta%nb * Qtb%nb), littleout(Qta%nb * Qtb%nb), &
indout(Qta%nb * Qtb%nb), degout(Qta%nb * Qtb%nb + 1))
end if
if(present(qqq)) then
allocate(qqq(size(qq, 1), Qta%nb * Qtb%nb))
end if
if(deg(1) .and. deg(2)) then
! Case with degeneracies
! ----------------------
if(Qta%nb < Qtb%nb) then
! Sort hashes in a
allocate(littlea(Qta%nb), dega(Qta%nb + 1))
call ascending_hsort(hasha, littlea, inda, na, dega)
ni = 0
do jj = 1, Qtb%nb
ii = Findtagindex(hashb(jj), littlea(:na))
if(ii > 0) then
do i1 = dega(ii) + 1, dega(ii + 1)
ni = ni + 1
cidx(1, ni) = inda(i1)
cidx(2, ni) = jj
if(.not. dodegout) cycle
! Construct quantum number for final hash
p1 = 1
p2 = snqs
do pp = 1, size(unca)
p3 = (unca(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qta%Data(inda(i1))%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
do pp = 1, size(uncb)
p3 = (uncb(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qtb%Data(jj)%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
hashout(ni) = prime_hash(qq, idxall, Qta%nqs)
if(present(qqq)) then
qqq(:, ni) = qq
end if
end do
end if
end do
deallocate(littlea, dega)
else
! Sort hashes in b
allocate(littleb(Qtb%nb), degb(Qtb%nb + 1))
call ascending_hsort(hashb, littleb, indb, nb, degb)
ni = 0
do ii = 1, Qta%nb
jj = Findtagindex(hasha(ii), littleb(:nb))
if(jj < 1) cycle
do j1 = degb(jj) + 1, degb(jj + 1)
ni = ni + 1
cidx(1, ni) = ii
cidx(2, ni) = indb(j1)
if(.not. dodegout) cycle
! Construct quantum number for final hash
p1 = 1
p2 = snqs
do pp = 1, size(unca)
p3 = (unca(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qta%Data(ii)%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
do pp = 1, size(uncb)
p3 = (uncb(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qtb%Data(indb(j1))%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
hashout(ni) = prime_hash(qq, idxall, Qta%nqs)
if(present(qqq)) then
qqq(:, ni) = qq
end if
end do
end do
deallocate(littleb, degb)
end if
elseif(deg(1)) then
! Sorting Qta with degeneracies, Qtb without
! ------------------------------------------
if(Qta%nb <= Qtb%nb) then
! Allocate and sort Qta
allocate(littlea(Qta%nb), dega(Qta%nb + 1))
call ascending_hsort(hasha, littlea, inda, na, dega)
ni = 0
do jj = 1, Qtb%nb
ii = Findtagindex(hashb(jj), littlea(:na))
if(ii < 1) cycle
do i1 = dega(ii) + 1, dega(ii + 1)
ni = ni + 1
cidx(1, ni) = inda(i1)
cidx(2, ni) = jj
if(.not. dodegout) cycle
! Construct quantum number for final hash
p1 = 1
p2 = snqs
do pp = 1, size(unca)
p3 = (unca(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qta%Data(inda(i1))%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
do pp = 1, size(uncb)
p3 = (uncb(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qtb%Data(jj)%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
hashout(ni) = prime_hash(qq, idxall, Qta%nqs)
if(present(qqq)) then
qqq(:, ni) = qq
end if
end do
end do
deallocate(littlea, dega)
else
call ascending_hsort(hashb, indb)
ni = 0
do ii = 1, Qta%nb
jj = Findtagindex(hasha(ii), hashb(indb))
if(jj < 1) cycle
ni = ni + 1
cidx(1, ni) = ii
cidx(2, ni) = indb(jj)
if(.not. dodegout) cycle
! Construct quantum numbers for final hash
p1 = 1
p2 = snqs
do pp = 1, size(unca)
p3 = (unca(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qta%Data(ii)%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
do pp = 1, size(uncb)
p3 = (uncb(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qtb%Data(indb(jj))%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
hashout(ni) = prime_hash(qq, idxall, Qta%nqs)
if(present(qqq)) then
qqq(:, ni) = qq
end if
end do
end if
elseif(deg(2)) then
! Sorthing Qtb with degeneracies, Qta without
! -------------------------------------------
if(Qtb%nb <= Qta%nb) then
! Allocate and sort Qtb
allocate(littleb(Qtb%nb), degb(Qtb%nb + 1))
call ascending_hsort(hashb, littleb, indb, nb, degb)
ni = 0
do ii = 1, Qta%nb
jj = Findtagindex(hasha(ii), littleb(:nb))
if(jj < 1) cycle
do j1 = degb(jj) + 1, degb(jj + 1)
ni = ni + 1
cidx(1, ni) = ii
cidx(2, ni) = indb(j1)
if(.not. dodegout) cycle
! Construct quantum number for final hash
p1 = 1
p2 = snqs
do pp = 1, size(unca)
p3 = (unca(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qta%Data(ii)%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
do pp = 1, size(uncb)
p3 = (uncb(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qtb%Data(indb(j1))%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
hashout(ni) = prime_hash(qq, idxall, Qta%nqs)
if(present(qqq)) then
qqq(:, ni) = qq
end if
end do
end do
deallocate(littleb, degb)
else
! Sort Qta
call ascending_hsort(hasha, inda)
ni = 0
do jj = 1, Qtb%nb
ii = Findtagindex(hashb(jj), hasha(inda))
if(ii < 1) cycle
ni = ni + 1
cidx(1, ni) = inda(ii)
cidx(2, ni) = jj
if(.not. dodegout) cycle
! Construct quantum numbers for final hash
p1 = 1
p2 = snqs
do pp = 1, size(unca)
p3 = (unca(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qta%Data(inda(ii))%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
do pp = 1, size(uncb)
p3 = (uncb(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qtb%Data(jj)%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
hashout(ni) = prime_hash(qq, idxall, Qta%nqs)
if(present(qqq)) then
qqq(:, ni) = qq
end if
end do
end if
else!if((.not. deg(1)) .and. (.not. deg(2))) then
! Sorting without degneracies
! ---------------------------
if(Qta%nb <= Qtb%nb) then
call ascending_hsort(hasha, inda)
ni = 0
do jj = 1, Qtb%nb
ii = Findtagindex(hashb(jj), hasha(inda))
if(ii > 0) then
ni = ni + 1
cidx(1, ni) = inda(ii)
cidx(2, ni) = jj
if(.not. dodegout) cycle
! Construct quantum numbers for final hash
p1 = 1
p2 = snqs
do pp = 1, size(unca)
p3 = (unca(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qta%Data(inda(ii))%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
do pp = 1, size(uncb)
p3 = (uncb(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qtb%Data(jj)%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
hashout(ni) = prime_hash(qq, idxall, Qta%nqs)
if(present(qqq)) then
qqq(:, ni) = qq
end if
end if
end do
else!if(Qta%nb > Qtb%nb) then
call ascending_hsort(hashb, indb)
ni = 0
do ii = 1, Qta%nb
jj = Findtagindex(hasha(ii), hashb(indb))
if(jj > 0) then
ni = ni + 1
cidx(1, ni) = ii
cidx(2, ni) = indb(jj)
if(.not. dodegout) cycle
! Construct quantum numbers for final hash
p1 = 1
p2 = snqs
do pp = 1, size(unca)
p3 = (unca(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qta%Data(ii)%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
do pp = 1, size(uncb)
p3 = (uncb(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qtb%Data(indb(jj))%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
hashout(ni) = prime_hash(qq, idxall, Qta%nqs)
if(present(qqq)) then
qqq(:, ni) = qq
end if
end if
end do
end if
end if
if(dodegout) then
call ascending_hsort(hashout(:ni), littleout(:ni), indout(:ni), &
niunique, degout(:ni + 1))
deallocate(unca, uncb, idxall, qq, hashout, littleout)
else
niunique = ni
end if
end subroutine get_contr_idx_qtensor_qtensor
"""
return
[docs]def get_contr_idx_qtensorc_qtensorc():
"""
fortran-subroutine - October 2016 (dj)
Find the indices of the tensors in the array to be contracted with
each other.
**Arguments**
Qta : TYPE(qtensorc), in
First tensor for contraction.
idxa : INTEGER(\*), in
The following legs in Qta should be contracted over.
Qtb : TYPE(qtensorc), in
Second tensor for contraction.
idxb : INTEGER(\*), in
The following legs in Qtb should be contracted over.
deg : LOGICAL(2), in
If deg(1) = .true., hashes in Qta may be degenerate and a
degenerate sorting is applied. If deg(1) .false., hashes in
Qta must be unique in regard to the contraction inidces
idxa. Analog definition for deg(2) and Qtb.
cidx : INTEGER(2, \*), out
Storing the index of the tensors in the array of tensors to be
contracted together. Second dimension should be at least
the minumum of Qta%nb and Qtb%nb.
niunique : INTEGER, out
Number of unique matches found. To execute contraction, loop to
cidx(:, degout(niunique + 1)).
degout : INTEGER(\*), out
Allocated on exit and filled with the degenerate subsets
for the contractions. degout(ii) + 1 : degout(ii + 1) have
the same final quantum number.
qqq : INTEGER(\*, \*), OPTIONAL, inout
If present, it is allocated on exit and filled with the
quantum numbers remaining after the contraction. do_degout
must be true if qqq are calculated.
By default, the quantum numbers are not stored.
do_degout : LOGICAL, in
If .true., the hashes of the new tensor are sorted. If false,
the quantum numbers and hashes are not calculated for the output
tensor.
Default to .true.
**Details**
Disregarding the degeneracies, it is the best approach to
sort the smaller array and then look for corresponding hashes of
the bigger array in the smaller array. With :math:`n_1` the size
of the smaller array and :math:`n_2` the size of the bigger array,
it scales as :math:`n_1 log(n_1) + n_2 log(n_1)`. Sorting both
arrays and then looking for matches scales approximately with
:math:`n_1 log(n_1) + n_2 log(n_2) + min(n_1, n_2)`. For degeneracies,
it might depend on the number of unique hashes, which is not
predictable beforehand.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine get_contr_idx_qtensorc_qtensorc(Qta, idxa, Qtb, idxb, &
deg, cidx, niunique, indout, degout, qqq, do_degout, errst)
type(qtensorc), intent(in) :: Qta
type(qtensorc), intent(in) :: Qtb
integer, intent(in) :: idxa(:), idxb(:)
logical, dimension(2), intent(in) :: deg
integer, intent(out) :: cidx(:, :)
integer, intent(out) :: niunique
integer, dimension(:), allocatable, intent(out) :: indout, degout
integer, dimension(:, :), allocatable, intent(inout), optional :: qqq
logical, intent(in), optional :: do_degout
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for indexing
integer :: ii, jj, kk, i1, j1, pp, p1, p2, p3, p4
! control while do
logical :: loop
! duplicate for optional variable
logical :: dodegout
! Hashes for the two qtensors
real(KIND=rKind), dimension(Qta%nb) :: hasha
real(KIND=rKind), dimension(Qtb%nb) :: hashb
! For sorting
integer, dimension(Qta%nb) :: inda
integer, dimension(Qtb%nb) :: indb
! For degenerate sorting
integer :: na, nb
integer, dimension(:), allocatable :: dega, degb
real(KIND=rKind), dimension(:), allocatable :: littlea, littleb
! uncontracted indices
logical, dimension(:), allocatable :: uncontr
integer, dimension(:), allocatable :: unca, uncb, idxall
! total number of matches
integer :: ni
! for final quantum numbers and their sorting
integer :: snqs
integer, dimension(:), allocatable :: qq
real(KIND=rKind), dimension(:), allocatable :: hashout, littleout
!if(present(errst)) errst = 0
!if(size(idxa) /= size(idxb)) then
! errst = raise_error('get_contr_idx_qtensorc:'//&
! ' size(idxa) /= size(idxb)', 2, errst=errst)
! return
!end if
! Fast return
if((Qta%nb == 0) .or. (Qtb%nb == 0)) then
niunique = 0
return
end if
dodegout = .true.
if(present(do_degout)) dodegout = do_degout
!if((.not. dodegout) .and. present(qqq)) then
! errst = raise_error('get_contr_idx_qtensorc_'//&
! 'qtensorc: qqq and no do_degout.', &
! 99, 'qTensors_include.f90:3318', errst=errst)
! return
!end if
! Generate hashes
hasha = get_hash(Qta, idxa)
hashb = get_hash(Qtb, idxb)
! Array for hashes of output
if(dodegout) then
! Find uncontracted indices
allocate(uncontr(rank(Qta)), unca(rank(Qta) - size(idxa)))
uncontr = .true.
uncontr(idxa) = .false.
jj = 1
do ii = 1, rank(Qta)
if(uncontr(ii)) then
unca(jj) = ii
jj = jj + 1
end if
end do
deallocate(uncontr)
allocate(uncontr(rank(Qtb)), uncb(rank(Qtb) - size(idxb)))
uncontr = .true.
uncontr(idxb) = .false.
jj = 1
do ii = 1, rank(Qtb)
if(uncontr(ii)) then
uncb(jj) = ii
jj = jj + 1
end if
end do
deallocate(uncontr)
allocate(idxall(size(unca) + size(uncb)))
idxall = [(ii, ii = 1, size(idxall))]
! Store number of quantum numbers
snqs = sum(Qta%nqs)
allocate(qq(snqs * (size(unca) + size(uncb))))
allocate(hashout(Qta%nb * Qtb%nb), littleout(Qta%nb * Qtb%nb), &
indout(Qta%nb * Qtb%nb), degout(Qta%nb * Qtb%nb + 1))
end if
if(present(qqq)) then
allocate(qqq(size(qq, 1), Qta%nb * Qtb%nb))
end if
if(deg(1) .and. deg(2)) then
! Case with degeneracies
! ----------------------
if(Qta%nb < Qtb%nb) then
! Sort hashes in a
allocate(littlea(Qta%nb), dega(Qta%nb + 1))
call ascending_hsort(hasha, littlea, inda, na, dega)
ni = 0
do jj = 1, Qtb%nb
ii = Findtagindex(hashb(jj), littlea(:na))
if(ii > 0) then
do i1 = dega(ii) + 1, dega(ii + 1)
ni = ni + 1
cidx(1, ni) = inda(i1)
cidx(2, ni) = jj
if(.not. dodegout) cycle
! Construct quantum number for final hash
p1 = 1
p2 = snqs
do pp = 1, size(unca)
p3 = (unca(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qta%Data(inda(i1))%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
do pp = 1, size(uncb)
p3 = (uncb(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qtb%Data(jj)%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
hashout(ni) = prime_hash(qq, idxall, Qta%nqs)
if(present(qqq)) then
qqq(:, ni) = qq
end if
end do
end if
end do
deallocate(littlea, dega)
else
! Sort hashes in b
allocate(littleb(Qtb%nb), degb(Qtb%nb + 1))
call ascending_hsort(hashb, littleb, indb, nb, degb)
ni = 0
do ii = 1, Qta%nb
jj = Findtagindex(hasha(ii), littleb(:nb))
if(jj < 1) cycle
do j1 = degb(jj) + 1, degb(jj + 1)
ni = ni + 1
cidx(1, ni) = ii
cidx(2, ni) = indb(j1)
if(.not. dodegout) cycle
! Construct quantum number for final hash
p1 = 1
p2 = snqs
do pp = 1, size(unca)
p3 = (unca(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qta%Data(ii)%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
do pp = 1, size(uncb)
p3 = (uncb(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qtb%Data(indb(j1))%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
hashout(ni) = prime_hash(qq, idxall, Qta%nqs)
if(present(qqq)) then
qqq(:, ni) = qq
end if
end do
end do
deallocate(littleb, degb)
end if
elseif(deg(1)) then
! Sorting Qta with degeneracies, Qtb without
! ------------------------------------------
if(Qta%nb <= Qtb%nb) then
! Allocate and sort Qta
allocate(littlea(Qta%nb), dega(Qta%nb + 1))
call ascending_hsort(hasha, littlea, inda, na, dega)
ni = 0
do jj = 1, Qtb%nb
ii = Findtagindex(hashb(jj), littlea(:na))
if(ii < 1) cycle
do i1 = dega(ii) + 1, dega(ii + 1)
ni = ni + 1
cidx(1, ni) = inda(i1)
cidx(2, ni) = jj
if(.not. dodegout) cycle
! Construct quantum number for final hash
p1 = 1
p2 = snqs
do pp = 1, size(unca)
p3 = (unca(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qta%Data(inda(i1))%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
do pp = 1, size(uncb)
p3 = (uncb(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qtb%Data(jj)%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
hashout(ni) = prime_hash(qq, idxall, Qta%nqs)
if(present(qqq)) then
qqq(:, ni) = qq
end if
end do
end do
deallocate(littlea, dega)
else
call ascending_hsort(hashb, indb)
ni = 0
do ii = 1, Qta%nb
jj = Findtagindex(hasha(ii), hashb(indb))
if(jj < 1) cycle
ni = ni + 1
cidx(1, ni) = ii
cidx(2, ni) = indb(jj)
if(.not. dodegout) cycle
! Construct quantum numbers for final hash
p1 = 1
p2 = snqs
do pp = 1, size(unca)
p3 = (unca(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qta%Data(ii)%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
do pp = 1, size(uncb)
p3 = (uncb(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qtb%Data(indb(jj))%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
hashout(ni) = prime_hash(qq, idxall, Qta%nqs)
if(present(qqq)) then
qqq(:, ni) = qq
end if
end do
end if
elseif(deg(2)) then
! Sorthing Qtb with degeneracies, Qta without
! -------------------------------------------
if(Qtb%nb <= Qta%nb) then
! Allocate and sort Qtb
allocate(littleb(Qtb%nb), degb(Qtb%nb + 1))
call ascending_hsort(hashb, littleb, indb, nb, degb)
ni = 0
do ii = 1, Qta%nb
jj = Findtagindex(hasha(ii), littleb(:nb))
if(jj < 1) cycle
do j1 = degb(jj) + 1, degb(jj + 1)
ni = ni + 1
cidx(1, ni) = ii
cidx(2, ni) = indb(j1)
if(.not. dodegout) cycle
! Construct quantum number for final hash
p1 = 1
p2 = snqs
do pp = 1, size(unca)
p3 = (unca(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qta%Data(ii)%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
do pp = 1, size(uncb)
p3 = (uncb(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qtb%Data(indb(j1))%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
hashout(ni) = prime_hash(qq, idxall, Qta%nqs)
if(present(qqq)) then
qqq(:, ni) = qq
end if
end do
end do
deallocate(littleb, degb)
else
! Sort Qta
call ascending_hsort(hasha, inda)
ni = 0
do jj = 1, Qtb%nb
ii = Findtagindex(hashb(jj), hasha(inda))
if(ii < 1) cycle
ni = ni + 1
cidx(1, ni) = inda(ii)
cidx(2, ni) = jj
if(.not. dodegout) cycle
! Construct quantum numbers for final hash
p1 = 1
p2 = snqs
do pp = 1, size(unca)
p3 = (unca(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qta%Data(inda(ii))%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
do pp = 1, size(uncb)
p3 = (uncb(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qtb%Data(jj)%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
hashout(ni) = prime_hash(qq, idxall, Qta%nqs)
if(present(qqq)) then
qqq(:, ni) = qq
end if
end do
end if
else!if((.not. deg(1)) .and. (.not. deg(2))) then
! Sorting without degneracies
! ---------------------------
if(Qta%nb <= Qtb%nb) then
call ascending_hsort(hasha, inda)
ni = 0
do jj = 1, Qtb%nb
ii = Findtagindex(hashb(jj), hasha(inda))
if(ii > 0) then
ni = ni + 1
cidx(1, ni) = inda(ii)
cidx(2, ni) = jj
if(.not. dodegout) cycle
! Construct quantum numbers for final hash
p1 = 1
p2 = snqs
do pp = 1, size(unca)
p3 = (unca(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qta%Data(inda(ii))%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
do pp = 1, size(uncb)
p3 = (uncb(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qtb%Data(jj)%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
hashout(ni) = prime_hash(qq, idxall, Qta%nqs)
if(present(qqq)) then
qqq(:, ni) = qq
end if
end if
end do
else!if(Qta%nb > Qtb%nb) then
call ascending_hsort(hashb, indb)
ni = 0
do ii = 1, Qta%nb
jj = Findtagindex(hasha(ii), hashb(indb))
if(jj > 0) then
ni = ni + 1
cidx(1, ni) = ii
cidx(2, ni) = indb(jj)
if(.not. dodegout) cycle
! Construct quantum numbers for final hash
p1 = 1
p2 = snqs
do pp = 1, size(unca)
p3 = (unca(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qta%Data(ii)%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
do pp = 1, size(uncb)
p3 = (uncb(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qtb%Data(indb(jj))%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
hashout(ni) = prime_hash(qq, idxall, Qta%nqs)
if(present(qqq)) then
qqq(:, ni) = qq
end if
end if
end do
end if
end if
if(dodegout) then
call ascending_hsort(hashout(:ni), littleout(:ni), indout(:ni), &
niunique, degout(:ni + 1))
deallocate(unca, uncb, idxall, qq, hashout, littleout)
else
niunique = ni
end if
end subroutine get_contr_idx_qtensorc_qtensorc
"""
return
[docs]def get_contr_idx_qtensorc_qtensor():
"""
fortran-subroutine - October 2016 (dj)
Find the indices of the tensors in the array to be contracted with
each other.
**Arguments**
Qta : TYPE(qtensorc), in
First tensor for contraction.
idxa : INTEGER(\*), in
The following legs in Qta should be contracted over.
Qtb : TYPE(qtensor), in
Second tensor for contraction.
idxb : INTEGER(\*), in
The following legs in Qtb should be contracted over.
deg : LOGICAL(2), in
If deg(1) = .true., hashes in Qta may be degenerate and a
degenerate sorting is applied. If deg(1) .false., hashes in
Qta must be unique in regard to the contraction inidces
idxa. Analog definition for deg(2) and Qtb.
cidx : INTEGER(2, \*), out
Storing the index of the tensors in the array of tensors to be
contracted together. Second dimension should be at least
the minumum of Qta%nb and Qtb%nb.
niunique : INTEGER, out
Number of unique matches found. To execute contraction, loop to
cidx(:, degout(niunique + 1)).
degout : INTEGER(\*), out
Allocated on exit and filled with the degenerate subsets
for the contractions. degout(ii) + 1 : degout(ii + 1) have
the same final quantum number.
qqq : INTEGER(\*, \*), OPTIONAL, inout
If present, it is allocated on exit and filled with the
quantum numbers remaining after the contraction. do_degout
must be true if qqq are calculated.
By default, the quantum numbers are not stored.
do_degout : LOGICAL, in
If .true., the hashes of the new tensor are sorted. If false,
the quantum numbers and hashes are not calculated for the output
tensor.
Default to .true.
**Details**
Disregarding the degeneracies, it is the best approach to
sort the smaller array and then look for corresponding hashes of
the bigger array in the smaller array. With :math:`n_1` the size
of the smaller array and :math:`n_2` the size of the bigger array,
it scales as :math:`n_1 log(n_1) + n_2 log(n_1)`. Sorting both
arrays and then looking for matches scales approximately with
:math:`n_1 log(n_1) + n_2 log(n_2) + min(n_1, n_2)`. For degeneracies,
it might depend on the number of unique hashes, which is not
predictable beforehand.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine get_contr_idx_qtensorc_qtensor(Qta, idxa, Qtb, idxb, &
deg, cidx, niunique, indout, degout, qqq, do_degout, errst)
type(qtensorc), intent(in) :: Qta
type(qtensor), intent(in) :: Qtb
integer, intent(in) :: idxa(:), idxb(:)
logical, dimension(2), intent(in) :: deg
integer, intent(out) :: cidx(:, :)
integer, intent(out) :: niunique
integer, dimension(:), allocatable, intent(out) :: indout, degout
integer, dimension(:, :), allocatable, intent(inout), optional :: qqq
logical, intent(in), optional :: do_degout
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for indexing
integer :: ii, jj, kk, i1, j1, pp, p1, p2, p3, p4
! control while do
logical :: loop
! duplicate for optional variable
logical :: dodegout
! Hashes for the two qtensors
real(KIND=rKind), dimension(Qta%nb) :: hasha
real(KIND=rKind), dimension(Qtb%nb) :: hashb
! For sorting
integer, dimension(Qta%nb) :: inda
integer, dimension(Qtb%nb) :: indb
! For degenerate sorting
integer :: na, nb
integer, dimension(:), allocatable :: dega, degb
real(KIND=rKind), dimension(:), allocatable :: littlea, littleb
! uncontracted indices
logical, dimension(:), allocatable :: uncontr
integer, dimension(:), allocatable :: unca, uncb, idxall
! total number of matches
integer :: ni
! for final quantum numbers and their sorting
integer :: snqs
integer, dimension(:), allocatable :: qq
real(KIND=rKind), dimension(:), allocatable :: hashout, littleout
!if(present(errst)) errst = 0
!if(size(idxa) /= size(idxb)) then
! errst = raise_error('get_contr_idx_qtensor:'//&
! ' size(idxa) /= size(idxb)', 2, errst=errst)
! return
!end if
! Fast return
if((Qta%nb == 0) .or. (Qtb%nb == 0)) then
niunique = 0
return
end if
dodegout = .true.
if(present(do_degout)) dodegout = do_degout
!if((.not. dodegout) .and. present(qqq)) then
! errst = raise_error('get_contr_idx_qtensorc_'//&
! 'qtensor: qqq and no do_degout.', &
! 99, 'qTensors_include.f90:3318', errst=errst)
! return
!end if
! Generate hashes
hasha = get_hash(Qta, idxa)
hashb = get_hash(Qtb, idxb)
! Array for hashes of output
if(dodegout) then
! Find uncontracted indices
allocate(uncontr(rank(Qta)), unca(rank(Qta) - size(idxa)))
uncontr = .true.
uncontr(idxa) = .false.
jj = 1
do ii = 1, rank(Qta)
if(uncontr(ii)) then
unca(jj) = ii
jj = jj + 1
end if
end do
deallocate(uncontr)
allocate(uncontr(rank(Qtb)), uncb(rank(Qtb) - size(idxb)))
uncontr = .true.
uncontr(idxb) = .false.
jj = 1
do ii = 1, rank(Qtb)
if(uncontr(ii)) then
uncb(jj) = ii
jj = jj + 1
end if
end do
deallocate(uncontr)
allocate(idxall(size(unca) + size(uncb)))
idxall = [(ii, ii = 1, size(idxall))]
! Store number of quantum numbers
snqs = sum(Qta%nqs)
allocate(qq(snqs * (size(unca) + size(uncb))))
allocate(hashout(Qta%nb * Qtb%nb), littleout(Qta%nb * Qtb%nb), &
indout(Qta%nb * Qtb%nb), degout(Qta%nb * Qtb%nb + 1))
end if
if(present(qqq)) then
allocate(qqq(size(qq, 1), Qta%nb * Qtb%nb))
end if
if(deg(1) .and. deg(2)) then
! Case with degeneracies
! ----------------------
if(Qta%nb < Qtb%nb) then
! Sort hashes in a
allocate(littlea(Qta%nb), dega(Qta%nb + 1))
call ascending_hsort(hasha, littlea, inda, na, dega)
ni = 0
do jj = 1, Qtb%nb
ii = Findtagindex(hashb(jj), littlea(:na))
if(ii > 0) then
do i1 = dega(ii) + 1, dega(ii + 1)
ni = ni + 1
cidx(1, ni) = inda(i1)
cidx(2, ni) = jj
if(.not. dodegout) cycle
! Construct quantum number for final hash
p1 = 1
p2 = snqs
do pp = 1, size(unca)
p3 = (unca(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qta%Data(inda(i1))%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
do pp = 1, size(uncb)
p3 = (uncb(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qtb%Data(jj)%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
hashout(ni) = prime_hash(qq, idxall, Qta%nqs)
if(present(qqq)) then
qqq(:, ni) = qq
end if
end do
end if
end do
deallocate(littlea, dega)
else
! Sort hashes in b
allocate(littleb(Qtb%nb), degb(Qtb%nb + 1))
call ascending_hsort(hashb, littleb, indb, nb, degb)
ni = 0
do ii = 1, Qta%nb
jj = Findtagindex(hasha(ii), littleb(:nb))
if(jj < 1) cycle
do j1 = degb(jj) + 1, degb(jj + 1)
ni = ni + 1
cidx(1, ni) = ii
cidx(2, ni) = indb(j1)
if(.not. dodegout) cycle
! Construct quantum number for final hash
p1 = 1
p2 = snqs
do pp = 1, size(unca)
p3 = (unca(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qta%Data(ii)%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
do pp = 1, size(uncb)
p3 = (uncb(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qtb%Data(indb(j1))%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
hashout(ni) = prime_hash(qq, idxall, Qta%nqs)
if(present(qqq)) then
qqq(:, ni) = qq
end if
end do
end do
deallocate(littleb, degb)
end if
elseif(deg(1)) then
! Sorting Qta with degeneracies, Qtb without
! ------------------------------------------
if(Qta%nb <= Qtb%nb) then
! Allocate and sort Qta
allocate(littlea(Qta%nb), dega(Qta%nb + 1))
call ascending_hsort(hasha, littlea, inda, na, dega)
ni = 0
do jj = 1, Qtb%nb
ii = Findtagindex(hashb(jj), littlea(:na))
if(ii < 1) cycle
do i1 = dega(ii) + 1, dega(ii + 1)
ni = ni + 1
cidx(1, ni) = inda(i1)
cidx(2, ni) = jj
if(.not. dodegout) cycle
! Construct quantum number for final hash
p1 = 1
p2 = snqs
do pp = 1, size(unca)
p3 = (unca(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qta%Data(inda(i1))%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
do pp = 1, size(uncb)
p3 = (uncb(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qtb%Data(jj)%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
hashout(ni) = prime_hash(qq, idxall, Qta%nqs)
if(present(qqq)) then
qqq(:, ni) = qq
end if
end do
end do
deallocate(littlea, dega)
else
call ascending_hsort(hashb, indb)
ni = 0
do ii = 1, Qta%nb
jj = Findtagindex(hasha(ii), hashb(indb))
if(jj < 1) cycle
ni = ni + 1
cidx(1, ni) = ii
cidx(2, ni) = indb(jj)
if(.not. dodegout) cycle
! Construct quantum numbers for final hash
p1 = 1
p2 = snqs
do pp = 1, size(unca)
p3 = (unca(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qta%Data(ii)%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
do pp = 1, size(uncb)
p3 = (uncb(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qtb%Data(indb(jj))%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
hashout(ni) = prime_hash(qq, idxall, Qta%nqs)
if(present(qqq)) then
qqq(:, ni) = qq
end if
end do
end if
elseif(deg(2)) then
! Sorthing Qtb with degeneracies, Qta without
! -------------------------------------------
if(Qtb%nb <= Qta%nb) then
! Allocate and sort Qtb
allocate(littleb(Qtb%nb), degb(Qtb%nb + 1))
call ascending_hsort(hashb, littleb, indb, nb, degb)
ni = 0
do ii = 1, Qta%nb
jj = Findtagindex(hasha(ii), littleb(:nb))
if(jj < 1) cycle
do j1 = degb(jj) + 1, degb(jj + 1)
ni = ni + 1
cidx(1, ni) = ii
cidx(2, ni) = indb(j1)
if(.not. dodegout) cycle
! Construct quantum number for final hash
p1 = 1
p2 = snqs
do pp = 1, size(unca)
p3 = (unca(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qta%Data(ii)%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
do pp = 1, size(uncb)
p3 = (uncb(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qtb%Data(indb(j1))%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
hashout(ni) = prime_hash(qq, idxall, Qta%nqs)
if(present(qqq)) then
qqq(:, ni) = qq
end if
end do
end do
deallocate(littleb, degb)
else
! Sort Qta
call ascending_hsort(hasha, inda)
ni = 0
do jj = 1, Qtb%nb
ii = Findtagindex(hashb(jj), hasha(inda))
if(ii < 1) cycle
ni = ni + 1
cidx(1, ni) = inda(ii)
cidx(2, ni) = jj
if(.not. dodegout) cycle
! Construct quantum numbers for final hash
p1 = 1
p2 = snqs
do pp = 1, size(unca)
p3 = (unca(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qta%Data(inda(ii))%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
do pp = 1, size(uncb)
p3 = (uncb(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qtb%Data(jj)%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
hashout(ni) = prime_hash(qq, idxall, Qta%nqs)
if(present(qqq)) then
qqq(:, ni) = qq
end if
end do
end if
else!if((.not. deg(1)) .and. (.not. deg(2))) then
! Sorting without degneracies
! ---------------------------
if(Qta%nb <= Qtb%nb) then
call ascending_hsort(hasha, inda)
ni = 0
do jj = 1, Qtb%nb
ii = Findtagindex(hashb(jj), hasha(inda))
if(ii > 0) then
ni = ni + 1
cidx(1, ni) = inda(ii)
cidx(2, ni) = jj
if(.not. dodegout) cycle
! Construct quantum numbers for final hash
p1 = 1
p2 = snqs
do pp = 1, size(unca)
p3 = (unca(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qta%Data(inda(ii))%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
do pp = 1, size(uncb)
p3 = (uncb(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qtb%Data(jj)%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
hashout(ni) = prime_hash(qq, idxall, Qta%nqs)
if(present(qqq)) then
qqq(:, ni) = qq
end if
end if
end do
else!if(Qta%nb > Qtb%nb) then
call ascending_hsort(hashb, indb)
ni = 0
do ii = 1, Qta%nb
jj = Findtagindex(hasha(ii), hashb(indb))
if(jj > 0) then
ni = ni + 1
cidx(1, ni) = ii
cidx(2, ni) = indb(jj)
if(.not. dodegout) cycle
! Construct quantum numbers for final hash
p1 = 1
p2 = snqs
do pp = 1, size(unca)
p3 = (unca(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qta%Data(ii)%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
do pp = 1, size(uncb)
p3 = (uncb(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qtb%Data(indb(jj))%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
hashout(ni) = prime_hash(qq, idxall, Qta%nqs)
if(present(qqq)) then
qqq(:, ni) = qq
end if
end if
end do
end if
end if
if(dodegout) then
call ascending_hsort(hashout(:ni), littleout(:ni), indout(:ni), &
niunique, degout(:ni + 1))
deallocate(unca, uncb, idxall, qq, hashout, littleout)
else
niunique = ni
end if
end subroutine get_contr_idx_qtensorc_qtensor
"""
return
[docs]def get_contr_idx_qtensor_qtensorc():
"""
fortran-subroutine - October 2016 (dj)
Find the indices of the tensors in the array to be contracted with
each other.
**Arguments**
Qta : TYPE(qtensor), in
First tensor for contraction.
idxa : INTEGER(\*), in
The following legs in Qta should be contracted over.
Qtb : TYPE(qtensorc), in
Second tensor for contraction.
idxb : INTEGER(\*), in
The following legs in Qtb should be contracted over.
deg : LOGICAL(2), in
If deg(1) = .true., hashes in Qta may be degenerate and a
degenerate sorting is applied. If deg(1) .false., hashes in
Qta must be unique in regard to the contraction inidces
idxa. Analog definition for deg(2) and Qtb.
cidx : INTEGER(2, \*), out
Storing the index of the tensors in the array of tensors to be
contracted together. Second dimension should be at least
the minumum of Qta%nb and Qtb%nb.
niunique : INTEGER, out
Number of unique matches found. To execute contraction, loop to
cidx(:, degout(niunique + 1)).
degout : INTEGER(\*), out
Allocated on exit and filled with the degenerate subsets
for the contractions. degout(ii) + 1 : degout(ii + 1) have
the same final quantum number.
qqq : INTEGER(\*, \*), OPTIONAL, inout
If present, it is allocated on exit and filled with the
quantum numbers remaining after the contraction. do_degout
must be true if qqq are calculated.
By default, the quantum numbers are not stored.
do_degout : LOGICAL, in
If .true., the hashes of the new tensor are sorted. If false,
the quantum numbers and hashes are not calculated for the output
tensor.
Default to .true.
**Details**
Disregarding the degeneracies, it is the best approach to
sort the smaller array and then look for corresponding hashes of
the bigger array in the smaller array. With :math:`n_1` the size
of the smaller array and :math:`n_2` the size of the bigger array,
it scales as :math:`n_1 log(n_1) + n_2 log(n_1)`. Sorting both
arrays and then looking for matches scales approximately with
:math:`n_1 log(n_1) + n_2 log(n_2) + min(n_1, n_2)`. For degeneracies,
it might depend on the number of unique hashes, which is not
predictable beforehand.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine get_contr_idx_qtensor_qtensorc(Qta, idxa, Qtb, idxb, &
deg, cidx, niunique, indout, degout, qqq, do_degout, errst)
type(qtensor), intent(in) :: Qta
type(qtensorc), intent(in) :: Qtb
integer, intent(in) :: idxa(:), idxb(:)
logical, dimension(2), intent(in) :: deg
integer, intent(out) :: cidx(:, :)
integer, intent(out) :: niunique
integer, dimension(:), allocatable, intent(out) :: indout, degout
integer, dimension(:, :), allocatable, intent(inout), optional :: qqq
logical, intent(in), optional :: do_degout
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for indexing
integer :: ii, jj, kk, i1, j1, pp, p1, p2, p3, p4
! control while do
logical :: loop
! duplicate for optional variable
logical :: dodegout
! Hashes for the two qtensors
real(KIND=rKind), dimension(Qta%nb) :: hasha
real(KIND=rKind), dimension(Qtb%nb) :: hashb
! For sorting
integer, dimension(Qta%nb) :: inda
integer, dimension(Qtb%nb) :: indb
! For degenerate sorting
integer :: na, nb
integer, dimension(:), allocatable :: dega, degb
real(KIND=rKind), dimension(:), allocatable :: littlea, littleb
! uncontracted indices
logical, dimension(:), allocatable :: uncontr
integer, dimension(:), allocatable :: unca, uncb, idxall
! total number of matches
integer :: ni
! for final quantum numbers and their sorting
integer :: snqs
integer, dimension(:), allocatable :: qq
real(KIND=rKind), dimension(:), allocatable :: hashout, littleout
!if(present(errst)) errst = 0
!if(size(idxa) /= size(idxb)) then
! errst = raise_error('get_contr_idx_qtensorc:'//&
! ' size(idxa) /= size(idxb)', 2, errst=errst)
! return
!end if
! Fast return
if((Qta%nb == 0) .or. (Qtb%nb == 0)) then
niunique = 0
return
end if
dodegout = .true.
if(present(do_degout)) dodegout = do_degout
!if((.not. dodegout) .and. present(qqq)) then
! errst = raise_error('get_contr_idx_qtensor_'//&
! 'qtensorc: qqq and no do_degout.', &
! 99, 'qTensors_include.f90:3318', errst=errst)
! return
!end if
! Generate hashes
hasha = get_hash(Qta, idxa)
hashb = get_hash(Qtb, idxb)
! Array for hashes of output
if(dodegout) then
! Find uncontracted indices
allocate(uncontr(rank(Qta)), unca(rank(Qta) - size(idxa)))
uncontr = .true.
uncontr(idxa) = .false.
jj = 1
do ii = 1, rank(Qta)
if(uncontr(ii)) then
unca(jj) = ii
jj = jj + 1
end if
end do
deallocate(uncontr)
allocate(uncontr(rank(Qtb)), uncb(rank(Qtb) - size(idxb)))
uncontr = .true.
uncontr(idxb) = .false.
jj = 1
do ii = 1, rank(Qtb)
if(uncontr(ii)) then
uncb(jj) = ii
jj = jj + 1
end if
end do
deallocate(uncontr)
allocate(idxall(size(unca) + size(uncb)))
idxall = [(ii, ii = 1, size(idxall))]
! Store number of quantum numbers
snqs = sum(Qta%nqs)
allocate(qq(snqs * (size(unca) + size(uncb))))
allocate(hashout(Qta%nb * Qtb%nb), littleout(Qta%nb * Qtb%nb), &
indout(Qta%nb * Qtb%nb), degout(Qta%nb * Qtb%nb + 1))
end if
if(present(qqq)) then
allocate(qqq(size(qq, 1), Qta%nb * Qtb%nb))
end if
if(deg(1) .and. deg(2)) then
! Case with degeneracies
! ----------------------
if(Qta%nb < Qtb%nb) then
! Sort hashes in a
allocate(littlea(Qta%nb), dega(Qta%nb + 1))
call ascending_hsort(hasha, littlea, inda, na, dega)
ni = 0
do jj = 1, Qtb%nb
ii = Findtagindex(hashb(jj), littlea(:na))
if(ii > 0) then
do i1 = dega(ii) + 1, dega(ii + 1)
ni = ni + 1
cidx(1, ni) = inda(i1)
cidx(2, ni) = jj
if(.not. dodegout) cycle
! Construct quantum number for final hash
p1 = 1
p2 = snqs
do pp = 1, size(unca)
p3 = (unca(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qta%Data(inda(i1))%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
do pp = 1, size(uncb)
p3 = (uncb(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qtb%Data(jj)%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
hashout(ni) = prime_hash(qq, idxall, Qta%nqs)
if(present(qqq)) then
qqq(:, ni) = qq
end if
end do
end if
end do
deallocate(littlea, dega)
else
! Sort hashes in b
allocate(littleb(Qtb%nb), degb(Qtb%nb + 1))
call ascending_hsort(hashb, littleb, indb, nb, degb)
ni = 0
do ii = 1, Qta%nb
jj = Findtagindex(hasha(ii), littleb(:nb))
if(jj < 1) cycle
do j1 = degb(jj) + 1, degb(jj + 1)
ni = ni + 1
cidx(1, ni) = ii
cidx(2, ni) = indb(j1)
if(.not. dodegout) cycle
! Construct quantum number for final hash
p1 = 1
p2 = snqs
do pp = 1, size(unca)
p3 = (unca(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qta%Data(ii)%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
do pp = 1, size(uncb)
p3 = (uncb(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qtb%Data(indb(j1))%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
hashout(ni) = prime_hash(qq, idxall, Qta%nqs)
if(present(qqq)) then
qqq(:, ni) = qq
end if
end do
end do
deallocate(littleb, degb)
end if
elseif(deg(1)) then
! Sorting Qta with degeneracies, Qtb without
! ------------------------------------------
if(Qta%nb <= Qtb%nb) then
! Allocate and sort Qta
allocate(littlea(Qta%nb), dega(Qta%nb + 1))
call ascending_hsort(hasha, littlea, inda, na, dega)
ni = 0
do jj = 1, Qtb%nb
ii = Findtagindex(hashb(jj), littlea(:na))
if(ii < 1) cycle
do i1 = dega(ii) + 1, dega(ii + 1)
ni = ni + 1
cidx(1, ni) = inda(i1)
cidx(2, ni) = jj
if(.not. dodegout) cycle
! Construct quantum number for final hash
p1 = 1
p2 = snqs
do pp = 1, size(unca)
p3 = (unca(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qta%Data(inda(i1))%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
do pp = 1, size(uncb)
p3 = (uncb(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qtb%Data(jj)%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
hashout(ni) = prime_hash(qq, idxall, Qta%nqs)
if(present(qqq)) then
qqq(:, ni) = qq
end if
end do
end do
deallocate(littlea, dega)
else
call ascending_hsort(hashb, indb)
ni = 0
do ii = 1, Qta%nb
jj = Findtagindex(hasha(ii), hashb(indb))
if(jj < 1) cycle
ni = ni + 1
cidx(1, ni) = ii
cidx(2, ni) = indb(jj)
if(.not. dodegout) cycle
! Construct quantum numbers for final hash
p1 = 1
p2 = snqs
do pp = 1, size(unca)
p3 = (unca(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qta%Data(ii)%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
do pp = 1, size(uncb)
p3 = (uncb(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qtb%Data(indb(jj))%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
hashout(ni) = prime_hash(qq, idxall, Qta%nqs)
if(present(qqq)) then
qqq(:, ni) = qq
end if
end do
end if
elseif(deg(2)) then
! Sorthing Qtb with degeneracies, Qta without
! -------------------------------------------
if(Qtb%nb <= Qta%nb) then
! Allocate and sort Qtb
allocate(littleb(Qtb%nb), degb(Qtb%nb + 1))
call ascending_hsort(hashb, littleb, indb, nb, degb)
ni = 0
do ii = 1, Qta%nb
jj = Findtagindex(hasha(ii), littleb(:nb))
if(jj < 1) cycle
do j1 = degb(jj) + 1, degb(jj + 1)
ni = ni + 1
cidx(1, ni) = ii
cidx(2, ni) = indb(j1)
if(.not. dodegout) cycle
! Construct quantum number for final hash
p1 = 1
p2 = snqs
do pp = 1, size(unca)
p3 = (unca(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qta%Data(ii)%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
do pp = 1, size(uncb)
p3 = (uncb(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qtb%Data(indb(j1))%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
hashout(ni) = prime_hash(qq, idxall, Qta%nqs)
if(present(qqq)) then
qqq(:, ni) = qq
end if
end do
end do
deallocate(littleb, degb)
else
! Sort Qta
call ascending_hsort(hasha, inda)
ni = 0
do jj = 1, Qtb%nb
ii = Findtagindex(hashb(jj), hasha(inda))
if(ii < 1) cycle
ni = ni + 1
cidx(1, ni) = inda(ii)
cidx(2, ni) = jj
if(.not. dodegout) cycle
! Construct quantum numbers for final hash
p1 = 1
p2 = snqs
do pp = 1, size(unca)
p3 = (unca(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qta%Data(inda(ii))%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
do pp = 1, size(uncb)
p3 = (uncb(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qtb%Data(jj)%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
hashout(ni) = prime_hash(qq, idxall, Qta%nqs)
if(present(qqq)) then
qqq(:, ni) = qq
end if
end do
end if
else!if((.not. deg(1)) .and. (.not. deg(2))) then
! Sorting without degneracies
! ---------------------------
if(Qta%nb <= Qtb%nb) then
call ascending_hsort(hasha, inda)
ni = 0
do jj = 1, Qtb%nb
ii = Findtagindex(hashb(jj), hasha(inda))
if(ii > 0) then
ni = ni + 1
cidx(1, ni) = inda(ii)
cidx(2, ni) = jj
if(.not. dodegout) cycle
! Construct quantum numbers for final hash
p1 = 1
p2 = snqs
do pp = 1, size(unca)
p3 = (unca(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qta%Data(inda(ii))%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
do pp = 1, size(uncb)
p3 = (uncb(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qtb%Data(jj)%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
hashout(ni) = prime_hash(qq, idxall, Qta%nqs)
if(present(qqq)) then
qqq(:, ni) = qq
end if
end if
end do
else!if(Qta%nb > Qtb%nb) then
call ascending_hsort(hashb, indb)
ni = 0
do ii = 1, Qta%nb
jj = Findtagindex(hasha(ii), hashb(indb))
if(jj > 0) then
ni = ni + 1
cidx(1, ni) = ii
cidx(2, ni) = indb(jj)
if(.not. dodegout) cycle
! Construct quantum numbers for final hash
p1 = 1
p2 = snqs
do pp = 1, size(unca)
p3 = (unca(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qta%Data(ii)%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
do pp = 1, size(uncb)
p3 = (uncb(pp) - 1) * snqs + 1
p4 = p3 + snqs - 1
qq(p1:p2) = Qtb%Data(indb(jj))%qq(p3:p4)
p1 = p1 + snqs
p2 = p2 + snqs
end do
hashout(ni) = prime_hash(qq, idxall, Qta%nqs)
if(present(qqq)) then
qqq(:, ni) = qq
end if
end if
end do
end if
end if
if(dodegout) then
call ascending_hsort(hashout(:ni), littleout(:ni), indout(:ni), &
niunique, degout(:ni + 1))
deallocate(unca, uncb, idxall, qq, hashout, littleout)
else
niunique = ni
end if
end subroutine get_contr_idx_qtensor_qtensorc
"""
return
[docs]def get_hash_qtensor():
"""
fortran-function - October 2016 (dj)
Get the hashes of specified indices of a qtensor.
**Arguments**
Qtens : TYPE(qtensor), inout
The values of the hashes are set according to the new
indices.
idxs : INTEGER(\*), in
Specify indices to be hashed in regard to the legs of the tensor.
ii : INTEGER, OPTIONAL, in
Specify index in terms of array of tensors for generating new hash.
If not present, all tensors are set again.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function get_hash_qtensor(Qtens, idxs) result(hash)
type(qtensor), intent(in) :: Qtens
integer, intent(in) :: idxs(:)
real(KIND=rKind), dimension(Qtens%nb) :: hash
! Local variables
! ---------------
! for looping
integer :: jj
do jj = 1, Qtens%nb
hash(jj) = prime_hash(Qtens%Data(jj)%qq, idxs, Qtens%nqs)
end do
end function get_hash_qtensor
"""
return
[docs]def get_hash_qtensorc():
"""
fortran-function - October 2016 (dj)
Get the hashes of specified indices of a qtensorc.
**Arguments**
Qtens : TYPE(qtensorc), inout
The values of the hashes are set according to the new
indices.
idxs : INTEGER(\*), in
Specify indices to be hashed in regard to the legs of the tensor.
ii : INTEGER, OPTIONAL, in
Specify index in terms of array of tensors for generating new hash.
If not present, all tensors are set again.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function get_hash_qtensorc(Qtens, idxs) result(hash)
type(qtensorc), intent(in) :: Qtens
integer, intent(in) :: idxs(:)
real(KIND=rKind), dimension(Qtens%nb) :: hash
! Local variables
! ---------------
! for looping
integer :: jj
do jj = 1, Qtens%nb
hash(jj) = prime_hash(Qtens%Data(jj)%qq, idxs, Qtens%nqs)
end do
end function get_hash_qtensorc
"""
return
[docs]def get_hash_ii_qtensor():
"""
fortran-function - October 2016 (dj)
Get the hash of specified indices of a qtensor.
**Arguments**
Qtens : TYPE(qtensor), inout
The values of the hashes are set according to the new
indices.
idxs : INTEGER(\*), in
Specify indices to be hashed in regard to the legs of the tensor.
ii : INTEGER, in
Specify index in terms of array of tensors for generating new hash.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function get_hash_ii_qtensor(Qtens, idxs, ii) result(hash)
type(qtensor), intent(in) :: Qtens
integer, intent(in) :: ii
integer, intent(in) :: idxs(:)
real(KIND=rKind) :: hash
hash = prime_hash(Qtens%Data(ii)%qq, idxs, Qtens%nqs)
end function get_hash_ii_qtensor
"""
return
[docs]def get_hash_ii_qtensorc():
"""
fortran-function - October 2016 (dj)
Get the hash of specified indices of a qtensorc.
**Arguments**
Qtens : TYPE(qtensorc), inout
The values of the hashes are set according to the new
indices.
idxs : INTEGER(\*), in
Specify indices to be hashed in regard to the legs of the tensor.
ii : INTEGER, in
Specify index in terms of array of tensors for generating new hash.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function get_hash_ii_qtensorc(Qtens, idxs, ii) result(hash)
type(qtensorc), intent(in) :: Qtens
integer, intent(in) :: ii
integer, intent(in) :: idxs(:)
real(KIND=rKind) :: hash
hash = prime_hash(Qtens%Data(ii)%qq, idxs, Qtens%nqs)
end function get_hash_ii_qtensorc
"""
return
[docs]def get_scalar_qtensor():
"""
fortran-function - July 2017 (dj)
Get the scalar if the tensor represents a rank-0 tensor.
**Arguments**
Qtens : TYPE(qtensor), in
Return the scalar entry of a rank-0 tensor.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function get_scalar_qtensor(Qtens, errst) result(sc)
type(qtensor), intent(in) :: Qtens
integer, intent(out), optional :: errst
real(KIND=rKind) :: sc
! No local variables
! ------------------
!if(present(errst)) errst = 0
! Fast return
if(Qtens%nb == 0) then
sc = 0.0_rKind
return
end if
!if(1 > size(Qtens%Data)) then
!errst = raise_error('get_scalar_qtensor : no blocks.', &
! 99, errst=errst)
!return
!end if
sc = Qtens%Data(1)%Tens%elem(1)
end function get_scalar_qtensor
"""
return
[docs]def get_scalar_qtensorc():
"""
fortran-function - July 2017 (dj)
Get the scalar if the tensor represents a rank-0 tensor.
**Arguments**
Qtens : TYPE(qtensorc), in
Return the scalar entry of a rank-0 tensor.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function get_scalar_qtensorc(Qtens, errst) result(sc)
type(qtensorc), intent(in) :: Qtens
integer, intent(out), optional :: errst
complex(KIND=rKind) :: sc
! No local variables
! ------------------
!if(present(errst)) errst = 0
! Fast return
if(Qtens%nb == 0) then
sc = 0.0_rKind
return
end if
!if(1 > size(Qtens%Data)) then
!errst = raise_error('get_scalar_qtensorc : no blocks.', &
! 99, errst=errst)
!return
!end if
sc = Qtens%Data(1)%Tens%elem(1)
end function get_scalar_qtensorc
"""
return
[docs]def get_sum_idx_qtensor():
"""
fortran-subroutine - Calculate which tensors have the same hash for selected indices.
**Arguments**
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine get_sum_idx_qtensor(Qta, idxa, Qtb, idxb, cidx, ni, errst)
type(qtensor), intent(in) :: Qta, Qtb
integer, intent(in) :: idxa(:), idxb(:), cidx(:, :)
integer, intent(in) :: ni
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping / indexing
integer :: ii, jj, j1, j2, k1, k2
! sum of nqs
integer :: snqs
! Storing quantum numbers
integer, dimension(:), allocatable :: qn, idxab
! Storing new hashes
real(KIND=rKind), dimension(:), allocatable :: hashes
!if(present(errst)) errst = 0
snqs = sum(Qta%nqs)
allocate(qn(snqs * size(idxa)), hashes(ni), &
idxab(size(idxa) + size(idxb)))
idxab = [(ii, ii = 1, size(idxa) + size(idxb))]
! Collect hashes
! ..............
do ii = 1, ni
k1 = 1
k2 = snqs
do jj = 1, size(idxa)
j1 = (jj - 1) * snqs + 1
j2 = jj * snqs
qn(k1:k2) = Qta%Data(cidx(1, ii))%qq(j1:j2)
k1 = k2 + 1
k2 = k1 + snqs
end do
do jj = 1, size(idxb)
j1 = (jj - 1) * snqs + 1
j2 = jj * snqs
qn(k1:k2) = Qtb%Data(cidx(2, ii))%qq(j1:j2)
k1 = k2 + 1
k2 = k2 + snqs
end do
hashes(ii) = prime_hash(qn, idxab, Qta%nqs)
end do
! Sort them
deallocate(qn, hashes, idxab)
end subroutine get_sum_idx_qtensor
"""
return
[docs]def get_sum_idx_qtensorc():
"""
fortran-subroutine -
**Arguments**
Calculate which tensors have the same hash for selected indices.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine get_sum_idx_qtensorc(Qta, idxa, Qtb, idxb, cidx, ni, errst)
type(qtensorc), intent(in) :: Qta, Qtb
integer, intent(in) :: idxa(:), idxb(:), cidx(:, :)
integer, intent(in) :: ni
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping / indexing
integer :: ii, jj, j1, j2, k1, k2
! sum of nqs
integer :: snqs
! Storing quantum numbers
integer, dimension(:), allocatable :: qn, idxab
! Storing new hashes
real(KIND=rKind), dimension(:), allocatable :: hashes
!if(present(errst)) errst = 0
snqs = sum(Qta%nqs)
allocate(qn(snqs * size(idxa)), hashes(ni), &
idxab(size(idxa) + size(idxb)))
idxab = [(ii, ii = 1, size(idxa) + size(idxb))]
! Collect hashes
! ..............
do ii = 1, ni
k1 = 1
k2 = snqs
do jj = 1, size(idxa)
j1 = (jj - 1) * snqs + 1
j2 = jj * snqs
qn(k1:k2) = Qta%Data(cidx(1, ii))%qq(j1:j2)
k1 = k2 + 1
k2 = k1 + snqs
end do
do jj = 1, size(idxb)
j1 = (jj - 1) * snqs + 1
j2 = jj * snqs
qn(k1:k2) = Qtb%Data(cidx(2, ii))%qq(j1:j2)
k1 = k2 + 1
k2 = k2 + snqs
end do
hashes(ii) = prime_hash(qn, idxab, Qta%nqs)
end do
! Sort them
deallocate(qn, hashes, idxab)
end subroutine get_sum_idx_qtensorc
"""
return
[docs]def has_nan_qtensor():
"""
fortran-function - October 2017 (dj)
**Arguments**
Check if the tensor has NAN in the actual arrays.
Tens : TYPE(TENSOR_TYPE), in
Check NAN on the entries of its subtensors. Check does not
apply to rank, dimensions, quantum numbers, etc.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function has_nan_qtensor(Qt, errst) result(hasnan)
type(qtensor), intent(in) :: Qt
integer, intent(out), optional :: errst
logical :: hasnan
! Local variables
! ---------------
! for looping
integer :: ii
!if(present(errst)) errst = 0
hasnan = .false.
do ii = 1, Qt%nb
hasnan = hasnan .or. has_nan(Qt%Data(ii)%Tens)
if(hasnan) exit
end do
end function has_nan_qtensor
"""
return
[docs]def has_nan_qtensorc():
"""
fortran-function - October 2017 (dj)
Check if the tensor has NAN in the actual arrays.
**Arguments**
Tens : TYPE(TENSOR_TYPE), in
Check NAN on the entries of its subtensors. Check does not
apply to rank, dimensions, quantum numbers, etc.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function has_nan_qtensorc(Qt, errst) result(hasnan)
type(qtensorc), intent(in) :: Qt
integer, intent(out), optional :: errst
logical :: hasnan
! Local variables
! ---------------
! for looping
integer :: ii
!if(present(errst)) errst = 0
hasnan = .false.
do ii = 1, Qt%nb
hasnan = hasnan .or. has_nan(Qt%Data(ii)%Tens)
if(hasnan) exit
end do
end function has_nan_qtensorc
"""
return
[docs]def Increase_Capacity_qtensor():
"""
fortran-subroutine - ?? ()
Increase the capacity of the vector, if required. Uses an exponential
growth rate for amortized constant time expansion.
details (template defined in qTensors_include.f90)
**Arguments**
Qt : TYPE(qtensor), inout
Increase the number of possible blocks stored in this tensor `V`.
capacity : INTEGER, in
Maximum of capacity and growth rate times the old capacity is taken
as new capacity.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine Increase_Capacity_qtensor(Qt, capacity, errst)
type(qtensor), intent(inout) :: Qt
integer, intent(in) :: capacity
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! increased capacity
integer :: newcap
! Temporary storage to copy data
type(internal_qtensor), dimension(:), pointer :: Tmpdata
real(KIND=rKind), dimension(:), pointer :: tmphash
newcap = max(capacity, ceiling(growth_rate * Qt%capacity))
if(newcap > Qt%capacity) then
allocate(Tmpdata(1:newcap))
do ii = Qt%nb + 1, newcap
! Nullify new of them
Tmpdata(ii)%Tens%dl => null()
Tmpdata(ii)%Tens%mdl => null()
Tmpdata(ii)%Tens%idx => null()
Tmpdata(ii)%Tens%elem => null()
end do
Tmpdata(1:Qt%nb) = Qt%Data(1:Qt%nb)
deallocate(Qt%Data)
Qt%Data => Tmpdata
allocate(tmphash(1:newcap))
tmphash(1:Qt%nb) = Qt%hash(1:Qt%nb)
deallocate(Qt%hash)
Qt%hash => tmphash
Qt%capacity= newcap
end if
end subroutine Increase_Capacity_qtensor
"""
return
[docs]def Increase_Capacity_qtensorc():
"""
fortran-subroutine - ?? ()
Increase the capacity of the vector, if required. Uses an exponential
growth rate for amortized constant time expansion.
details (template defined in qTensors_include.f90)
**Arguments**
Qt : TYPE(qtensorc), inout
Increase the number of possible blocks stored in this tensor `V`.
capacity : INTEGER, in
Maximum of capacity and growth rate times the old capacity is taken
as new capacity.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine Increase_Capacity_qtensorc(Qt, capacity, errst)
type(qtensorc), intent(inout) :: Qt
integer, intent(in) :: capacity
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! increased capacity
integer :: newcap
! Temporary storage to copy data
type(internal_qtensorc), dimension(:), pointer :: Tmpdata
real(KIND=rKind), dimension(:), pointer :: tmphash
newcap = max(capacity, ceiling(growth_rate * Qt%capacity))
if(newcap > Qt%capacity) then
allocate(Tmpdata(1:newcap))
do ii = Qt%nb + 1, newcap
! Nullify new of them
Tmpdata(ii)%Tens%dl => null()
Tmpdata(ii)%Tens%mdl => null()
Tmpdata(ii)%Tens%idx => null()
Tmpdata(ii)%Tens%elem => null()
end do
Tmpdata(1:Qt%nb) = Qt%Data(1:Qt%nb)
deallocate(Qt%Data)
Qt%Data => Tmpdata
allocate(tmphash(1:newcap))
tmphash(1:Qt%nb) = Qt%hash(1:Qt%nb)
deallocate(Qt%hash)
Qt%hash => tmphash
Qt%capacity= newcap
end if
end subroutine Increase_Capacity_qtensorc
"""
return
[docs]def is_eye_qtensor():
"""
fortran-function - August 2017 (dj)
Check if the tensor is an identity.
**Arguments**
Tens : TYPE(TENSOR_TYPE), in
This tensor is checked if it is an identity.
**Details**
We define the identity for any rank as a tensor
where the quantum numbers are equal on each link. For each
subtensor, the subtensor has ones for i_1 = i_2 = ... = i_n,
and otherwise zeros.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function is_eye_qtensor(Qt, errst) result(res)
type(qtensor), intent(in) :: Qt
integer, intent(out), optional :: errst
logical :: res
! Local variables
! ---------------
! for looping
integer :: ii
!if(present(errst)) errst = 0
res = .true.
do ii = 1, Qt%nb
! To-Do : check on quantum numbers
stop 'Check on quantum numbers missing.'
if(.not. is_eye(Qt%Data(ii)%Tens)) then
res = .false.
return
end if
end do
end function is_eye_qtensor
"""
return
[docs]def is_eye_qtensorc():
"""
fortran-function - August 2017 (dj)
Check if the tensor is an identity.
**Arguments**
Tens : TYPE(TENSOR_TYPE), in
This tensor is checked if it is an identity.
**Details**
We define the identity for any rank as a tensor
where the quantum numbers are equal on each link. For each
subtensor, the subtensor has ones for i_1 = i_2 = ... = i_n,
and otherwise zeros.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function is_eye_qtensorc(Qt, errst) result(res)
type(qtensorc), intent(in) :: Qt
integer, intent(out), optional :: errst
logical :: res
! Local variables
! ---------------
! for looping
integer :: ii
!if(present(errst)) errst = 0
res = .true.
do ii = 1, Qt%nb
! To-Do : check on quantum numbers
stop 'Check on quantum numbers missing.'
if(.not. is_eye(Qt%Data(ii)%Tens)) then
res = .false.
return
end if
end do
end function is_eye_qtensorc
"""
return
[docs]def is_set_qtensor():
"""
fortran-function - August 2017 (dj)
Check if a qtensor is in use.
**Arguments**
Qt : TYPE(qtensor), in
Check if the qtensor was used, i.e. a call to create. A qtensor
with zero blocks is used and will return true.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function is_set_qtensor(Qt, errst) result(res)
type(qtensor), intent(in) :: Qt
integer, intent(out), optional :: errst
logical :: res
! No local variables
! ------------------
!if(present(errst)) errst = 0
res = .not. (Qt%nb == -1)
end function is_set_qtensor
"""
return
[docs]def is_set_qtensorc():
"""
fortran-function - August 2017 (dj)
Check if a qtensor is in use.
**Arguments**
Qt : TYPE(qtensorc), in
Check if the qtensor was used, i.e. a call to create. A qtensor
with zero blocks is used and will return true.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function is_set_qtensorc(Qt, errst) result(res)
type(qtensorc), intent(in) :: Qt
integer, intent(out), optional :: errst
logical :: res
! No local variables
! ------------------
!if(present(errst)) errst = 0
res = .not. (Qt%nb == -1)
end function is_set_qtensorc
"""
return
[docs]def kron_qtensor_qtensor():
"""
fortran-subroutine -
**Details**
For qtensor, the restriction is to rank-2 tensors
and no transformations.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine kron_qtensor_qtensor(Tout, Tl, Tr, llr, lrr, &
transl, transr, op, errst)
type(qtensor), intent(inout) :: Tout
type(qtensor), intent(in) :: Tl, Tr
integer, intent(in) :: llr, lrr
character, intent(in) :: transl, transr, op
integer, intent(out), optional :: errst
! Local variables
!----------------
! for looping
integer :: ii, jj
! shortcut to nqs
integer :: snqs
! temporary tensor, to difficult to do += on qtensors
type(qtensor) :: Tmp
!if(present(errst)) errst = 0
! Fast return
if((Tl%nb == 0) .or. (Tr%nb == 0)) then
call create(Tout, Tl%nqs, 1)
return
end if
!if(rank(Tl) /= 2) then
! errst = raise_error('kron_qtensor_'//&
! 'qtensor : not implemented.', &
! 99, 'qTensors_include.f90:4225', errst=errst)
! return
!end if
!if(rank(Tr) /= 2) then
! errst = raise_error('kron_qtensor_'//&
! 'qtensor : not implemented.', &
! 99, 'qTensors_include.f90:4232', errst=errst)
! return
!end if
snqs = sum(Tl%nqs)
if(op == 'N') then
! Act directly on Tout
call create(Tout, Tl%nqs, Tl%nb * Tr%nb)
do ii = 1, Tl%nb
do jj = 1, Tr%nb
Tout%nb = Tout%nb + 1
call kron(Tout%Data(Tout%nb)%Tens, Tl%Data(ii)%Tens, &
Tr%Data(jj)%Tens, llr, lrr, transl, transr, 'N')
allocate(Tout%Data(Tout%nb)%qq(4 * snqs))
if((transl == 'N') .and. (transr == 'N')) then
! No permutation on quantum numbers
Tout%Data(Tout%nb)%qq = [Tl%Data(ii)%qq(:snqs), &
Tr%Data(jj)%qq(:snqs), &
Tl%Data(ii)%qq(snqs + 1:2 * snqs), &
Tr%Data(jj)%qq(snqs + 1:2 * snqs)]
elseif(transl == 'N') then
! The right argument is transposed or daggered
Tout%Data(Tout%nb)%qq = [Tl%Data(ii)%qq(:snqs), &
Tr%Data(jj)%qq(snqs + 1:2 * snqs), &
Tl%Data(ii)%qq(snqs + 1:2 * snqs), &
Tr%Data(jj)%qq(:snqs)]
elseif(transr == 'N') then
! The left argument is transposed or daggered
Tout%Data(Tout%nb)%qq = [Tl%Data(ii)%qq(snqs + 1:2 * snqs), &
Tr%Data(jj)%qq(:snqs), &
Tl%Data(ii)%qq(:snqs), &
Tr%Data(jj)%qq(snqs + 1:2 * snqs)]
else
! Both arguments are transposed or daggered
Tout%Data(Tout%nb)%qq = [Tl%Data(ii)%qq(snqs + 1:2 * snqs), &
Tr%Data(jj)%qq(snqs + 1:2 * snqs), &
Tl%Data(ii)%qq(:snqs), &
Tr%Data(jj)%qq(:snqs)]
end if
end do
end do
elseif(op == '+') then
! Execute Kronecker on temporary tensor and use GAXPY
call create(Tmp, Tl%nqs, Tl%nb * Tr%nb)
do ii = 1, Tl%nb
!if(Tl%Data(ii)%Tens%rank /= 2) stop 'Not implemented'
do jj = 1, Tr%nb
!if(Tr%Data(jj)%Tens%rank /= 2) stop 'Not implemented'
Tmp%nb = Tmp%nb + 1
call kron(Tmp%Data(Tmp%nb)%Tens, Tl%Data(ii)%Tens, &
Tr%Data(jj)%Tens, llr, lrr, transl, transr, 'N')
allocate(Tmp%Data(Tmp%nb)%qq(4 * snqs))
if((transl == 'N') .and. (transr == 'N')) then
! No permutation on quantum numbers
Tmp%Data(Tmp%nb)%qq = [Tl%Data(ii)%qq(:snqs), &
Tr%Data(jj)%qq(:snqs), &
Tl%Data(ii)%qq(snqs + 1:2 * snqs), &
Tr%Data(jj)%qq(snqs + 1:2 * snqs)]
elseif(transl == 'N') then
! The right argument is transposed or daggered
Tmp%Data(Tmp%nb)%qq = [Tl%Data(ii)%qq(:snqs), &
Tr%Data(jj)%qq(snqs + 1:2 * snqs), &
Tl%Data(ii)%qq(snqs + 1:2 * snqs), &
Tr%Data(jj)%qq(:snqs)]
elseif(transr == 'N') then
! The left argument is transposed or daggered
Tmp%Data(Tmp%nb)%qq = [Tl%Data(ii)%qq(snqs + 1:2 * snqs), &
Tr%Data(jj)%qq(:snqs), &
Tl%Data(ii)%qq(:snqs), &
Tr%Data(jj)%qq(snqs + 1:2 * snqs)]
else
! Both arguments are transposed or daggered
Tmp%Data(Tmp%nb)%qq = [Tl%Data(ii)%qq(snqs + 1:2 * snqs), &
Tr%Data(jj)%qq(snqs + 1:2 * snqs), &
Tl%Data(ii)%qq(:snqs), &
Tr%Data(jj)%qq(:snqs)]
end if
end do
end do
call gaxpy(Tout, 1.0_rKind, Tmp)
call destroy(Tmp)
end if
end subroutine kron_qtensor_qtensor
"""
return
[docs]def kron_qtensorc_qtensorc():
"""
fortran-subroutine -
**Details**
For qtensorc, the restriction is to rank-2 tensors
and no transformations.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine kron_qtensorc_qtensorc(Tout, Tl, Tr, llr, lrr, &
transl, transr, op, errst)
type(qtensorc), intent(inout) :: Tout
type(qtensorc), intent(in) :: Tl, Tr
integer, intent(in) :: llr, lrr
character, intent(in) :: transl, transr, op
integer, intent(out), optional :: errst
! Local variables
!----------------
! for looping
integer :: ii, jj
! shortcut to nqs
integer :: snqs
! temporary tensor, to difficult to do += on qtensors
type(qtensorc) :: Tmp
!if(present(errst)) errst = 0
! Fast return
if((Tl%nb == 0) .or. (Tr%nb == 0)) then
call create(Tout, Tl%nqs, 1)
return
end if
!if(rank(Tl) /= 2) then
! errst = raise_error('kron_qtensorc_'//&
! 'qtensorc : not implemented.', &
! 99, 'qTensors_include.f90:4225', errst=errst)
! return
!end if
!if(rank(Tr) /= 2) then
! errst = raise_error('kron_qtensorc_'//&
! 'qtensorc : not implemented.', &
! 99, 'qTensors_include.f90:4232', errst=errst)
! return
!end if
snqs = sum(Tl%nqs)
if(op == 'N') then
! Act directly on Tout
call create(Tout, Tl%nqs, Tl%nb * Tr%nb)
do ii = 1, Tl%nb
do jj = 1, Tr%nb
Tout%nb = Tout%nb + 1
call kron(Tout%Data(Tout%nb)%Tens, Tl%Data(ii)%Tens, &
Tr%Data(jj)%Tens, llr, lrr, transl, transr, 'N')
allocate(Tout%Data(Tout%nb)%qq(4 * snqs))
if((transl == 'N') .and. (transr == 'N')) then
! No permutation on quantum numbers
Tout%Data(Tout%nb)%qq = [Tl%Data(ii)%qq(:snqs), &
Tr%Data(jj)%qq(:snqs), &
Tl%Data(ii)%qq(snqs + 1:2 * snqs), &
Tr%Data(jj)%qq(snqs + 1:2 * snqs)]
elseif(transl == 'N') then
! The right argument is transposed or daggered
Tout%Data(Tout%nb)%qq = [Tl%Data(ii)%qq(:snqs), &
Tr%Data(jj)%qq(snqs + 1:2 * snqs), &
Tl%Data(ii)%qq(snqs + 1:2 * snqs), &
Tr%Data(jj)%qq(:snqs)]
elseif(transr == 'N') then
! The left argument is transposed or daggered
Tout%Data(Tout%nb)%qq = [Tl%Data(ii)%qq(snqs + 1:2 * snqs), &
Tr%Data(jj)%qq(:snqs), &
Tl%Data(ii)%qq(:snqs), &
Tr%Data(jj)%qq(snqs + 1:2 * snqs)]
else
! Both arguments are transposed or daggered
Tout%Data(Tout%nb)%qq = [Tl%Data(ii)%qq(snqs + 1:2 * snqs), &
Tr%Data(jj)%qq(snqs + 1:2 * snqs), &
Tl%Data(ii)%qq(:snqs), &
Tr%Data(jj)%qq(:snqs)]
end if
end do
end do
elseif(op == '+') then
! Execute Kronecker on temporary tensor and use GAXPY
call create(Tmp, Tl%nqs, Tl%nb * Tr%nb)
do ii = 1, Tl%nb
!if(Tl%Data(ii)%Tens%rank /= 2) stop 'Not implemented'
do jj = 1, Tr%nb
!if(Tr%Data(jj)%Tens%rank /= 2) stop 'Not implemented'
Tmp%nb = Tmp%nb + 1
call kron(Tmp%Data(Tmp%nb)%Tens, Tl%Data(ii)%Tens, &
Tr%Data(jj)%Tens, llr, lrr, transl, transr, 'N')
allocate(Tmp%Data(Tmp%nb)%qq(4 * snqs))
if((transl == 'N') .and. (transr == 'N')) then
! No permutation on quantum numbers
Tmp%Data(Tmp%nb)%qq = [Tl%Data(ii)%qq(:snqs), &
Tr%Data(jj)%qq(:snqs), &
Tl%Data(ii)%qq(snqs + 1:2 * snqs), &
Tr%Data(jj)%qq(snqs + 1:2 * snqs)]
elseif(transl == 'N') then
! The right argument is transposed or daggered
Tmp%Data(Tmp%nb)%qq = [Tl%Data(ii)%qq(:snqs), &
Tr%Data(jj)%qq(snqs + 1:2 * snqs), &
Tl%Data(ii)%qq(snqs + 1:2 * snqs), &
Tr%Data(jj)%qq(:snqs)]
elseif(transr == 'N') then
! The left argument is transposed or daggered
Tmp%Data(Tmp%nb)%qq = [Tl%Data(ii)%qq(snqs + 1:2 * snqs), &
Tr%Data(jj)%qq(:snqs), &
Tl%Data(ii)%qq(:snqs), &
Tr%Data(jj)%qq(snqs + 1:2 * snqs)]
else
! Both arguments are transposed or daggered
Tmp%Data(Tmp%nb)%qq = [Tl%Data(ii)%qq(snqs + 1:2 * snqs), &
Tr%Data(jj)%qq(snqs + 1:2 * snqs), &
Tl%Data(ii)%qq(:snqs), &
Tr%Data(jj)%qq(:snqs)]
end if
end do
end do
call gaxpy(Tout, 1.0_rKind, Tmp)
call destroy(Tmp)
end if
end subroutine kron_qtensorc_qtensorc
"""
return
[docs]def kron_qtensorc_qtensor():
"""
fortran-subroutine -
**Details**
For qtensor, the restriction is to rank-2 tensors
and no transformations.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine kron_qtensorc_qtensor(Tout, Tl, Tr, llr, lrr, &
transl, transr, op, errst)
type(qtensorc), intent(inout) :: Tout
type(qtensor), intent(in) :: Tl, Tr
integer, intent(in) :: llr, lrr
character, intent(in) :: transl, transr, op
integer, intent(out), optional :: errst
! Local variables
!----------------
! for looping
integer :: ii, jj
! shortcut to nqs
integer :: snqs
! temporary tensor, to difficult to do += on qtensors
type(qtensor) :: Tmp
!if(present(errst)) errst = 0
! Fast return
if((Tl%nb == 0) .or. (Tr%nb == 0)) then
call create(Tout, Tl%nqs, 1)
return
end if
!if(rank(Tl) /= 2) then
! errst = raise_error('kron_qtensorc_'//&
! 'qtensor : not implemented.', &
! 99, 'qTensors_include.f90:4225', errst=errst)
! return
!end if
!if(rank(Tr) /= 2) then
! errst = raise_error('kron_qtensorc_'//&
! 'qtensor : not implemented.', &
! 99, 'qTensors_include.f90:4232', errst=errst)
! return
!end if
snqs = sum(Tl%nqs)
if(op == 'N') then
! Act directly on Tout
call create(Tout, Tl%nqs, Tl%nb * Tr%nb)
do ii = 1, Tl%nb
do jj = 1, Tr%nb
Tout%nb = Tout%nb + 1
call kron(Tout%Data(Tout%nb)%Tens, Tl%Data(ii)%Tens, &
Tr%Data(jj)%Tens, llr, lrr, transl, transr, 'N')
allocate(Tout%Data(Tout%nb)%qq(4 * snqs))
if((transl == 'N') .and. (transr == 'N')) then
! No permutation on quantum numbers
Tout%Data(Tout%nb)%qq = [Tl%Data(ii)%qq(:snqs), &
Tr%Data(jj)%qq(:snqs), &
Tl%Data(ii)%qq(snqs + 1:2 * snqs), &
Tr%Data(jj)%qq(snqs + 1:2 * snqs)]
elseif(transl == 'N') then
! The right argument is transposed or daggered
Tout%Data(Tout%nb)%qq = [Tl%Data(ii)%qq(:snqs), &
Tr%Data(jj)%qq(snqs + 1:2 * snqs), &
Tl%Data(ii)%qq(snqs + 1:2 * snqs), &
Tr%Data(jj)%qq(:snqs)]
elseif(transr == 'N') then
! The left argument is transposed or daggered
Tout%Data(Tout%nb)%qq = [Tl%Data(ii)%qq(snqs + 1:2 * snqs), &
Tr%Data(jj)%qq(:snqs), &
Tl%Data(ii)%qq(:snqs), &
Tr%Data(jj)%qq(snqs + 1:2 * snqs)]
else
! Both arguments are transposed or daggered
Tout%Data(Tout%nb)%qq = [Tl%Data(ii)%qq(snqs + 1:2 * snqs), &
Tr%Data(jj)%qq(snqs + 1:2 * snqs), &
Tl%Data(ii)%qq(:snqs), &
Tr%Data(jj)%qq(:snqs)]
end if
end do
end do
elseif(op == '+') then
! Execute Kronecker on temporary tensor and use GAXPY
call create(Tmp, Tl%nqs, Tl%nb * Tr%nb)
do ii = 1, Tl%nb
!if(Tl%Data(ii)%Tens%rank /= 2) stop 'Not implemented'
do jj = 1, Tr%nb
!if(Tr%Data(jj)%Tens%rank /= 2) stop 'Not implemented'
Tmp%nb = Tmp%nb + 1
call kron(Tmp%Data(Tmp%nb)%Tens, Tl%Data(ii)%Tens, &
Tr%Data(jj)%Tens, llr, lrr, transl, transr, 'N')
allocate(Tmp%Data(Tmp%nb)%qq(4 * snqs))
if((transl == 'N') .and. (transr == 'N')) then
! No permutation on quantum numbers
Tmp%Data(Tmp%nb)%qq = [Tl%Data(ii)%qq(:snqs), &
Tr%Data(jj)%qq(:snqs), &
Tl%Data(ii)%qq(snqs + 1:2 * snqs), &
Tr%Data(jj)%qq(snqs + 1:2 * snqs)]
elseif(transl == 'N') then
! The right argument is transposed or daggered
Tmp%Data(Tmp%nb)%qq = [Tl%Data(ii)%qq(:snqs), &
Tr%Data(jj)%qq(snqs + 1:2 * snqs), &
Tl%Data(ii)%qq(snqs + 1:2 * snqs), &
Tr%Data(jj)%qq(:snqs)]
elseif(transr == 'N') then
! The left argument is transposed or daggered
Tmp%Data(Tmp%nb)%qq = [Tl%Data(ii)%qq(snqs + 1:2 * snqs), &
Tr%Data(jj)%qq(:snqs), &
Tl%Data(ii)%qq(:snqs), &
Tr%Data(jj)%qq(snqs + 1:2 * snqs)]
else
! Both arguments are transposed or daggered
Tmp%Data(Tmp%nb)%qq = [Tl%Data(ii)%qq(snqs + 1:2 * snqs), &
Tr%Data(jj)%qq(snqs + 1:2 * snqs), &
Tl%Data(ii)%qq(:snqs), &
Tr%Data(jj)%qq(:snqs)]
end if
end do
end do
call gaxpy(Tout, 1.0_rKind, Tmp)
call destroy(Tmp)
end if
end subroutine kron_qtensorc_qtensor
"""
return
[docs]def maxlineardim_qtensor():
"""
fortran-function - June 2017 (updated dj)
**Arguments**
Tens : TYPE(qtensor), in
Get the maximal dimension of this tensor.
idx : INTEGER(\*), in
Search only over these indices of the rank-n tensor.
**Details**
Return the maximal dimension of all n indices in the
rank-n tensor, or selected indices.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function maxlineardim_qtensor(Tens, idx) result(mld)
type(qtensor), intent(in) :: Tens
integer, dimension(:), optional :: idx
integer :: mld
! Local variables
! ---------------
! for looping
integer :: ii, jj
! temporary dimension
integer :: tdim
! temporary storage of hashes and sorting them
real(KIND=rKind), dimension(:), allocatable :: tmphash
integer, dimension(:), allocatable :: ind
mld = 0
! Fast return
if(Tens%nb == 0) return
! allocate arrays
allocate(tmphash(Tens%nb), ind(Tens%nb))
if(present(idx)) then
do ii = 1, size(idx)
tmphash = get_hash(Tens, [idx(ii)])
call ascending_hsort(tmphash, ind)
tdim = Tens%Data(ind(1))%Tens%dl(idx(ii))
do jj = 2, Tens%nb
if(tmphash(ind(jj)) /= tmphash(ind(jj - 1))) then
tdim = tdim + Tens%Data(ind(jj))%Tens%dl(idx(ii))
end if
end do
mld = max(mld, tdim)
end do
else
do ii = 1, Tens%Data(1)%Tens%rank
tmphash = get_hash(Tens, [ii])
call ascending_hsort(tmphash, ind)
tdim = Tens%Data(ind(1))%Tens%dl(ii)
do jj = 2, Tens%nb
if(tmphash(ind(jj)) /= tmphash(ind(jj - 1))) then
tdim = tdim + Tens%Data(ind(jj))%Tens%dl(ii)
end if
end do
mld = max(mld, tdim)
end do
end if
deallocate(tmphash, ind)
end function maxlineardim_qtensor
"""
return
[docs]def maxlineardim_qtensorc():
"""
fortran-function - June 2017 (updated dj)
Return the maximal dimension of all n indices in the
rank-n tensor, or selected indices.
**Arguments**
Tens : TYPE(qtensorc), in
Get the maximal dimension of this tensor.
idx : INTEGER(\*), in
Search only over these indices of the rank-n tensor.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function maxlineardim_qtensorc(Tens, idx) result(mld)
type(qtensorc), intent(in) :: Tens
integer, dimension(:), optional :: idx
integer :: mld
! Local variables
! ---------------
! for looping
integer :: ii, jj
! temporary dimension
integer :: tdim
! temporary storage of hashes and sorting them
real(KIND=rKind), dimension(:), allocatable :: tmphash
integer, dimension(:), allocatable :: ind
mld = 0
! Fast return
if(Tens%nb == 0) return
! allocate arrays
allocate(tmphash(Tens%nb), ind(Tens%nb))
if(present(idx)) then
do ii = 1, size(idx)
tmphash = get_hash(Tens, [idx(ii)])
call ascending_hsort(tmphash, ind)
tdim = Tens%Data(ind(1))%Tens%dl(idx(ii))
do jj = 2, Tens%nb
if(tmphash(ind(jj)) /= tmphash(ind(jj - 1))) then
tdim = tdim + Tens%Data(ind(jj))%Tens%dl(idx(ii))
end if
end do
mld = max(mld, tdim)
end do
else
do ii = 1, Tens%Data(1)%Tens%rank
tmphash = get_hash(Tens, [ii])
call ascending_hsort(tmphash, ind)
tdim = Tens%Data(ind(1))%Tens%dl(ii)
do jj = 2, Tens%nb
if(tmphash(ind(jj)) /= tmphash(ind(jj - 1))) then
tdim = tdim + Tens%Data(ind(jj))%Tens%dl(ii)
end if
end do
mld = max(mld, tdim)
end do
end if
deallocate(tmphash, ind)
end function maxlineardim_qtensorc
"""
return
[docs]def maxvalue_qtensor():
"""
fortran-function - June 2017 (dj)
Find the maximal entry in the tensor.
**Arguments**
Tens : TYPE(qtensor), in
Find maximal entry in this tensor across all subtensors.
For complex tensors, the absolute value is considered.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function maxvalue_qtensor(Tens) result(val)
type(qtensor), intent(in) :: Tens
real(KIND=rKind) :: val
! Local variables
! ---------------
! for looping
integer :: ii
! maximal value for Data(ii)
real(KIND=rKind) :: valii
val = 0.0_rKind
! Fast return
if(Tens%nb == 0) return
val = maxvalue(Tens%Data(1)%Tens)
do ii = 2, Tens%nb
valii = maxvalue(Tens%Data(ii)%Tens)
if((valii) > (val)) val = valii
end do
end function maxvalue_qtensor
"""
return
[docs]def maxvalue_qtensorc():
"""
fortran-function - June 2017 (dj)
Find the maximal entry in the tensor.
**Arguments**
Tens : TYPE(qtensorc), in
Find maximal entry in this tensor across all subtensors.
For complex tensors, the absolute value is considered.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function maxvalue_qtensorc(Tens) result(val)
type(qtensorc), intent(in) :: Tens
complex(KIND=rKind) :: val
! Local variables
! ---------------
! for looping
integer :: ii
! maximal value for Data(ii)
complex(KIND=rKind) :: valii
val = 0.0_rKind
! Fast return
if(Tens%nb == 0) return
val = maxvalue(Tens%Data(1)%Tens)
do ii = 2, Tens%nb
valii = maxvalue(Tens%Data(ii)%Tens)
if(abs(valii) > abs(val)) val = valii
end do
end function maxvalue_qtensorc
"""
return
[docs]def norm_qtensor():
"""
fortran-function - ?? (mlw)
Calculate the norm of the qtensor as <A,A>.
details (template defined in qTensors_include.f90)
**Arguments**
Qt : TYPE(qtensor), in
Get norm of the qtensor.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function norm_qtensor(Qt) result(qtnorm)
type(qtensor), intent(in) :: Qt
real(KIND=rKind) :: qtnorm
! Local variables
! ---------------
! for looping
integer :: ii
qtnorm = 0.0_rKind
do ii = 1, Qt%nb
qtnorm = qtnorm + norm(Qt%Data(ii)%Tens)
end do
end function norm_qtensor
"""
return
[docs]def norm_qtensorc():
"""
fortran-function - ?? (mlw)
Calculate the norm of the qtensorc as <A,A>.
details (template defined in qTensors_include.f90)
**Arguments**
Qt : TYPE(qtensorc), in
Get norm of the qtensorc.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function norm_qtensorc(Qt) result(qtnorm)
type(qtensorc), intent(in) :: Qt
real(KIND=rKind) :: qtnorm
! Local variables
! ---------------
! for looping
integer :: ii
qtnorm = 0.0_rKind
do ii = 1, Qt%nb
qtnorm = qtnorm + norm(Qt%Data(ii)%Tens)
end do
end function norm_qtensorc
"""
return
[docs]def permute_qnumbers_qtensor():
"""
fortran-subroutine - November 2016 (dj)
Permute the quantum numbers; necessary when permuting the legs of the
tensors.
**Arguments**
Tens : TYPE(qtensor), inout
Save a transposition/permutation on the indices of this tensor.
perm : INTEGER(\*), OPTIONAL, in
permutation array has length equal to the rank of the tensor with
unique entries 1 to rank.
Default to rank, rank - 1, ..., 2, 1 (transpose)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine permute_qnumbers_qtensor(Tens, perm, errst)
type(qtensor), intent(inout) :: Tens
integer, dimension(:), intent(in), optional :: perm
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping / indexing
integer :: ii, jj, i1, i2, j1, j2
! sum of nqs
integer :: snqs
! permutation for indices in legs
integer, dimension(:), allocatable :: perm_
! permutation for actual quantum numbers
integer, dimension(:), allocatable :: qperm
!if(present(errst)) errst = 0
allocate(perm_(Tens%Data(1)%Tens%rank))
if(present(perm)) then
perm_ = perm
else
perm_ = [(ii, ii = Tens%Data(1)%Tens%rank, 1, -1)]
end if
snqs = sum(Tens%nqs)
allocate(qperm(snqs * size(perm_)))
i1 = 1
i2 = snqs
do ii = 1, size(perm_)
j2 = perm_(ii) * snqs
j1 = j2 - snqs + 1
qperm(i1:i2) = [(jj, jj = j1, j2)]
i1 = i2 + 1
i2 = i2 + snqs
end do
do ii = 1, Tens%nb
! Permute quantum numbers
Tens%Data(ii)%qq = Tens%Data(ii)%qq(qperm)
end do
deallocate(perm_, qperm)
end subroutine permute_qnumbers_qtensor
"""
return
[docs]def permute_qnumbers_qtensorc():
"""
fortran-subroutine - November 2016 (dj)
Permute the quantum numbers; necessary when permuting the legs of the
tensors.
**Arguments**
Tens : TYPE(qtensorc), inout
Save a transposition/permutation on the indices of this tensor.
perm : INTEGER(\*), OPTIONAL, in
permutation array has length equal to the rank of the tensor with
unique entries 1 to rank.
Default to rank, rank - 1, ..., 2, 1 (transpose)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine permute_qnumbers_qtensorc(Tens, perm, errst)
type(qtensorc), intent(inout) :: Tens
integer, dimension(:), intent(in), optional :: perm
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping / indexing
integer :: ii, jj, i1, i2, j1, j2
! sum of nqs
integer :: snqs
! permutation for indices in legs
integer, dimension(:), allocatable :: perm_
! permutation for actual quantum numbers
integer, dimension(:), allocatable :: qperm
!if(present(errst)) errst = 0
allocate(perm_(Tens%Data(1)%Tens%rank))
if(present(perm)) then
perm_ = perm
else
perm_ = [(ii, ii = Tens%Data(1)%Tens%rank, 1, -1)]
end if
snqs = sum(Tens%nqs)
allocate(qperm(snqs * size(perm_)))
i1 = 1
i2 = snqs
do ii = 1, size(perm_)
j2 = perm_(ii) * snqs
j1 = j2 - snqs + 1
qperm(i1:i2) = [(jj, jj = j1, j2)]
i1 = i2 + 1
i2 = i2 + snqs
end do
do ii = 1, Tens%nb
! Permute quantum numbers
Tens%Data(ii)%qq = Tens%Data(ii)%qq(qperm)
end do
deallocate(perm_, qperm)
end subroutine permute_qnumbers_qtensorc
"""
return
[docs]def perturb_qtensor():
"""
fortran-subroutine - December 2018 (dj)
Perturb a tensor by a some small epsilon, entry-by-entry.
**Arguments**
Tens : TYPE(qtensor), inout
Tensor to be perturbed..
epsilon : real, OPTIONAL, in
Scale a randomized tensor by epsilon and add to original tensor.
Default to 1e-8
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine perturb_qtensor(Tens, epsilon, errst)
type(qtensor), intent(inout) :: Tens
real(KIND=rKind), intent(in), optional :: epsilon
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
!if(present(errst)) errst= 0
do ii = 1, Tens%nb
call perturb(Tens%Data(ii)%Tens, epsilon, errst=errst)
!if(prop_error('perturb_qtensor : perturb failed.', &
! 'qTensors_include.f90:4632', errst=errst)) return
end do
end subroutine perturb_qtensor
"""
return
[docs]def perturb_qtensorc():
"""
fortran-subroutine - December 2018 (dj)
Perturb a tensor by a some small epsilon, entry-by-entry.
**Arguments**
Tens : TYPE(qtensorc), inout
Tensor to be perturbed..
epsilon : real, OPTIONAL, in
Scale a randomized tensor by epsilon and add to original tensor.
Default to 1e-8
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine perturb_qtensorc(Tens, epsilon, errst)
type(qtensorc), intent(inout) :: Tens
real(KIND=rKind), intent(in), optional :: epsilon
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
!if(present(errst)) errst= 0
do ii = 1, Tens%nb
call perturb(Tens%Data(ii)%Tens, epsilon, errst=errst)
!if(prop_error('perturb_qtensorc : perturb failed.', &
! 'qTensors_include.f90:4632', errst=errst)) return
end do
end subroutine perturb_qtensorc
"""
return
[docs]def pointto_qtensor():
"""
fortran-subroutine - March 2018 (dj)
Copy Objb to Obja by setting the pointers and nullify Objb.
**Arguments**
Obja : TYPE(qtensor), inout
On exit, it contains the same information as Objb
Objb : TYPE(qtensor), inout
Empty on exit.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine pointto_qtensor(Obja, Objb)
type(qtensor), intent(inout) :: Obja, Objb
! No local variables
! ------------------
Obja%nb = Objb%nb
Objb%nb = -1
Obja%capacity = Objb%capacity
Obja%nqs = Objb%nqs
Obja%Data => Objb%Data
Objb%Data => null()
Obja%hash => Objb%hash
Objb%hash => null()
end subroutine pointto_qtensor
"""
return
[docs]def pointto_qtensorc():
"""
fortran-subroutine - March 2018 (dj)
Copy Objb to Obja by setting the pointers and nullify Objb.
**Arguments**
Obja : TYPE(qtensorc), inout
On exit, it contains the same information as Objb
Objb : TYPE(qtensorc), inout
Empty on exit.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine pointto_qtensorc(Obja, Objb)
type(qtensorc), intent(inout) :: Obja, Objb
! No local variables
! ------------------
Obja%nb = Objb%nb
Objb%nb = -1
Obja%capacity = Objb%capacity
Obja%nqs = Objb%nqs
Obja%Data => Objb%Data
Objb%Data => null()
Obja%hash => Objb%hash
Objb%hash => null()
end subroutine pointto_qtensorc
"""
return
[docs]def pointto_qtensorc_qtensor():
"""
fortran-subroutine - March 2018 (dj)
Copy Objb to Obja by setting the pointers and nullify Objb.
Uses copy to convert from real to complex.
**Arguments**
Obja : TYPE(qtensorc), inout
On exit, it contains the same information as Objb
Objb : TYPE(qtensor), inout
Empty on exit.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine pointto_qtensorc_qtensor(Obja, Objb)
type(qtensorc), intent(inout) :: Obja
type(qtensor), intent(inout) :: Objb
! No local variables
! ------------------
call copy(Obja, Objb)
call destroy(Objb)
end subroutine pointto_qtensorc_qtensor
"""
return
[docs]def print_qtensor():
"""
fortran-subroutine - ?? ()
Write dimension and non-zero entries to standard out (6) via
write_qtensor. (deprecated, use directly write_qtensor)
details (template defined in qTensors_include.f90)
**Arguments**
Qt : QTYPE(TENSOR_TYPE), in
Write this q-tensor to standard out (dimensions, non-zero entries)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine print_qtensor(Qt, errst)
type(qtensor), intent(in) :: Qt
integer, intent(out), optional :: errst
call write_qtensor(Qt, 6, "6", errst=errst)
!if(prop_error('print_qtensor: write failed', &
! errst=errst)) return
end subroutine print_qtensor
"""
return
[docs]def print_qtensorc():
"""
fortran-subroutine - ?? ()
Write dimension and non-zero entries to standard out (6) via
write_qtensorc. (deprecated, use directly write_qtensorc)
details (template defined in qTensors_include.f90)
**Arguments**
Qt : QTYPE(TENSOR_TYPE), in
Write this q-tensor to standard out (dimensions, non-zero entries)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine print_qtensorc(Qt, errst)
type(qtensorc), intent(in) :: Qt
integer, intent(out), optional :: errst
call write_qtensorc(Qt, 6, "6", errst=errst)
!if(prop_error('print_qtensorc: write failed', &
! errst=errst)) return
end subroutine print_qtensorc
"""
return
[docs]def project_qtensor():
"""
fortran-subroutine - March 2016 (updated dj)
Apply the projector P to Aa and store in Bb, where P is defined as
:math:`P = 1 - \sum_{\\alpha} | psiProjs_{\\alpha}> <psiProjs_{\\alpha}|`
**Arguments**
Qtb : TYPE(qtensor), out
Store projection of A in this tensor.
Qta : TYPE(qtensor), inout
Get projection of this tensor.
PsiProjs : TYPE(qtensor)(\*), inout
Array of tensors defining the projector.
**Details**
Used in orthogonalizing an MPS against another set of MPSs.
(template defined in qTensors_include.f90)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine project_qtensor(Qtb, Qta, PsiProjs, errst)
type(qtensor), intent(out) :: Qtb
type(qtensor), intent(inout) :: Qta
type(qtensor), pointer, intent(inout) :: Psiprojs(:)
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: jj
! overlap between tensors (dot product)
real(KIND=rKind) :: proj
call copy(Qtb, Qta, errst=errst)
!if(prop_error('project_qtensor: copy failed.', &
! errst=errst)) return
do jj = 1, size(PsiProjs)
proj = - dot(PsiProjs(jj), Qta)
call gaxpy(Qtb, proj, PsiProjs(jj), errst=errst)
!if(prop_error('project_qtensor: gaxpy failed.', &
! errst=errst)) return
end do
end subroutine project_qtensor
"""
return
[docs]def project_qtensorc():
"""
fortran-subroutine - March 2016 (updated dj)
Apply the projector P to Aa and store in Bb, where P is defined as
:math:`P = 1 - \sum_{\\alpha} | psiProjs_{\\alpha}> <psiProjs_{\\alpha}|`
**Arguments**
Qtb : TYPE(qtensorc), out
Store projection of A in this tensor.
Qta : TYPE(qtensorc), inout
Get projection of this tensor.
PsiProjs : TYPE(qtensorc)(\*), inout
Array of tensors defining the projector.
**Details**
Used in orthogonalizing an MPS against another set of MPSs.
(template defined in qTensors_include.f90)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine project_qtensorc(Qtb, Qta, PsiProjs, errst)
type(qtensorc), intent(out) :: Qtb
type(qtensorc), intent(inout) :: Qta
type(qtensorc), pointer, intent(inout) :: Psiprojs(:)
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: jj
! overlap between tensors (dot product)
complex(KIND=rKind) :: proj
call copy(Qtb, Qta, errst=errst)
!if(prop_error('project_qtensorc: copy failed.', &
! errst=errst)) return
do jj = 1, size(PsiProjs)
proj = - dot(PsiProjs(jj), Qta)
call gaxpy(Qtb, proj, PsiProjs(jj), errst=errst)
!if(prop_error('project_qtensorc: gaxpy failed.', &
! errst=errst)) return
end do
end subroutine project_qtensorc
"""
return
[docs]def qmattomat_qtensor():
"""
fortran-subroutine - November 2017 (dj, update)
Transform a qtensor to a tensor assuming that
all links are a local Hilbert space.
**Arguments**
Tout : TYPE(tensor), inout
Tensor without symmetry-adapted space.
Tin : TYPE(qtensor), in
Tensor in symmetry-adapted space to be written
a normal tensor.
Imapper : TYPE(imap), in
Contains the information about where each quantum
number is mapped to.
**Details**
This version works for arbitrary number of
links under the condition they are all defined in the same
local Hilbert space.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine qmattomat_qtensor(Tout, Tin, Imapper, errst)
type(tensor), intent(inout) :: Tout
type(qtensor), intent(in) :: Tin
type(imap), intent(in) :: Imapper
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! rank of the tensor
integer :: rank
! other indices
integer :: someidx, sub, tmp
! store hash
real(KIND=rKind) :: hash
! empty array costructor
integer, dimension(0) :: rankzero
! dimensions of links
integer, dimension(:), allocatable :: dl
! index in complete space
integer, dimension(:), allocatable :: ind
! actual dimension in array = degeneracy dimensions + 1
integer, dimension(:), allocatable :: dds
integer :: proddds
! size of local Hilbert space
integer :: locdim
! Unfolding index
integer, dimension(:), allocatable :: ijk
! Keeping track of indices
integer, dimension(:), allocatable :: idx
!if(present(errst)) errst = 0
if(Tin%nb == 0) then
! No statement possible
call create(Tout, rankzero, init='0')
return
end if
if(Tin%Data(1)%Tens%rank == 0) then
! True rank zero
call create(Tout, rankzero)
Tout%elem = Tin%Data(1)%Tens%elem(1)
return
end if
rank = Tin%Data(1)%Tens%rank
allocate(dl(rank), ind(rank), dds(rank), ijk(rank), idx(rank))
dl = Imapper%totald
call create(Tout, dl, init='0')
do ii = 1, Tin%nb
! Find the index for each dimension
do jj = 1, rank
hash = get_hash(Tin, [jj], ii)
do kk = 1, size(Imapper%hashes, 1)
if(abs(Imapper%hashes(kk) - hash) < 1e-12) exit
end do
ind(jj) = kk
dds(jj) = Imapper%dd(kk) + 1
end do
! We have to keep track of three (sets of) indices
!
! 1) ijk keeps track of the indices in the subtensor
! for all indices
! 2) jj keeps track of the index accessing the correct
! element in the subtensor (in the linear memory)
! The loop is governed by jj. ijk is incremented
! at the end.
! 3) someidx keeps track of the index in linear memory
! in the target array.
locdim = sum(Imapper%dd + 1)
proddds = product(dds)
ijk = 1
do jj = 1, proddds
someidx = Imapper%start(ind(1)) - 1 + ijk(1)
tmp = locdim
do kk = 2, rank
sub = Imapper%start(ind(kk)) - 1 + ijk(kk)
someidx = someidx + (sub - 1) * tmp
tmp = tmp * locdim
end do
Tout%elem(someidx) = Tout%elem(someidx) &
+ Tin%Data(ii)%Tens%elem(jj)
idx(1) = idx(1) + 1
do kk = 1, rank - 1
if(idx(kk) > dds(kk)) then
idx(kk + 1) = idx(kk + 1) + 1
idx(kk) = 1
else
exit
end if
end do
end do
end do
deallocate(dl, ind, dds, ijk, idx)
end subroutine qmattomat_qtensor
"""
return
[docs]def qmattomat_qtensorc():
"""
fortran-subroutine - November 2017 (dj, update)
Transform a qtensorc to a tensorc assuming that
all links are a local Hilbert space.
**Arguments**
Tout : TYPE(tensorc), inout
Tensor without symmetry-adapted space.
Tin : TYPE(qtensorc), in
Tensor in symmetry-adapted space to be written
a normal tensor.
Imapper : TYPE(imap), in
Contains the information about where each quantum
number is mapped to.
**Details**
This version works for arbitrary number of
links under the condition they are all defined in the same
local Hilbert space.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine qmattomat_qtensorc(Tout, Tin, Imapper, errst)
type(tensorc), intent(inout) :: Tout
type(qtensorc), intent(in) :: Tin
type(imap), intent(in) :: Imapper
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! rank of the tensor
integer :: rank
! other indices
integer :: someidx, sub, tmp
! store hash
real(KIND=rKind) :: hash
! empty array costructor
integer, dimension(0) :: rankzero
! dimensions of links
integer, dimension(:), allocatable :: dl
! index in complete space
integer, dimension(:), allocatable :: ind
! actual dimension in array = degeneracy dimensions + 1
integer, dimension(:), allocatable :: dds
integer :: proddds
! size of local Hilbert space
integer :: locdim
! Unfolding index
integer, dimension(:), allocatable :: ijk
! Keeping track of indices
integer, dimension(:), allocatable :: idx
!if(present(errst)) errst = 0
if(Tin%nb == 0) then
! No statement possible
call create(Tout, rankzero, init='0')
return
end if
if(Tin%Data(1)%Tens%rank == 0) then
! True rank zero
call create(Tout, rankzero)
Tout%elem = Tin%Data(1)%Tens%elem(1)
return
end if
rank = Tin%Data(1)%Tens%rank
allocate(dl(rank), ind(rank), dds(rank), ijk(rank), idx(rank))
dl = Imapper%totald
call create(Tout, dl, init='0')
do ii = 1, Tin%nb
! Find the index for each dimension
do jj = 1, rank
hash = get_hash(Tin, [jj], ii)
do kk = 1, size(Imapper%hashes, 1)
if(abs(Imapper%hashes(kk) - hash) < 1e-12) exit
end do
ind(jj) = kk
dds(jj) = Imapper%dd(kk) + 1
end do
! We have to keep track of three (sets of) indices
!
! 1) ijk keeps track of the indices in the subtensor
! for all indices
! 2) jj keeps track of the index accessing the correct
! element in the subtensor (in the linear memory)
! The loop is governed by jj. ijk is incremented
! at the end.
! 3) someidx keeps track of the index in linear memory
! in the target array.
locdim = sum(Imapper%dd + 1)
proddds = product(dds)
ijk = 1
do jj = 1, proddds
someidx = Imapper%start(ind(1)) - 1 + ijk(1)
tmp = locdim
do kk = 2, rank
sub = Imapper%start(ind(kk)) - 1 + ijk(kk)
someidx = someidx + (sub - 1) * tmp
tmp = tmp * locdim
end do
Tout%elem(someidx) = Tout%elem(someidx) &
+ Tin%Data(ii)%Tens%elem(jj)
idx(1) = idx(1) + 1
do kk = 1, rank - 1
if(idx(kk) > dds(kk)) then
idx(kk + 1) = idx(kk + 1) + 1
idx(kk) = 1
else
exit
end if
end do
end do
end do
deallocate(dl, ind, dds, ijk, idx)
end subroutine qmattomat_qtensorc
"""
return
[docs]def randomize_qtensor():
"""
fortran-subroutine - Randomize the nonempty data elements (not the qs!) of Qt.
details (template defined in qTensors_include.f90)
March 2016 (updated dj)
**Arguments**
Qt : TYPE(qtensor), inout
Randomize entries between [-1, 1] (real array) or [-1-i, 1+i]
(complex arrays). This is done for each data element allocated
beforehand.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine randomize_qtensor(Qt, errst)
type(qtensor), intent(inout) :: Qt
integer, intent(out), optional :: errst
! Local Variables
! ---------------
! for looping
integer :: ii
do ii = 1, Qt%nb
call randomize(Qt%Data(ii)%Tens, errst=errst)
!if(prop_error('randomize_qtensor: failed.', &
! errst=errst)) return
end do
end subroutine randomize_qtensor
"""
return
[docs]def randomize_qtensorc():
"""
fortran-subroutine - Randomize the nonempty data elements (not the qs!) of Qt.
details (template defined in qTensors_include.f90)
March 2016 (updated dj)
**Arguments**
Qt : TYPE(qtensorc), inout
Randomize entries between [-1, 1] (real array) or [-1-i, 1+i]
(complex arrays). This is done for each data element allocated
beforehand.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine randomize_qtensorc(Qt, errst)
type(qtensorc), intent(inout) :: Qt
integer, intent(out), optional :: errst
! Local Variables
! ---------------
! for looping
integer :: ii
do ii = 1, Qt%nb
call randomize(Qt%Data(ii)%Tens, errst=errst)
!if(prop_error('randomize_qtensorc: failed.', &
! errst=errst)) return
end do
end subroutine randomize_qtensorc
"""
return
[docs]def rank_qtensor():
"""
fortran-function - June 2017 (dj)
Return the rank of a tensor.
**Arguments**
Tens : TYPE(TENSOR_TYPE), in
Return the rank of the tensor. If the tensor has no blocks
rank -1 is returned. (Rank 0 would correspond to a scalar.)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function rank_qtensor(Qt) result(myrank)
type(qtensor), intent(in) :: Qt
integer :: myrank
if(Qt%nb > 0) then
myrank = Qt%Data(1)%Tens%rank
else
myrank = -1
end if
end function rank_qtensor
"""
return
[docs]def rank_qtensorc():
"""
fortran-function - June 2017 (dj)
Return the rank of a tensor.
**Arguments**
Tens : TYPE(TENSOR_TYPE), in
Return the rank of the tensor. If the tensor has no blocks
rank -1 is returned. (Rank 0 would correspond to a scalar.)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function rank_qtensorc(Qt) result(myrank)
type(qtensorc), intent(in) :: Qt
integer :: myrank
if(Qt%nb > 0) then
myrank = Qt%Data(1)%Tens%rank
else
myrank = -1
end if
end function rank_qtensorc
"""
return
[docs]def read_qtensor():
"""
fortran-subroutine - August 2015 (dj)
Read a q-tensor from a given unit.
**Arguments**
Qtens : TYPE(qtensor), out
will be read from given destination.
unit : INTEGER, in
read from this unit
form : CHARACTER, in
'H' (human readable), 'B' (binary).
**Details**
For details of the expected input read `write_qtensor` for
the corresponding form. (template defined in qTensors_include.f90)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine read_qtensor(Qtens, unit, form)
type(qtensor), intent(out) :: Qtens
integer, intent(in) :: unit
character, intent(in) :: form
! Local variables
! ---------------
! for looping
integer :: ii
! size of the array storing the quantum numbers
integer :: nq
if(form == "6") then
stop "read_qtensor: form=6 not enabled for reading!"
elseif(form == 'H') then
! Write the numer of blocks (used blocks)
read(unit, *) Qtens%nb, Qtens%nqs
Qtens%capacity = Qtens%nb
allocate(Qtens%data(Qtens%nb), Qtens%hash(Qtens%nb))
do ii = 1, Qtens%nb
! Write the hash of the current block and the size of the quantum
! number array
read(unit, *) Qtens%hash(ii), nq
allocate(Qtens%Data(ii)%qq(nq))
! Write the quantum numbers
read(unit, *) Qtens%Data(ii)%qq
! Write the corresponding tensor
call read(Qtens%Data(ii)%Tens, unit, form)
end do
elseif(form == 'B') then
! Write the number of blocks (used blocks)
read(unit) Qtens%nb, Qtens%nqs
Qtens%capacity = Qtens%nb
allocate(Qtens%Data(Qtens%nb), Qtens%hash(Qtens%nb))
do ii = 1, Qtens%nb
! Write the hash of the current block and the size of the quantum
! number array
read(unit) Qtens%hash(ii), nq
allocate(Qtens%data(ii)%qq(nq))
! Write the quantum numbers
read(unit) Qtens%Data(ii)%qq
! Write the corresponding tensor
call read(Qtens%Data(ii)%Tens, unit, form)
end do
else
stop "write_qtensor: bad formatting option."
end if
end subroutine read_qtensor
"""
return
[docs]def read_qtensorc():
"""
fortran-subroutine - August 2015 (dj)
Read a q-tensor from a given unit.
**Arguments**
Qtens : TYPE(qtensorc), out
will be read from given destination.
unit : INTEGER, in
read from this unit
form : CHARACTER, in
'H' (human readable), 'B' (binary).
**Details**
For details of the expected input read `write_qtensorc` for
the corresponding form. (template defined in qTensors_include.f90)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine read_qtensorc(Qtens, unit, form)
type(qtensorc), intent(out) :: Qtens
integer, intent(in) :: unit
character, intent(in) :: form
! Local variables
! ---------------
! for looping
integer :: ii
! size of the array storing the quantum numbers
integer :: nq
if(form == "6") then
stop "read_qtensorc: form=6 not enabled for reading!"
elseif(form == 'H') then
! Write the numer of blocks (used blocks)
read(unit, *) Qtens%nb, Qtens%nqs
Qtens%capacity = Qtens%nb
allocate(Qtens%data(Qtens%nb), Qtens%hash(Qtens%nb))
do ii = 1, Qtens%nb
! Write the hash of the current block and the size of the quantum
! number array
read(unit, *) Qtens%hash(ii), nq
allocate(Qtens%Data(ii)%qq(nq))
! Write the quantum numbers
read(unit, *) Qtens%Data(ii)%qq
! Write the corresponding tensor
call read(Qtens%Data(ii)%Tens, unit, form)
end do
elseif(form == 'B') then
! Write the number of blocks (used blocks)
read(unit) Qtens%nb, Qtens%nqs
Qtens%capacity = Qtens%nb
allocate(Qtens%Data(Qtens%nb), Qtens%hash(Qtens%nb))
do ii = 1, Qtens%nb
! Write the hash of the current block and the size of the quantum
! number array
read(unit) Qtens%hash(ii), nq
allocate(Qtens%data(ii)%qq(nq))
! Write the quantum numbers
read(unit) Qtens%Data(ii)%qq
! Write the corresponding tensor
call read(Qtens%Data(ii)%Tens, unit, form)
end do
else
stop "write_qtensorc: bad formatting option."
end if
end subroutine read_qtensorc
"""
return
[docs]def scale_qtensor_real():
"""
fortran-subroutine - ?? (mlw)
Scale qtensor by real
details (template defined in qTensors_include.f90)
**Arguments**
sc : real, in
Scalar to be multiplied with vector.
Qt : TYPE(qtensor), inout
To be scaled with scalar.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine scale_qtensor_real(sc, Qt, errst)
real(KIND=rKind), intent(in) :: sc
type(qtensor), intent(inout) :: Qt
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
!if(present(errst)) errst = 0
do ii = 1, Qt%nb
call scale(sc, Qt%Data(ii)%Tens, errst=errst)
!if(prop_error('scale_qtensor_real: failed', &
! errst=errst)) return
end do
end subroutine scale_qtensor_real
"""
return
[docs]def scale_qtensorc_complex():
"""
fortran-subroutine - ?? (mlw)
Scale qtensorc by complex
details (template defined in qTensors_include.f90)
**Arguments**
sc : complex, in
Scalar to be multiplied with vector.
Qt : TYPE(qtensorc), inout
To be scaled with scalar.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine scale_qtensorc_complex(sc, Qt, errst)
complex(KIND=rKind), intent(in) :: sc
type(qtensorc), intent(inout) :: Qt
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
!if(present(errst)) errst = 0
do ii = 1, Qt%nb
call scale(sc, Qt%Data(ii)%Tens, errst=errst)
!if(prop_error('scale_qtensorc_complex: failed', &
! errst=errst)) return
end do
end subroutine scale_qtensorc_complex
"""
return
[docs]def scale_qtensorc_real():
"""
fortran-subroutine - ?? (mlw)
Scale qtensorc by real
details (template defined in qTensors_include.f90)
**Arguments**
sc : real, in
Scalar to be multiplied with vector.
Qt : TYPE(qtensorc), inout
To be scaled with scalar.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine scale_qtensorc_real(sc, Qt, errst)
real(KIND=rKind), intent(in) :: sc
type(qtensorc), intent(inout) :: Qt
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
!if(present(errst)) errst = 0
do ii = 1, Qt%nb
call scale(sc, Qt%Data(ii)%Tens, errst=errst)
!if(prop_error('scale_qtensorc_real: failed', &
! errst=errst)) return
end do
end subroutine scale_qtensorc_real
"""
return
[docs]def set_hash_qtensor():
"""
fortran-subroutine - October 2016 (dj)
Set the hashes of specified indices of the qtensor in its
internal structure.
**Arguments**
Qtens : TYPE(qtensor), inout
The values of the hashes are set according to the new
indices.
idxs : INTEGER(\*), in
Specify indices to be hashed in regard to the legs of the tensor.
ii : INTEGER, OPTIONAL, in
Specify index in terms of array of tensors for generating new hash.
If not present, all tensors are set again.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine set_hash_qtensor(Qtens, idxs, ii, errst)
type(qtensor), intent(inout) :: Qtens
integer, intent(in) :: idxs(:)
integer, intent(in), optional :: ii
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: jj
!if(present(errst)) errst = 0
if(present(ii)) then
Qtens%hash(ii) = prime_hash(Qtens%Data(ii)%qq, idxs, Qtens%nqs)
else
do jj = 1, Qtens%nb
Qtens%hash(jj) = prime_hash(Qtens%Data(jj)%qq, idxs, Qtens%nqs)
end do
end if
end subroutine set_hash_qtensor
"""
return
[docs]def set_hash_qtensorc():
"""
fortran-subroutine - October 2016 (dj)
Set the hashes of specified indices of the qtensorc in its
internal structure.
**Arguments**
Qtens : TYPE(qtensorc), inout
The values of the hashes are set according to the new
indices.
idxs : INTEGER(\*), in
Specify indices to be hashed in regard to the legs of the tensor.
ii : INTEGER, OPTIONAL, in
Specify index in terms of array of tensors for generating new hash.
If not present, all tensors are set again.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine set_hash_qtensorc(Qtens, idxs, ii, errst)
type(qtensorc), intent(inout) :: Qtens
integer, intent(in) :: idxs(:)
integer, intent(in), optional :: ii
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: jj
!if(present(errst)) errst = 0
if(present(ii)) then
Qtens%hash(ii) = prime_hash(Qtens%Data(ii)%qq, idxs, Qtens%nqs)
else
do jj = 1, Qtens%nb
Qtens%hash(jj) = prime_hash(Qtens%Data(jj)%qq, idxs, Qtens%nqs)
end do
end if
end subroutine set_hash_qtensorc
"""
return
[docs]def size_qtensor():
"""
fortran-function - ?? ()
Overload the SIZE() function to return the number of used values rather
than the capacity.
details (template defined in qTensors_include.f90)
**Arguments**
Qt : QTYPE(TENSOR_TYPE), in
Get number of used blocks in the qtensor.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function size_qtensor(Qt) result(siz)
type(qtensor) :: Qt
integer :: siz
siz = Qt%nb
end function size_qtensor
"""
return
[docs]def size_qtensorc():
"""
fortran-function - ?? ()
Overload the SIZE() function to return the number of used values rather
than the capacity.
details (template defined in qTensors_include.f90)
**Arguments**
Qt : QTYPE(TENSOR_TYPE), in
Get number of used blocks in the qtensorc.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function size_qtensorc(Qt) result(siz)
type(qtensorc) :: Qt
integer :: siz
siz = Qt%nb
end function size_qtensorc
"""
return
[docs]def Skim_qtensor():
"""
fortran-subroutine - ?? (mlw)
Remove all irreps which contribute less than err of the relative norm.
details (template defined in qTensors_include.f90)
**Arguments**
Qt : TYPE(qtensor), inout
Eliminate all blocks which do not contribute more than a fraction err
to the norm.
err : REAL, in
Criteria for each block; contribution to complete norm must be
greater than the fraction err.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine Skim_qtensor(Qt, err, errst)
type(qtensor), intent(inout) :: Qt
real(KIND=rKind), intent(in) :: err
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! Norms
real(KIND=rKind) :: total_nrm, new_nrm
real(KIND=rKind), dimension(:), allocatable :: nrm_ii
! number of deleted and number of kept blocks
integer :: nmarked, nunmarked
! indices of kept blocks
integer, allocatable :: unmarked(:)
! temporary arrays for copying
type(internal_qtensor), dimension(:), pointer :: Tmpdata
real(KIND=rKind), dimension(:), pointer :: tmphash
!if(present(errst)) errst = 0
! Array to store blocks to be kept
allocate(unmarked(Qt%nb), nrm_ii(Qt%nb))
nmarked = 0
nunmarked = 0
do ii = 1, Qt%nb
nrm_ii(ii) = norm(Qt%Data(ii)%Tens)
end do
! Total norm
total_nrm = sum(nrm_ii)
! Get fractions for all
nrm_ii = nrm_ii / total_nrm
! New total norm
new_nrm = 0.0_rKind
do ii = 1, Qt%nb
if(nrm_ii(ii) >= err) then
! norm is appreciable --> don't mark for deletion
nunmarked = nunmarked + 1
unmarked(nunmarked) = ii
new_nrm = new_nrm + nrm_ii(ii)
else
nmarked = nmarked + 1
!call destroy(Qt%Data(ii)%Tens)
!deallocate(Qt%Data(ii)%qq)
end if
end do
if(nunmarked < Qt%nb) then
! Remove entries
call skim(Qt, nunmarked, unmarked, errst=errst)
!if(prop_error('skim_qtensor : skim_idx failed.', &
! errst=errst)) return
! Scale with square root of total_norm / new_nrm
call scale(sqrt(total_nrm / new_nrm), Qt)
end if
end subroutine skim_qtensor
"""
return
[docs]def Skim_qtensorc():
"""
fortran-subroutine - ?? (mlw)
Remove all irreps which contribute less than err of the relative norm.
details (template defined in qTensors_include.f90)
**Arguments**
Qt : TYPE(qtensorc), inout
Eliminate all blocks which do not contribute more than a fraction err
to the norm.
err : REAL, in
Criteria for each block; contribution to complete norm must be
greater than the fraction err.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine Skim_qtensorc(Qt, err, errst)
type(qtensorc), intent(inout) :: Qt
real(KIND=rKind), intent(in) :: err
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! Norms
real(KIND=rKind) :: total_nrm, new_nrm
real(KIND=rKind), dimension(:), allocatable :: nrm_ii
! number of deleted and number of kept blocks
integer :: nmarked, nunmarked
! indices of kept blocks
integer, allocatable :: unmarked(:)
! temporary arrays for copying
type(internal_qtensorc), dimension(:), pointer :: Tmpdata
real(KIND=rKind), dimension(:), pointer :: tmphash
!if(present(errst)) errst = 0
! Array to store blocks to be kept
allocate(unmarked(Qt%nb), nrm_ii(Qt%nb))
nmarked = 0
nunmarked = 0
do ii = 1, Qt%nb
nrm_ii(ii) = norm(Qt%Data(ii)%Tens)
end do
! Total norm
total_nrm = sum(nrm_ii)
! Get fractions for all
nrm_ii = nrm_ii / total_nrm
! New total norm
new_nrm = 0.0_rKind
do ii = 1, Qt%nb
if(nrm_ii(ii) >= err) then
! norm is appreciable --> don't mark for deletion
nunmarked = nunmarked + 1
unmarked(nunmarked) = ii
new_nrm = new_nrm + nrm_ii(ii)
else
nmarked = nmarked + 1
!call destroy(Qt%Data(ii)%Tens)
!deallocate(Qt%Data(ii)%qq)
end if
end do
if(nunmarked < Qt%nb) then
! Remove entries
call skim(Qt, nunmarked, unmarked, errst=errst)
!if(prop_error('skim_qtensorc : skim_idx failed.', &
! errst=errst)) return
! Scale with square root of total_norm / new_nrm
call scale(sqrt(total_nrm / new_nrm), Qt)
end if
end subroutine skim_qtensorc
"""
return
[docs]def skim_idx_qtensor():
"""
fortran-subroutine - January 2017 (dj)
Remove all irreps which are not marked by the user.
details (template defined in qTensors_include.f90)
**Arguments**
Qt : TYPE(qtensor), inout
Eliminate all blocks which are not marked by the user.
nkeep : INTEGER, in
Number of irreps kept.
idxkeep : INTEGER(\*), in
The indices of the irreps to be kept.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine skim_idx_qtensor(Qt, nkeep, idxkeep, errst)
type(qtensor), intent(inout) :: Qt
integer, intent(in) :: nkeep
integer, dimension(Qt%nb), intent(in) :: idxkeep
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! temporary arrays for copying
type(internal_qtensor), dimension(:), allocatable :: Tmpdata
!if(present(errst)) errst = 0
! Quick return
if(Qt%nb == nkeep) return
! Map elements
allocate(Tmpdata(nkeep))
! Copy internal data
do ii = 1, nkeep
call copy(Tmpdata(ii)%Tens, Qt%Data(idxkeep(ii))%Tens)
allocate(Tmpdata(ii)%qq(size(Qt%Data(idxkeep(ii))%qq)))
Tmpdata(ii)%qq = Qt%Data(idxkeep(ii))%qq
end do
! Copy hashes
Qt%hash(:nkeep) = Qt%hash(idxkeep(:nkeep))
! Deallocate all elements
do ii = 1, Qt%nb
call destroy(Qt%Data(ii)%Tens)
deallocate(Qt%Data(ii)%qq)
end do
! Copy into elements 1, ..., nkeep
do ii = 1, nkeep
call copy(Qt%Data(ii)%Tens, Tmpdata(ii)%Tens)
allocate(Qt%Data(ii)%qq(size(Tmpdata(ii)%qq)))
Qt%Data(ii)%qq = Tmpdata(ii)%qq
call destroy(Tmpdata(ii)%Tens)
deallocate(Tmpdata(ii)%qq)
end do
Qt%nb = nkeep
deallocate(Tmpdata)
end subroutine skim_idx_qtensor
"""
return
[docs]def skim_idx_qtensorc():
"""
fortran-subroutine - January 2017 (dj)
Remove all irreps which are not marked by the user.
details (template defined in qTensors_include.f90)
**Arguments**
Qt : TYPE(qtensorc), inout
Eliminate all blocks which are not marked by the user.
nkeep : INTEGER, in
Number of irreps kept.
idxkeep : INTEGER(\*), in
The indices of the irreps to be kept.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine skim_idx_qtensorc(Qt, nkeep, idxkeep, errst)
type(qtensorc), intent(inout) :: Qt
integer, intent(in) :: nkeep
integer, dimension(Qt%nb), intent(in) :: idxkeep
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! temporary arrays for copying
type(internal_qtensorc), dimension(:), allocatable :: Tmpdata
!if(present(errst)) errst = 0
! Quick return
if(Qt%nb == nkeep) return
! Map elements
allocate(Tmpdata(nkeep))
! Copy internal data
do ii = 1, nkeep
call copy(Tmpdata(ii)%Tens, Qt%Data(idxkeep(ii))%Tens)
allocate(Tmpdata(ii)%qq(size(Qt%Data(idxkeep(ii))%qq)))
Tmpdata(ii)%qq = Qt%Data(idxkeep(ii))%qq
end do
! Copy hashes
Qt%hash(:nkeep) = Qt%hash(idxkeep(:nkeep))
! Deallocate all elements
do ii = 1, Qt%nb
call destroy(Qt%Data(ii)%Tens)
deallocate(Qt%Data(ii)%qq)
end do
! Copy into elements 1, ..., nkeep
do ii = 1, nkeep
call copy(Qt%Data(ii)%Tens, Tmpdata(ii)%Tens)
allocate(Qt%Data(ii)%qq(size(Tmpdata(ii)%qq)))
Qt%Data(ii)%qq = Tmpdata(ii)%qq
call destroy(Tmpdata(ii)%Tens)
deallocate(Tmpdata(ii)%qq)
end do
Qt%nb = nkeep
deallocate(Tmpdata)
end subroutine skim_idx_qtensorc
"""
return
[docs]def sort_qtensor():
"""
fortran-subroutine - ?? (mlw)
Sort a qtensor in ascending order of its current hashes.
details (template defined in qTensors_include.f90)
**Arguments**
Qt : TYPE(qtensor), inout
The order of blocks will be changed according to the present hashes.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine sort_qtensor(Qt, errst)
type(qtensor), intent(inout) :: Qt
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! temporary copy of tensor
type(qtensor) :: Qtmp
! array for sorting
integer, allocatable :: ind(:)
!if(present(errst)) errst = 0
call create(Qtmp, Qt%nqs, Qt%capacity)
Qtmp%nb = Qt%nb
allocate(ind(Qt%nb))
call ascending_hsort(Qt%hash(1:Qt%nb), ind)
do ii = 1, Qt%nb
call copy(Qtmp%Data(ii)%Tens, Qt%Data(ind(ii))%Tens)
allocate(Qtmp%Data(ii)%qq(size(Qt%Data(ind(ii))%qq)))
Qtmp%Data(ii)%qq = Qt%Data(ind(ii))%qq
Qtmp%hash(ii) = Qt%hash(ind(ii))
end do
call destroy(Qt)
call pointto(Qt, Qtmp)
!call copy(Qt, Qtmp)
!call destroy(Qtmp)
deallocate(ind)
end subroutine sort_qtensor
"""
return
[docs]def sort_qtensorc():
"""
fortran-subroutine - ?? (mlw)
Sort a qtensor in ascending order of its current hashes.
details (template defined in qTensors_include.f90)
**Arguments**
Qt : TYPE(qtensorc), inout
The order of blocks will be changed according to the present hashes.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine sort_qtensorc(Qt, errst)
type(qtensorc), intent(inout) :: Qt
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! temporary copy of tensor
type(qtensorc) :: Qtmp
! array for sorting
integer, allocatable :: ind(:)
!if(present(errst)) errst = 0
call create(Qtmp, Qt%nqs, Qt%capacity)
Qtmp%nb = Qt%nb
allocate(ind(Qt%nb))
call ascending_hsort(Qt%hash(1:Qt%nb), ind)
do ii = 1, Qt%nb
call copy(Qtmp%Data(ii)%Tens, Qt%Data(ind(ii))%Tens)
allocate(Qtmp%Data(ii)%qq(size(Qt%Data(ind(ii))%qq)))
Qtmp%Data(ii)%qq = Qt%Data(ind(ii))%qq
Qtmp%hash(ii) = Qt%hash(ind(ii))
end do
call destroy(Qt)
call pointto(Qt, Qtmp)
!call copy(Qt, Qtmp)
!call destroy(Qtmp)
deallocate(ind)
end subroutine sort_qtensorc
"""
return
[docs]def split_qtensor():
"""
fortran-subroutine - October 2017 (dj)
Split a single link of the tensor into a set of links. Symmetries are split
and filled with zeros.
**Arguments**
Qt : TYPE(qtensor), inout
Split one link in this tensor.
idx : INTEGER, in
Index of the link to be splitted.
Sl : TYPE(splitlink), in
Contains the information how to split the links into
new dimensions.
**Details**
This case is kind of artificial. If we split a single link
tensor with two abelian and two discrete quantum numbers [1, 2, 3, 4]
into two links, the new links should have the quantum numbers
[1, 0, 3, 0] and [2, 0, 4, 0]. That allows the contraction of the two
links with other links splitted the same way. (One possible work around
is to allow different quantum numbers for each link, so they need an
array for each link.)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine split_qtensor(Qt, idx, Sl, errst)
type(qtensor), intent(inout) :: Qt
integer, intent(in) :: idx
type(splitlink), intent(in) :: Sl
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj
! matching index
integer :: match
! indexing in quantum number arrays
integer :: x1, x2, y1, y2
! total number of conserved quantities
integer :: snqs
! new / old rank of the tensor
integer :: new_rank, old_rank
! reduced nqs
integer, dimension(2) :: red_nqs
! temporary array for quantum numbers
integer, dimension(:), allocatable :: qq
! hash for current tensor
real(KIND=rKind) :: hashjj
!if(present(errst)) errst = 0
! Quick return for no blocks
if(Qt%nb == 0) return
old_rank = rank(Qt)
new_rank = old_rank - 1 + size(Sl%dims, 1)
snqs = sum(Qt%nqs)
allocate(qq(snqs * new_rank))
red_nqs = Qt%nqs / size(Sl%dims, 1)
do ii = 1, Qt%nb
! Split the subtensor
! -------------------
hashjj = get_hash(Qt, [idx], ii)
match = findtagindex(hashjj, Sl%hashes)
if(match < 0) then
! Have to raise error
errst = raise_error('split_qtensor: index not '//&
'found.', 99, 'qTensors_include.f90:5661', &
errst=errst)
return
end if
call split(Qt%Data(ii)%Tens, idx, Sl, sidx=match, errst=errst)
!if(prop_error('split_qtensor : split failed.', &
! 'qTensors_include.f90:5668', errst=errst)) return
! Split the quantum numbers
! -------------------------
qq = 0
! Copy block at the front
if(idx > 1) then
! indices of old and new array
x1 = 1
x2 = snqs * (idx - 1)
qq(x1:x2) = Qt%Data(ii)%qq(x1:x2)
end if
! Copy block of the link splitted
do jj = 1, size(Sl%dims, 1)
! Index of new array (Abelian)
x1 = snqs * ((idx - 1) + (jj - 1)) + 1
x2 = x1 + red_nqs(1) - 1
! Index of old array (Abelian)
y1 = snqs * (idx - 1) + (jj - 1) * red_nqs(1) + 1
y2 = y1 + red_nqs(1) - 1
! Copy abelian
qq(x1:x2) = Qt%Data(ii)%qq(y1:y2)
! Index of new array (Discrete)
x1 = snqs * ((idx -1) + (jj - 1)) + Qt%nqs(1) + 1
x2 = x1 + red_nqs(2) - 1
! Index of old array (Discrete)
y1 = snqs * (idx - 1) + Qt%nqs(1) + (jj - 1) * red_nqs(2) + 1
y2 = y1 + red_nqs(2) - 1
! Copy discrete
qq(x1:x2) = Qt%Data(ii)%qq(y1:y2)
end do
! Copy block at the end
if(idx < old_rank) then
! index of new array
x2 = snqs * new_rank
x1 = x2 - (old_rank - idx) * snqs + 1
! index of old array
y2 = snqs * old_rank
y1 = y2 - (old_rank - idx) * snqs + 1
qq(x1:x2) = Qt%Data(ii)%qq(y1:y2)
end if
deallocate(Qt%Data(ii)%qq)
allocate(Qt%Data(ii)%qq(new_rank * snqs))
Qt%Data(ii)%qq = qq
end do
deallocate(qq)
end subroutine split_qtensor
"""
return
[docs]def split_qtensorc():
"""
fortran-subroutine - October 2017 (dj)
Split a single link of the tensor into a set of links. Symmetries are split
and filled with zeros.
**Arguments**
Qt : TYPE(qtensorc), inout
Split one link in this tensor.
idx : INTEGER, in
Index of the link to be splitted.
Sl : TYPE(splitlink), in
Contains the information how to split the links into
new dimensions.
**Details**
This case is kind of artificial. If we split a single link
tensor with two abelian and two discrete quantum numbers [1, 2, 3, 4]
into two links, the new links should have the quantum numbers
[1, 0, 3, 0] and [2, 0, 4, 0]. That allows the contraction of the two
links with other links splitted the same way. (One possible work around
is to allow different quantum numbers for each link, so they need an
array for each link.)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine split_qtensorc(Qt, idx, Sl, errst)
type(qtensorc), intent(inout) :: Qt
integer, intent(in) :: idx
type(splitlink), intent(in) :: Sl
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj
! matching index
integer :: match
! indexing in quantum number arrays
integer :: x1, x2, y1, y2
! total number of conserved quantities
integer :: snqs
! new / old rank of the tensor
integer :: new_rank, old_rank
! reduced nqs
integer, dimension(2) :: red_nqs
! temporary array for quantum numbers
integer, dimension(:), allocatable :: qq
! hash for current tensor
real(KIND=rKind) :: hashjj
!if(present(errst)) errst = 0
! Quick return for no blocks
if(Qt%nb == 0) return
old_rank = rank(Qt)
new_rank = old_rank - 1 + size(Sl%dims, 1)
snqs = sum(Qt%nqs)
allocate(qq(snqs * new_rank))
red_nqs = Qt%nqs / size(Sl%dims, 1)
do ii = 1, Qt%nb
! Split the subtensor
! -------------------
hashjj = get_hash(Qt, [idx], ii)
match = findtagindex(hashjj, Sl%hashes)
if(match < 0) then
! Have to raise error
errst = raise_error('split_qtensorc: index not '//&
'found.', 99, 'qTensors_include.f90:5661', &
errst=errst)
return
end if
call split(Qt%Data(ii)%Tens, idx, Sl, sidx=match, errst=errst)
!if(prop_error('split_qtensorc : split failed.', &
! 'qTensors_include.f90:5668', errst=errst)) return
! Split the quantum numbers
! -------------------------
qq = 0
! Copy block at the front
if(idx > 1) then
! indices of old and new array
x1 = 1
x2 = snqs * (idx - 1)
qq(x1:x2) = Qt%Data(ii)%qq(x1:x2)
end if
! Copy block of the link splitted
do jj = 1, size(Sl%dims, 1)
! Index of new array (Abelian)
x1 = snqs * ((idx - 1) + (jj - 1)) + 1
x2 = x1 + red_nqs(1) - 1
! Index of old array (Abelian)
y1 = snqs * (idx - 1) + (jj - 1) * red_nqs(1) + 1
y2 = y1 + red_nqs(1) - 1
! Copy abelian
qq(x1:x2) = Qt%Data(ii)%qq(y1:y2)
! Index of new array (Discrete)
x1 = snqs * ((idx -1) + (jj - 1)) + Qt%nqs(1) + 1
x2 = x1 + red_nqs(2) - 1
! Index of old array (Discrete)
y1 = snqs * (idx - 1) + Qt%nqs(1) + (jj - 1) * red_nqs(2) + 1
y2 = y1 + red_nqs(2) - 1
! Copy discrete
qq(x1:x2) = Qt%Data(ii)%qq(y1:y2)
end do
! Copy block at the end
if(idx < old_rank) then
! index of new array
x2 = snqs * new_rank
x1 = x2 - (old_rank - idx) * snqs + 1
! index of old array
y2 = snqs * old_rank
y1 = y2 - (old_rank - idx) * snqs + 1
qq(x1:x2) = Qt%Data(ii)%qq(y1:y2)
end if
deallocate(Qt%Data(ii)%qq)
allocate(Qt%Data(ii)%qq(new_rank * snqs))
Qt%Data(ii)%qq = qq
end do
deallocate(qq)
end subroutine split_qtensorc
"""
return
[docs]def split_all_qtensor():
"""
fortran-subroutine - October 2017 (dj)
Splitting all links of the tensor into subsets. This steps allows us to
reduce the number of conserved quantities as well.
**Arguments**
Qt : TYPE(qtensor), inout
Split all links of this tensor.
Sls : TYPE(splitlink)(\*), in
Information how to split each link in the current tensor.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine split_all_qtensor(Qt, Sls, errst)
type(qtensor), intent(inout) :: Qt
type(splitlink), dimension(:), intent(in) :: Sls
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk, xx
! indexing the quantum number arrays
integer :: x1, x2, y1, y2
! index for each splitlink object
integer, dimension(:), allocatable :: sidx
! matching index
integer :: idx
! rank of incoming tensor
integer :: old_rank
! hash
real(KIND=rKind) :: hashjj
! number of conserved quantities
integer :: snqs, new_snqs
! copy of the quantum numbers
integer, dimension(:), allocatable :: qq
! new number of quantum numbers
integer, dimension(2) :: new_nqs
!if(present(errst)) errst = 0
! Quick return (empty qtensor)
if(Qt%nb == 0) return
allocate(sidx(rank(Qt)))
old_rank = rank(Qt)
snqs = sum(Qt%nqs)
allocate(qq(old_rank * snqs))
new_nqs = Qt%nqs / size(Sls(1)%dims, 1)
new_snqs = sum(new_nqs)
do ii = 1, Qt%nb
! Split the subtensor
! -------------------
do jj = old_rank, 1, (-1)
hashjj = get_hash(Qt, [jj], ii)
idx = findtagindex(hashjj, Sls(jj)%hashes)
if(idx < 0) then
! Have to raise error
errst = raise_error('split_all_qtensor: index not '//&
'found.', 99, 'qTensors_include.f90:5818', &
errst=errst)
return
end if
sidx(jj) = idx
end do
call split(Qt%Data(ii)%Tens, Sls, sidx, errst=errst)
!if(prop_error('split_all_qtensor : split failed.', &
! 'qTensors_include.f90:5828', errst=errst)) return
! Split the quantum numbers again
! -------------------------------
!
! (It assumes they are composite quantum numbers.)
qq = Qt%Data(ii)%qq
xx = 0
do jj = 1, size(Sls, 1)
do kk = 1, size(Sls(1)%dims, 1)
! Find index in new array (Abelian)
x1 = xx * new_snqs + 1
x2 = x1 + new_nqs(1) - 1
! Find index in old array (Abelian)
y1 = (jj - 1) * snqs + (kk - 1) * new_nqs(1) + 1
y2 = y1 + new_nqs(1) - 1
qq(x1:x2) = Qt%Data(ii)%qq(y1:y2)
! Find index in new array (Discrete)
x1 = x2 + 1
x2 = x2 + new_nqs(2)
! Find index in old array (Discrete)
y1 = (jj - 1) * snqs + size(Sls(1)%dims, 1) * new_nqs(1) &
+ (kk - 1) * new_nqs(2) + 1
y2 = y1 + new_nqs(2) - 1
qq(x1:x2) = Qt%Data(ii)%qq(y1:y2)
xx = xx + 1
end do
end do
Qt%Data(ii)%qq = qq
end do
Qt%nqs = new_nqs
deallocate(sidx, qq)
end subroutine split_all_qtensor
"""
return
[docs]def split_all_qtensorc():
"""
fortran-subroutine - October 2017 (dj)
Splitting all links of the tensor into subsets. This steps allows us to
reduce the number of conserved quantities as well.
**Arguments**
Qt : TYPE(qtensorc), inout
Split all links of this tensor.
Sls : TYPE(splitlink)(\*), in
Information how to split each link in the current tensor.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine split_all_qtensorc(Qt, Sls, errst)
type(qtensorc), intent(inout) :: Qt
type(splitlink), dimension(:), intent(in) :: Sls
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk, xx
! indexing the quantum number arrays
integer :: x1, x2, y1, y2
! index for each splitlink object
integer, dimension(:), allocatable :: sidx
! matching index
integer :: idx
! rank of incoming tensor
integer :: old_rank
! hash
real(KIND=rKind) :: hashjj
! number of conserved quantities
integer :: snqs, new_snqs
! copy of the quantum numbers
integer, dimension(:), allocatable :: qq
! new number of quantum numbers
integer, dimension(2) :: new_nqs
!if(present(errst)) errst = 0
! Quick return (empty qtensor)
if(Qt%nb == 0) return
allocate(sidx(rank(Qt)))
old_rank = rank(Qt)
snqs = sum(Qt%nqs)
allocate(qq(old_rank * snqs))
new_nqs = Qt%nqs / size(Sls(1)%dims, 1)
new_snqs = sum(new_nqs)
do ii = 1, Qt%nb
! Split the subtensor
! -------------------
do jj = old_rank, 1, (-1)
hashjj = get_hash(Qt, [jj], ii)
idx = findtagindex(hashjj, Sls(jj)%hashes)
if(idx < 0) then
! Have to raise error
errst = raise_error('split_all_qtensorc: index not '//&
'found.', 99, 'qTensors_include.f90:5818', &
errst=errst)
return
end if
sidx(jj) = idx
end do
call split(Qt%Data(ii)%Tens, Sls, sidx, errst=errst)
!if(prop_error('split_all_qtensorc : split failed.', &
! 'qTensors_include.f90:5828', errst=errst)) return
! Split the quantum numbers again
! -------------------------------
!
! (It assumes they are composite quantum numbers.)
qq = Qt%Data(ii)%qq
xx = 0
do jj = 1, size(Sls, 1)
do kk = 1, size(Sls(1)%dims, 1)
! Find index in new array (Abelian)
x1 = xx * new_snqs + 1
x2 = x1 + new_nqs(1) - 1
! Find index in old array (Abelian)
y1 = (jj - 1) * snqs + (kk - 1) * new_nqs(1) + 1
y2 = y1 + new_nqs(1) - 1
qq(x1:x2) = Qt%Data(ii)%qq(y1:y2)
! Find index in new array (Discrete)
x1 = x2 + 1
x2 = x2 + new_nqs(2)
! Find index in old array (Discrete)
y1 = (jj - 1) * snqs + size(Sls(1)%dims, 1) * new_nqs(1) &
+ (kk - 1) * new_nqs(2) + 1
y2 = y1 + new_nqs(2) - 1
qq(x1:x2) = Qt%Data(ii)%qq(y1:y2)
xx = xx + 1
end do
end do
Qt%Data(ii)%qq = qq
end do
Qt%nqs = new_nqs
deallocate(sidx, qq)
end subroutine split_all_qtensorc
"""
return
[docs]def trace_qtensor():
"""
fortran-function - June 2017 (dj)
Returns the trace for rank-2 tensors.
**Arguments**
Tens : TYPE(qtensor), in
Calculate the trace assuming it is a rank-2 tensor.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function trace_qtensor(Tens, errst) result(tr)
type(qtensor), intent(in) :: Tens
integer, intent(out), optional :: errst
real(KIND=rKind) :: tr
! Local variables
! ---------------
! for looping
integer :: ii
tr = 0.0_rKind
!if(present(errst)) errst = 0
! Fast return
if(Tens%nb == 0) return
do ii = 1, Tens%nb
if(abs(get_hash(Tens, [1], ii) - get_hash(Tens, [2], ii)) > &
10.0_rKind * numzero) cycle
tr = tr + trace(Tens%Data(ii)%Tens, errst=errst)
!if(prop_error('trace_qtensor: trace failed', &
! errst=errst)) return
end do
end function trace_qtensor
"""
return
[docs]def trace_qtensorc():
"""
fortran-function - June 2017 (dj)
Returns the trace for rank-2 tensors.
**Arguments**
Tens : TYPE(qtensorc), in
Calculate the trace assuming it is a rank-2 tensor.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function trace_qtensorc(Tens, errst) result(tr)
type(qtensorc), intent(in) :: Tens
integer, intent(out), optional :: errst
complex(KIND=rKind) :: tr
! Local variables
! ---------------
! for looping
integer :: ii
tr = 0.0_rKind
!if(present(errst)) errst = 0
! Fast return
if(Tens%nb == 0) return
do ii = 1, Tens%nb
if(abs(get_hash(Tens, [1], ii) - get_hash(Tens, [2], ii)) > &
10.0_rKind * numzero) cycle
tr = tr + trace(Tens%Data(ii)%Tens, errst=errst)
!if(prop_error('trace_qtensorc: trace failed', &
! errst=errst)) return
end do
end function trace_qtensorc
"""
return
[docs]def transposed_qtensor():
"""
fortran-subroutine - July 2016 (dj)
Transposition of indices or permutation.
**Arguments**
Tens : TYPE(qtensor), inout
Save a transposition/permutation on the indices of this tensor.
perm : INTEGER(\*), OPTIONAL, in
permutation array has length equal to the rank of the tensor with
unique entries 1 to rank.
Default to rank, rank - 1, ..., 2, 1 (transpose)
doperm : LOGICAL, in
Dummy variable for interface. Always permuted due to quantum
numbers.
**Details**
The permutation is only stored in the indices and no actions
on the actual memory are carried out. The permutation array [3, 1, 2]
is to be read as "The new index 1 comes from old index 3" etc.
(template defined in Tensors_include.f90)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine transposed_qtensor(Tens, perm, doperm, errst)
type(qtensor), intent(inout) :: Tens
integer, dimension(:), intent(in), optional :: perm
logical, intent(in), optional :: doperm
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
!if(present(errst)) errst = 0
! Fast return
if(Tens%nb == 0) return
do ii = 1, Tens%nb
call transposed(Tens%Data(ii)%Tens, perm, doperm=.true., errst=errst)
!if(prop_error('tranpose_qtensor: tranpose failed.', &
! errst=errst)) return
end do
call permute_qnumbers(Tens, perm, errst=errst)
!if(prop_error('tranpose_qtensor: permute_qnumbers failed.', &
! errst=errst)) return
end subroutine transposed_qtensor
"""
return
[docs]def transposed_qtensorc():
"""
fortran-subroutine - July 2016 (dj)
Transposition of indices or permutation.
**Arguments**
Tens : TYPE(qtensorc), inout
Save a transposition/permutation on the indices of this tensor.
perm : INTEGER(\*), OPTIONAL, in
permutation array has length equal to the rank of the tensor with
unique entries 1 to rank.
Default to rank, rank - 1, ..., 2, 1 (transpose)
doperm : LOGICAL, in
Dummy variable for interface. Always permuted due to quantum
numbers.
**Details**
The permutation is only stored in the indices and no actions
on the actual memory are carried out. The permutation array [3, 1, 2]
is to be read as "The new index 1 comes from old index 3" etc.
(template defined in Tensors_include.f90)
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine transposed_qtensorc(Tens, perm, doperm, errst)
type(qtensorc), intent(inout) :: Tens
integer, dimension(:), intent(in), optional :: perm
logical, intent(in), optional :: doperm
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
!if(present(errst)) errst = 0
! Fast return
if(Tens%nb == 0) return
do ii = 1, Tens%nb
call transposed(Tens%Data(ii)%Tens, perm, doperm=.true., errst=errst)
!if(prop_error('tranpose_qtensorc: tranpose failed.', &
! errst=errst)) return
end do
call permute_qnumbers(Tens, perm, errst=errst)
!if(prop_error('tranpose_qtensorc: permute_qnumbers failed.', &
! errst=errst)) return
end subroutine transposed_qtensorc
"""
return
[docs]def write_qtensor():
"""
fortran-subroutine - August 2015 (dj)
Write the information about a qTensor to file or standard out.
details (template defined in qTensors_include.f90)
**Arguments**
Qtens : TYPE(qtensor), in
will be written to given destination.
unit : INTEGER, in
write on this unit
form : CHARACTER, in
'H' (human readable), 'B' (binary) or '6' (non-zero values
intended for standard-output).
**Details**
The information when writing a Qtensor is given in the following
form (for `H` and `B`):
1) integer, number of blocks
Looping over all blocks we write
2) real, integer with the hash and the size of the quantum number array
3) integer(:), array with the quantum numbers
4) Calling the corresponding subroutine for writing the rank-3 tensor.
See `write_tensor` or `write_tensorc`.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine write_qtensor(Qtens, unit, form, errst)
type(qtensor), intent(in) :: Qtens
integer, intent(in) :: unit
character, intent(in) :: form
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
!if(present(errst)) errst = 0
if(form == "6") then
do ii = 1, Qtens%nb
write(unit, *) 'Block #', ii
write(unit, *) 'hash', Qtens%hash(ii)
write(unit, *) 'Quantum numbers', Qtens%Data(ii)%qq
call write(Qtens%Data(ii)%Tens, unit, form)
write(unit, *) ''
end do
elseif(form == 'H') then
! Write the numer of blocks (used blocks)
write(unit, *) Qtens%nb, Qtens%nqs
do ii = 1, Qtens%nb
! Write the hash of the current block and the size of the quantum
! number array
write(unit, *) Qtens%hash(ii), size(Qtens%Data(ii)%qq)
! Write the quantum numbers
write(unit, *) Qtens%Data(ii)%qq
! Write the corresponding tensor
call write(Qtens%Data(ii)%Tens, unit, form)
end do
elseif(form == 'B') then
! Write the number of blocks (used blocks)
write(unit) Qtens%nb, Qtens%nqs
do ii = 1, Qtens%nb
! Write the hash of the current block and the size of the quantum
! number array
write(unit) Qtens%hash(ii), size(Qtens%data(ii)%qq)
! Write the quantum numbers
write(unit) Qtens%Data(ii)%qq
! Write the corresponding tensor
call write(Qtens%Data(ii)%Tens, unit, form)
end do
else
stop "write_qtensor: bad formatting option."
end if
end subroutine write_qtensor
"""
return
[docs]def write_qtensorc():
"""
fortran-subroutine - August 2015 (dj)
Write the information about a qTensor to file or standard out.
details (template defined in qTensors_include.f90)
**Arguments**
Qtens : TYPE(qtensorc), in
will be written to given destination.
unit : INTEGER, in
write on this unit
form : CHARACTER, in
'H' (human readable), 'B' (binary) or '6' (non-zero values
intended for standard-output).
**Details**
The information when writing a Qtensor is given in the following
form (for `H` and `B`):
1) integer, number of blocks
Looping over all blocks we write
2) real, integer with the hash and the size of the quantum number array
3) integer(:), array with the quantum numbers
4) Calling the corresponding subroutine for writing the rank-3 tensor.
See `write_tensor` or `write_tensorc`.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine write_qtensorc(Qtens, unit, form, errst)
type(qtensorc), intent(in) :: Qtens
integer, intent(in) :: unit
character, intent(in) :: form
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
!if(present(errst)) errst = 0
if(form == "6") then
do ii = 1, Qtens%nb
write(unit, *) 'Block #', ii
write(unit, *) 'hash', Qtens%hash(ii)
write(unit, *) 'Quantum numbers', Qtens%Data(ii)%qq
call write(Qtens%Data(ii)%Tens, unit, form)
write(unit, *) ''
end do
elseif(form == 'H') then
! Write the numer of blocks (used blocks)
write(unit, *) Qtens%nb, Qtens%nqs
do ii = 1, Qtens%nb
! Write the hash of the current block and the size of the quantum
! number array
write(unit, *) Qtens%hash(ii), size(Qtens%Data(ii)%qq)
! Write the quantum numbers
write(unit, *) Qtens%Data(ii)%qq
! Write the corresponding tensor
call write(Qtens%Data(ii)%Tens, unit, form)
end do
elseif(form == 'B') then
! Write the number of blocks (used blocks)
write(unit) Qtens%nb, Qtens%nqs
do ii = 1, Qtens%nb
! Write the hash of the current block and the size of the quantum
! number array
write(unit) Qtens%hash(ii), size(Qtens%data(ii)%qq)
! Write the quantum numbers
write(unit) Qtens%Data(ii)%qq
! Write the corresponding tensor
call write(Qtens%Data(ii)%Tens, unit, form)
end do
else
stop "write_qtensorc: bad formatting option."
end if
end subroutine write_qtensorc
"""
return
[docs]def create_splitlink_qtensor():
"""
fortran-subroutine - October 2017 (dj)
Create a splitlink object from the identity matrix.
**Arguments**
Sl : TYPE(splitlink), inout
Fill this splitlink object with the splitting for an
identity matrix.
Idop : TYPE(TENSOR_TYPE), in
The dimension is taken from the identity to create
the splitlink object.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine create_splitlink_qtensor(Sl, Idop)
type(splitlink), intent(inout) :: Sl
type(qtensor), intent(in) :: Idop
! Local variables
! ---------------
! indices for fusing
integer, dimension(2, 2) :: fidx
! temporary tensors for Kronecker and fusing
type(qtensor) :: Qa, Qb, Qc
call copy(Qa, Idop)
call copy(Qb, Qa)
call kron(Qc, Qa, Qb, 1, 1, 'N', 'N', 'N')
call destroy(Qa)
call destroy(Qb)
call init(Sl, Qc, [1, 2])
fidx(:, 1) = [1, 2]
fidx(:, 2) = [3, 4]
call fuse(Qc, fidx, '0')
call finalize(Sl, Qc, 1)
call destroy(Qc)
end subroutine create_splitlink_qtensor
"""
return
[docs]def create_splitlink_qtensorc():
"""
fortran-subroutine - October 2017 (dj)
Create a splitlink object from the identity matrix.
**Arguments**
Sl : TYPE(splitlink), inout
Fill this splitlink object with the splitting for an
identity matrix.
Idop : TYPE(TENSOR_TYPE), in
The dimension is taken from the identity to create
the splitlink object.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine create_splitlink_qtensorc(Sl, Idop)
type(splitlink), intent(inout) :: Sl
type(qtensorc), intent(in) :: Idop
! Local variables
! ---------------
! indices for fusing
integer, dimension(2, 2) :: fidx
! temporary tensors for Kronecker and fusing
type(qtensorc) :: Qa, Qb, Qc
call copy(Qa, Idop)
call copy(Qb, Qa)
call kron(Qc, Qa, Qb, 1, 1, 'N', 'N', 'N')
call destroy(Qa)
call destroy(Qb)
call init(Sl, Qc, [1, 2])
fidx(:, 1) = [1, 2]
fidx(:, 2) = [3, 4]
call fuse(Qc, fidx, '0')
call finalize(Sl, Qc, 1)
call destroy(Qc)
end subroutine create_splitlink_qtensorc
"""
return
[docs]def init_splitlink_qtensor():
"""
fortran-subroutine - October 2017 (dj)
Store dimension for splitting a link. The quantum numbers on that link
must stay the same.
**Arguments**
Sl : TYPE(splitlink), inout
Object storing the dimensions for each hash.
Tens : TYPE(qtensor), in
Tensor to be fused in the following.
idx : INTEGER(\*), in
Indices to be fused in the tensor Tens.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine init_splitlink_qtensor(Sl, Tens, idx, errst)
type(splitlink), intent(inout) :: Sl
type(qtensor), intent(in) :: Tens
integer, dimension(:), intent(in) :: idx
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! example for representation
integer :: i1
! number of links fused
integer :: nn
! number of blocks
integer :: mm
! for degenerate sorting
real(KIND=rKind), dimension(:), allocatable :: hash, littlehash
integer :: nunique
integer, dimension(:), allocatable :: ind, deg
!if(present(errst)) errst = 0
nn = size(idx, 1)
mm = Tens%nb
allocate(hash(mm), littlehash(mm), ind(mm), deg(mm + 1))
hash = get_hash(Tens, [idx])
call ascending_hsort(hash, littlehash, ind, nunique, deg, errst=errst)
!if(prop_error('create_splitlink_qtensor : ascending_'//&
! 'hsort failed.', 'qTensors_include.f90:6234', errst=errst)) return
allocate(Sl%hashes(nunique), Sl%dims(nn, nunique))
do ii = 1, nunique
i1 = ind(deg(ii) + 1)
Sl%dims(:, ii) = Tens%Data(i1)%Tens%dl(idx)
Sl%hashes(ii) = i1
end do
deallocate(hash, littlehash, ind, deg)
end subroutine init_splitlink_qtensor
"""
return
[docs]def init_splitlink_qtensorc():
"""
fortran-subroutine - October 2017 (dj)
Store dimension for splitting a link. The quantum numbers on that link
must stay the same.
**Arguments**
Sl : TYPE(splitlink), inout
Object storing the dimensions for each hash.
Tens : TYPE(qtensorc), in
Tensor to be fused in the following.
idx : INTEGER(\*), in
Indices to be fused in the tensor Tens.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine init_splitlink_qtensorc(Sl, Tens, idx, errst)
type(splitlink), intent(inout) :: Sl
type(qtensorc), intent(in) :: Tens
integer, dimension(:), intent(in) :: idx
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! example for representation
integer :: i1
! number of links fused
integer :: nn
! number of blocks
integer :: mm
! for degenerate sorting
real(KIND=rKind), dimension(:), allocatable :: hash, littlehash
integer :: nunique
integer, dimension(:), allocatable :: ind, deg
!if(present(errst)) errst = 0
nn = size(idx, 1)
mm = Tens%nb
allocate(hash(mm), littlehash(mm), ind(mm), deg(mm + 1))
hash = get_hash(Tens, [idx])
call ascending_hsort(hash, littlehash, ind, nunique, deg, errst=errst)
!if(prop_error('create_splitlink_qtensorc : ascending_'//&
! 'hsort failed.', 'qTensors_include.f90:6234', errst=errst)) return
allocate(Sl%hashes(nunique), Sl%dims(nn, nunique))
do ii = 1, nunique
i1 = ind(deg(ii) + 1)
Sl%dims(:, ii) = Tens%Data(i1)%Tens%dl(idx)
Sl%hashes(ii) = i1
end do
deallocate(hash, littlehash, ind, deg)
end subroutine init_splitlink_qtensorc
"""
return
[docs]def finalize_splitlink_qtensor():
"""
fortran-subroutine - October 2017 (dj)
This is the second step when creating a splitlink object. It creates
the hashes of the fused symmetry numbers.
**Arguments**
Sl : TYPE(splitlink), inout
On exit, complete splitlink object. On entry, the hashes are
filled with the indices of the corresponding block.
Tens : TYPE(TENSOR_TYPE), in
The tensor which was fused.
idx : INTEGER, in
Index of the new link, which has been fused.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine finalize_splitlink_qtensor(Sl, Tens, idx, errst)
type(splitlink), intent(inout) :: Sl
type(qtensor), intent(in) :: Tens
integer, intent(in) :: idx
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! indices from sorting
integer, dimension(:), allocatable :: ind
! copy for dimensions
integer, dimension(:, :), allocatable :: dims
do ii = 1, size(Sl%hashes, 1)
Sl%hashes(ii) = get_hash(Tens, [idx], int(Sl%hashes(ii)))
end do
! Hashes have to be sorted for `Findtagindex`, but I don't see any
! reason why they should be since abelian and discrete quantum numbers
! can be permuted. So they should be unique now.
allocate(ind(size(Sl%hashes, 1)), dims(size(Sl%dims, 1), size(Sl%dims, 2)))
call ascending_hsort(Sl%hashes, ind)
Sl%hashes(ind) = Sl%hashes
dims = Sl%dims
do ii = 1, size(ind, 1)
Sl%dims(:, ii) = dims(:, ind(ii))
end do
deallocate(ind, dims)
end subroutine finalize_splitlink_qtensor
"""
return
[docs]def finalize_splitlink_qtensorc():
"""
fortran-subroutine - October 2017 (dj)
This is the second step when creating a splitlink object. It creates
the hashes of the fused symmetry numbers.
**Arguments**
Sl : TYPE(splitlink), inout
On exit, complete splitlink object. On entry, the hashes are
filled with the indices of the corresponding block.
Tens : TYPE(TENSOR_TYPE), in
The tensor which was fused.
idx : INTEGER, in
Index of the new link, which has been fused.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine finalize_splitlink_qtensorc(Sl, Tens, idx, errst)
type(splitlink), intent(inout) :: Sl
type(qtensorc), intent(in) :: Tens
integer, intent(in) :: idx
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! indices from sorting
integer, dimension(:), allocatable :: ind
! copy for dimensions
integer, dimension(:, :), allocatable :: dims
do ii = 1, size(Sl%hashes, 1)
Sl%hashes(ii) = get_hash(Tens, [idx], int(Sl%hashes(ii)))
end do
! Hashes have to be sorted for `Findtagindex`, but I don't see any
! reason why they should be since abelian and discrete quantum numbers
! can be permuted. So they should be unique now.
allocate(ind(size(Sl%hashes, 1)), dims(size(Sl%dims, 1), size(Sl%dims, 2)))
call ascending_hsort(Sl%hashes, ind)
Sl%hashes(ind) = Sl%hashes
dims = Sl%dims
do ii = 1, size(ind, 1)
Sl%dims(:, ii) = dims(:, ind(ii))
end do
deallocate(ind, dims)
end subroutine finalize_splitlink_qtensorc
"""
return