Source code for qTensors_f90

"""
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 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 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