qTensors

Fortran module qTensors: June 2017 (dj)

Containing basic operations for symmetric tensors as allocation, reading writing.

Authors

• 4. Jaschke

• 13. 12. 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

qTensors_f90.sumq()

fortran-function - April 2016 (updated dj) Group element addition for the corresponding symmetry. Return type is INTEGER(*) = q1 + q2

Arguments

q1INTEGER(*), in

charge number on links

q2INTEGER(*), in

charge number on links

nqsINTEGER(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

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

qTensors_f90.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

qINTEGER(*), 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.

indicesINTEGER(*), 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_{lpha eta}^{i}} according to its first dimension.

nqsINTEGER(2), in

Saves number of U(1) and Z(2) symmetries.

Details

(Template defined in qTensors_template.f90)

Source Code

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

qTensors_f90.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

nnINTEGER, in

Find first nn prime numbers and setup their roots.

Details

(Template defined in qTensors_template.f90)

Source Code

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

qTensors_f90.cleanup_qtensors()

fortran-subroutine - March 2016 (dj) Deallocate the vector with prime numbers.

Details

(Template defined in qTensors_template.f90)

Source Code

show / hide f90 code

  subroutine cleanup_qtensors()

      deallocate(primes)

  end subroutine cleanup_qtensors

qTensors_f90.AddProject_qtensor()

fortran-subroutine - March 2016 (updated dj) Apply the projector P to A and add to B, where P is defined as .

Arguments

BbTYPE(qtensor), inout

Add projection of A to this tensor.

AaTYPE(qtensor), in

Get projection of this tensor and add to Bb

PsiProjsTYPE(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

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

qTensors_f90.AddProject_qtensorc()

fortran-subroutine - March 2016 (updated dj) Apply the projector P to A and add to B, where P is defined as .

Arguments

BbTYPE(qtensorc), inout

Add projection of A to this tensor.

AaTYPE(qtensorc), in

Get projection of this tensor and add to Bb

PsiProjsTYPE(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

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

qTensors_f90.add_dummylink_qtensor()

fortran-subroutine - October 2017 (dj) Add a dummy link to a tensor. By default quantum numbers 0.

Arguments

QtTYPE(qtensor), inout

Add a dummy link of dimenions one to the tensor.

idxINTEGER, in

Position of the dummy link in the modified tensor.

Source Code

show / hide f90 code

  subroutine add_dummylink_qtensor(Qt, idx, errst)
      type(qtensor), intent(inout) :: Qt
      integer, intent(in) :: idx
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! total number of quantum numbers
      integer :: snqs

      ! size for new quantum numbers
      integer :: nq

      ! temporary quantum numbers
      integer, dimension(:), allocatable :: qq

      ! indices to copy quantum numbers
      integer :: q2, q3, p3

      !if(present(errst)) errst = 0

      if(Qt%nb == 0) return

      snqs = sum(Qt%nqs)

      nq = snqs * (rank(Qt) + 1)
      allocate(qq(nq))
      qq = 0

      ! Indices in new array
      q2 = snqs * (idx - 1)
      q3 = snqs * idx + 1

      ! Different indices in old array
      p3 = q2 + 1

      do ii = 1, Qt%nb
          call add_dummylink(Qt%Data(ii)%Tens, idx, errst=errst)
          !if(prop_error('add_dummylink_qtensor : add_'//&
          !              'dummylink failed.', 'qTensors_include.f90:384', &
          !              errst=errst)) return

          qq(:q2) = Qt%Data(ii)%qq(:q2)
          qq(q3:) = Qt%Data(ii)%qq(p3:)

          deallocate(Qt%Data(ii)%qq)
          allocate(Qt%Data(ii)%qq(nq))
          Qt%Data(ii)%qq = qq

      end do

      deallocate(qq)

  end subroutine add_dummylink_qtensor

qTensors_f90.add_dummylink_qtensorc()

fortran-subroutine - October 2017 (dj) Add a dummy link to a tensor. By default quantum numbers 0.

Arguments

QtTYPE(qtensorc), inout

Add a dummy link of dimenions one to the tensor.

idxINTEGER, in

Position of the dummy link in the modified tensor.

Source Code

show / hide f90 code

  subroutine add_dummylink_qtensorc(Qt, idx, errst)
      type(qtensorc), intent(inout) :: Qt
      integer, intent(in) :: idx
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! total number of quantum numbers
      integer :: snqs

      ! size for new quantum numbers
      integer :: nq

      ! temporary quantum numbers
      integer, dimension(:), allocatable :: qq

      ! indices to copy quantum numbers
      integer :: q2, q3, p3

      !if(present(errst)) errst = 0

      if(Qt%nb == 0) return

      snqs = sum(Qt%nqs)

      nq = snqs * (rank(Qt) + 1)
      allocate(qq(nq))
      qq = 0

      ! Indices in new array
      q2 = snqs * (idx - 1)
      q3 = snqs * idx + 1

      ! Different indices in old array
      p3 = q2 + 1

      do ii = 1, Qt%nb
          call add_dummylink(Qt%Data(ii)%Tens, idx, errst=errst)
          !if(prop_error('add_dummylink_qtensorc : add_'//&
          !              'dummylink failed.', 'qTensors_include.f90:384', &
          !              errst=errst)) return

          qq(:q2) = Qt%Data(ii)%qq(:q2)
          qq(q3:) = Qt%Data(ii)%qq(p3:)

          deallocate(Qt%Data(ii)%qq)
          allocate(Qt%Data(ii)%qq(nq))
          Qt%Data(ii)%qq = qq

      end do

      deallocate(qq)

  end subroutine add_dummylink_qtensorc

qTensors_f90.block_qtensor()

fortran-subroutine - April 2017 (dj, based on mlw) Build the blocks for a bipartition of links prior to a decomposition.

Arguments

Tenstype(qtensor), inout

This tensor should be decomposed. Might be changed on exit, e.g. due to permutations.

idxlINTEGER(*), in

Contains the indices of the links going to the rows.

idxrINTEGER(*), in

Contains the indices of the links going to the columns.

MatsTYPE(tensorlist), inout

Contains the matrices to be decomposed back into tensors. Deallocated on exit.

nuniqueINTEGER, out

On exit the number of unique blocks corresponding to the number of matrices in Mats.

LmapTYPE(VECTOR_INT)(*), inout

Map for finding a representative of each irrep for the rows to retrieve the quantum numbers. Allocated during this suboutine.

RmapTYPE(VECTOR_INT)(*), inout

Map for finding a representative of each irrep for the columns to retrieve the quantum numbers. Allocated during this subroutine.

RowcutTYPE(VECTOR_INT)(*), inout

Contains the first and last index of rows for each irreps. Allocated during this subroutine.

ColcutTYPE(VECTOR_INT)(*), inout

Contains the first and last index of columns for each irreps. Allocated during this subroutine.

nts_rowINTEGER(*), inout

Contains the number of irreps in each block for the rows. Allocated during this subroutine.

nts_colINTEGER(*), inout

Contains the number of irreps in each block for the columns. Allocated during this subroutine.

idxhashINTEGER(*), in

Sorting the hashes for the splitting. Allocated during this subroutine.

hamLOGICAL, 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

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

qTensors_f90.block_qtensorc()

fortran-subroutine - April 2017 (dj, based on mlw) Build the blocks for a bipartition of links prior to a decomposition.

Arguments

Tenstype(qtensorc), inout

This tensor should be decomposed. Might be changed on exit, e.g. due to permutations.

idxlINTEGER(*), in

Contains the indices of the links going to the rows.

idxrINTEGER(*), in

Contains the indices of the links going to the columns.

MatsTYPE(tensorlistc), inout

Contains the matrices to be decomposed back into tensors. Deallocated on exit.

nuniqueINTEGER, out

On exit the number of unique blocks corresponding to the number of matrices in Mats.

LmapTYPE(VECTOR_INT)(*), inout

Map for finding a representative of each irrep for the rows to retrieve the quantum numbers. Allocated during this suboutine.

RmapTYPE(VECTOR_INT)(*), inout

Map for finding a representative of each irrep for the columns to retrieve the quantum numbers. Allocated during this subroutine.

RowcutTYPE(VECTOR_INT)(*), inout

Contains the first and last index of rows for each irreps. Allocated during this subroutine.

ColcutTYPE(VECTOR_INT)(*), inout

Contains the first and last index of columns for each irreps. Allocated during this subroutine.

nts_rowINTEGER(*), inout

Contains the number of irreps in each block for the rows. Allocated during this subroutine.

nts_colINTEGER(*), inout

Contains the number of irreps in each block for the columns. Allocated during this subroutine.

idxhashINTEGER(*), in

Sorting the hashes for the splitting. Allocated during this subroutine.

hamLOGICAL, 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

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

qTensors_f90.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

TensTYPE(qtensor), in

This tensor should be decomposed.

strideINTEGER, in

Used to identify the offset after sorting the complete hash.

ntINTEGER, in

Number of tensors in this subblock to be sorted.

idxINTEGER(*), in

Contains the link(s) to be hashed for the subblock.

nlINTEGER, in

Number of indices building the left bipartitions for splitting the tensor.

idxhashINTEGER(*), in

Sorting the hashes for the splitting. Allocated during this subroutine.

nuniqueiiINTEGER, out

Number of unique hashes in the subblock.

dimINTEGER, out

The dimension of a subblock is the number of rows (left bipartition) or number of columns (right bipartition).

cutiiINTEGER(*), 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.

mapINTEGER(*), inout

Contains one representative (example) of each irrep to retrieve the quantum numbers at the end. Allocated during this subroutine.

bmapINTEGER(*), inout

Returns the block when inputting the index. Allocated during this subroutine.

Source Code

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

qTensors_f90.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

TensTYPE(qtensorc), in

This tensor should be decomposed.

strideINTEGER, in

Used to identify the offset after sorting the complete hash.

ntINTEGER, in

Number of tensors in this subblock to be sorted.

idxINTEGER(*), in

Contains the link(s) to be hashed for the subblock.

nlINTEGER, in

Number of indices building the left bipartitions for splitting the tensor.

idxhashINTEGER(*), in

Sorting the hashes for the splitting. Allocated during this subroutine.

nuniqueiiINTEGER, out

Number of unique hashes in the subblock.

dimINTEGER, out

The dimension of a subblock is the number of rows (left bipartition) or number of columns (right bipartition).

cutiiINTEGER(*), 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.

mapINTEGER(*), inout

Contains one representative (example) of each irrep to retrieve the quantum numbers at the end. Allocated during this subroutine.

bmapINTEGER(*), inout

Returns the block when inputting the index. Allocated during this subroutine.

Source Code

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

qTensors_f90.block2tensor_left_qtensor()

fortran-subroutine - April 2017 (dj, based on mlw) Rewrite the matrices of a decomposition again as tensor.

Arguments

LtensTYPE(qtensor), inout

The decomposed tensor is stored here.

TensTYPE(qtensor), in

The original tensor which was decomposed. It is required to track the quantum numbers.

MatsTYPE(tensorlist), inout

Contains the matrices to be decomposed back into tensors. Deallocated on exit.

nlINTEGER, in

Number of indices encoded in the rows.

nuniqueINTEGER, in

Number of unique blocks corresponding to the number of matrices in Mats.

chiINTEGER, in

Total bond dimension for last index.

LmapTYPE(VECTOR_INT)(*), inout

Map for finding a representative of each irrep to retrieve the quantum numbers. Deallocate on exit.

RowcutTYPE(VECTOR_INT)(*), inout

Contains the first and last index of rows for each irreps. Deallocated on exit.

nts_rowINTEGER(*), inout

Contains the number of irreps in each block. Deallocated on exit.

idxhashINTEGER(*), in

Sorting the hashes for the splitting.

lamblkINTEGER(*), OPTIONAL, in

Contains the block for the singular value at the i-th position.

lamindINTEGER(*), OPTIONAL, in

Contains the indices to sort the array of singular values.

callerCHARACTER, 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

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

qTensors_f90.block2tensor_left_qtensorc()

fortran-subroutine - April 2017 (dj, based on mlw) Rewrite the matrices of a decomposition again as tensor.

Arguments

LtensTYPE(qtensorc), inout

The decomposed tensor is stored here.

TensTYPE(qtensorc), in

The original tensor which was decomposed. It is required to track the quantum numbers.

MatsTYPE(tensorlistc), inout

Contains the matrices to be decomposed back into tensors. Deallocated on exit.

nlINTEGER, in

Number of indices encoded in the rows.

nuniqueINTEGER, in

Number of unique blocks corresponding to the number of matrices in Mats.

chiINTEGER, in

Total bond dimension for last index.

LmapTYPE(VECTOR_INT)(*), inout

Map for finding a representative of each irrep to retrieve the quantum numbers. Deallocate on exit.

RowcutTYPE(VECTOR_INT)(*), inout

Contains the first and last index of rows for each irreps. Deallocated on exit.

nts_rowINTEGER(*), inout

Contains the number of irreps in each block. Deallocated on exit.

idxhashINTEGER(*), in

Sorting the hashes for the splitting.

lamblkINTEGER(*), OPTIONAL, in

Contains the block for the singular value at the i-th position.

lamindINTEGER(*), OPTIONAL, in

Contains the indices to sort the array of singular values.

callerCHARACTER, 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

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

qTensors_f90.block2tensor_right_qtensor()

fortran-subroutine - April 2017 (dj, based on mlw) Rewrite the matrices of a decomposition again as tensor.

Arguments

RtensTYPE(qtensor), inout

The decomposed tensor is stored here.

TensTYPE(qtensor), in

The original tensor which was decomposed. It is required to track the quantum numbers.

MatsTYPE(tensorlist), inout

Contains the matrices to be decomposed back into tensors. Deallocated on exit.

nlINTEGER, in

Number of indices encoded in the rows.

nrINTEGER, in

Number of indices encoded in the columns.

nuniqueINTEGER, in

Number of unique blocks corresponding to the number of matrices in Mats.

chiINTEGER, in

Total bond dimension for last index.

RmapTYPE(VECTOR_INT)(*), inout

Map for finding a representative of each irrep to retrieve the quantum numbers. Deallocate on exit.

ColcutTYPE(VECTOR_INT)(*), inout

Contains the first and last index of columns for each irreps. Deallocated on exit.

nts_colINTEGER(*), inout

Contains the number of irreps in each block. Deallocated on exit.

idxhashINTEGER(*), in

Sorting the hashes for the splitting.

lamblkINTEGER(*), OPTIONAL, in

Contains the block for the singular value at the i-th position.

lamindINTEGER(*), OPTIONAL, in

Contains the indices to sort the array of singular values.

callerCHARACTER, 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

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

qTensors_f90.block2tensor_right_qtensorc()

fortran-subroutine - April 2017 (dj, based on mlw) Rewrite the matrices of a decomposition again as tensor.

Arguments

RtensTYPE(qtensorc), inout

The decomposed tensor is stored here.

TensTYPE(qtensorc), in

The original tensor which was decomposed. It is required to track the quantum numbers.

MatsTYPE(tensorlistc), inout

Contains the matrices to be decomposed back into tensors. Deallocated on exit.

nlINTEGER, in

Number of indices encoded in the rows.

nrINTEGER, in

Number of indices encoded in the columns.

nuniqueINTEGER, in

Number of unique blocks corresponding to the number of matrices in Mats.

chiINTEGER, in

Total bond dimension for last index.

RmapTYPE(VECTOR_INT)(*), inout

Map for finding a representative of each irrep to retrieve the quantum numbers. Deallocate on exit.

ColcutTYPE(VECTOR_INT)(*), inout

Contains the first and last index of columns for each irreps. Deallocated on exit.

nts_colINTEGER(*), inout

Contains the number of irreps in each block. Deallocated on exit.

idxhashINTEGER(*), in

Sorting the hashes for the splitting.

lamblkINTEGER(*), OPTIONAL, in

Contains the block for the singular value at the i-th position.

lamindINTEGER(*), OPTIONAL, in

Contains the indices to sort the array of singular values.

callerCHARACTER, 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

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

qTensors_f90.block2tensor_center_qtensor()

fortran-subroutine - April 2017 (dj) Rewrite the matrices of the singular values again as a tensor.

Arguments

LambdaTYPE(qtensor), inout

The singular values between the decomposed tensors (or other possible weights).

TensTYPE(qtensor), in

The original tensor which was decomposed. It is required to track the quantum numbers.

LamTYPE(tensorlist), inout

Contains the vectors for singular values to be stored with their quantum numbers.

nlINTEGER, in

Number of indices encoded in the rows.

nuniqueINTEGER, in

Number of unique blocks corresponding to the number of matrices in Mats.

chiINTEGER, in

Total bond dimension for last index.

RmapTYPE(VECTOR_INT)(*), inout

Map for finding a representative of each irrep to retrieve the quantum numbers.

nts_colINTEGER(*), inout

Contains the number of irreps in each block.

idxhashINTEGER(*), in

Sorting the hashes for the splitting.

lamblkINTEGER(*), in

Contains the block for the singular value at the i-th position.

lamindINTEGER(*), in

Contains the indices to sort the array of singular values.

callerCHARACTER, 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

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

qTensors_f90.block2tensor_center_qtensorc()

fortran-subroutine - April 2017 (dj) Rewrite the matrices of the singular values again as a tensor.

Arguments

LambdaTYPE(qtensor), inout

The singular values between the decomposed tensors (or other possible weights).

TensTYPE(qtensorc), in

The original tensor which was decomposed. It is required to track the quantum numbers.

LamTYPE(tensorlist), inout

Contains the vectors for singular values to be stored with their quantum numbers.

nlINTEGER, in

Number of indices encoded in the rows.

nuniqueINTEGER, in

Number of unique blocks corresponding to the number of matrices in Mats.

chiINTEGER, in

Total bond dimension for last index.

RmapTYPE(VECTOR_INT)(*), inout

Map for finding a representative of each irrep to retrieve the quantum numbers.

nts_colINTEGER(*), inout

Contains the number of irreps in each block.

idxhashINTEGER(*), in

Sorting the hashes for the splitting.

lamblkINTEGER(*), in

Contains the block for the singular value at the i-th position.

lamindINTEGER(*), in

Contains the indices to sort the array of singular values.

callerCHARACTER, 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

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

qTensors_f90.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

TensTYPE(qtensor), inout

The original tensor which was decomposed. It will be overwritten.

MatsTYPE(tensorlist), inout

Contains the matrices to be decomposed back into tensors. Deallocated on exit.

MatsTYPE(tensorlist), inout

Contains the matrices to be decomposed back into tensors. Deallocated on exit.

LmapTYPE(VECTOR_INT)(*), inout

Map for finding a representative of each irrep to retrieve the quantum numbers of a row. Deallocate on exit.

RmapTYPE(VECTOR_INT)(*), inout

Map for finding a representative of each irrep to retrieve the quantum numbers of a column. Deallocate on exit.

RowcutTYPE(VECTOR_INT)(*), inout

Contains the first and last index of rows for each irreps. Deallocated on exit.

ColcutTYPE(VECTOR_INT)(*), inout

Contains the first and last index of columns for each irreps. Deallocated on exit.

nts_rowINTEGER(*), inout

Contains the number of irreps in each block for the rows. Deallocated on exit.

nts_colINTEGER(*), inout

Contains the number of irreps in each block for the columns. Deallocated on exit.

idxhashINTEGER(*), in

Sorting the hashes for the splitting.

nuniqueINTEGER, in

Number of unique blocks corresponding to the number of matrices in Mats.

nlINTEGER, in

Number of links in the left block.

Source Code

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

qTensors_f90.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

TensTYPE(qtensorc), inout

The original tensor which was decomposed. It will be overwritten.

MatsTYPE(tensorlistc), inout

Contains the matrices to be decomposed back into tensors. Deallocated on exit.

MatsTYPE(tensorlistc), inout

Contains the matrices to be decomposed back into tensors. Deallocated on exit.

LmapTYPE(VECTOR_INT)(*), inout

Map for finding a representative of each irrep to retrieve the quantum numbers of a row. Deallocate on exit.

RmapTYPE(VECTOR_INT)(*), inout

Map for finding a representative of each irrep to retrieve the quantum numbers of a column. Deallocate on exit.

RowcutTYPE(VECTOR_INT)(*), inout

Contains the first and last index of rows for each irreps. Deallocated on exit.

ColcutTYPE(VECTOR_INT)(*), inout

Contains the first and last index of columns for each irreps. Deallocated on exit.

nts_rowINTEGER(*), inout

Contains the number of irreps in each block for the rows. Deallocated on exit.

nts_colINTEGER(*), inout

Contains the number of irreps in each block for the columns. Deallocated on exit.

idxhashINTEGER(*), in

Sorting the hashes for the splitting.

nuniqueINTEGER, in

Number of unique blocks corresponding to the number of matrices in Mats.

nlINTEGER, in

Number of links in the left block.

Source Code

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

qTensors_f90.check_qnum_tensdim_qtensor()

fortran-subroutine - August 2018 (dj) Check for entries with same quantum number, but different tensor dimension.

Arguments

TensTYPE(qtensor), in

Tensor to be checked.

Source Code

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

qTensors_f90.check_qnum_tensdim_qtensorc()

fortran-subroutine - August 2018 (dj) Check for entries with same quantum number, but different tensor dimension.

Arguments

TensTYPE(qtensorc), in

Tensor to be checked.

Source Code

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

qTensors_f90.conj_qtensor()

fortran-subroutine - October 2016 (dj) Complex-conjugated elements in the tensor.

Arguments

TensTYPE(qtensor), inout

Take the complex conjugate of each element

Source Code

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

qTensors_f90.conj_qtensorc()

fortran-subroutine - October 2016 (dj) Complex-conjugated elements in the tensor.

Arguments

TensTYPE(qtensorc), inout

Take the complex conjugate of each element

Source Code

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

qTensors_f90.copy_qtensor_qtensor()

fortran-subroutine - January 2016 (update dj) Copy a qtensor. details (template defined in qTensors_include.f90)

Arguments

ObjoutTYPE(VECTOR_TYPE), out

Store copy of Objin in this vector.

ObjinTYPE(VECTOR_TYPE), in

Copy this vector to a new vector Objout.

scalarreal, OPTIONAL, in

Multiply input tensor with scalar during copying replacing a copy + scale action.

transCHARACTER, 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

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

qTensors_f90.copy_qtensorc_qtensor()

fortran-subroutine - January 2016 (update dj) Copy a qtensor. details (template defined in qTensors_include.f90)

Arguments

ObjoutTYPE(VECTOR_TYPE), out

Store copy of Objin in this vector.

ObjinTYPE(VECTOR_TYPE), in

Copy this vector to a new vector Objout.

scalarcomplex, OPTIONAL, in

Multiply input tensor with scalar during copying replacing a copy + scale action.

transCHARACTER, 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

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

qTensors_f90.copy_qtensorc_qtensorc()

fortran-subroutine - January 2016 (update dj) Copy a qtensorc. details (template defined in qTensors_include.f90)

Arguments

ObjoutTYPE(VECTOR_TYPE), out

Store copy of Objin in this vector.

ObjinTYPE(VECTOR_TYPE), in

Copy this vector to a new vector Objout.

scalarcomplex, OPTIONAL, in

Multiply input tensor with scalar during copying replacing a copy + scale action.

transCHARACTER, 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

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

qTensors_f90.copy_qtensorlist()

fortran-subroutine - ?? () Copy a qtensor list.

Arguments

ObjoutTYPE(qtensorlist), out

Copy the entries of Objin here.

ObjinTYPE(qtensorlist), in

source for copy into Dest.

Source Code

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

qTensors_f90.copy_qtensorclist()

fortran-subroutine - ?? () Copy a qtensorc list.

Arguments

ObjoutTYPE(qtensorclist), out

Copy the entries of Objin here.

ObjinTYPE(qtensorclist), in

source for copy into Dest.

Source Code

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

qTensors_f90.copy_qtensorlistarray()

fortran-subroutine - ?? () Copy an array of qtensor lists.

Arguments

ObjoutTYPE(qtensorlist)(*), out

Copy the entries of Objin here.

ObjinTYPE(qtensorlist)(*), in

source for copy into Objout

Source Code

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

qTensors_f90.copy_qtensorclistarray()

fortran-subroutine - ?? () Copy an array of qtensorc lists.

Arguments

ObjoutTYPE(qtensorclist)(*), out

Copy the entries of Objin here.

ObjinTYPE(qtensorclist)(*), in

source for copy into Objout

Source Code

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

qTensors_f90.create_qtensor()

fortran-subroutine - ?? (mlw) Create an empty qtensor with capacity “capacity”. details (template defined in qTensors_include.f90)

Arguments

QtTYPE(qtensor), out

Allocate the array to store the tensors for each set of quantum numbers.

nqsINTEGER(2), in

NUmber of conserved quantum numbers on each link.

capacityINTEGER, OPTIONAL, in

Estimation of the maximal number of sets of quantum numbers. Will be extended when needed.

Source Code

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

qTensors_f90.create_qtensorc()

fortran-subroutine - ?? (mlw) Create an empty qtensorc with capacity “capacity”. details (template defined in qTensors_include.f90)

Arguments

QtTYPE(qtensorc), out

Allocate the array to store the tensors for each set of quantum numbers.

nqsINTEGER(2), in

NUmber of conserved quantum numbers on each link.

capacityINTEGER, OPTIONAL, in

Estimation of the maximal number of sets of quantum numbers. Will be extended when needed.

Source Code

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

qTensors_f90.create_qtensorlist()

fortran-subroutine - January 2016 (update dj) Create a qtensor list of length d1.

Arguments

MatsTYPE(qtensorlist), inout

Allocate an array of size d1.

d1INTEGER, in

Length of the matrix list to be allocated.

Source Code

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

qTensors_f90.create_qtensorclist()

fortran-subroutine - January 2016 (update dj) Create a qtensorc list of length d1.

Arguments

MatsTYPE(qtensorclist), inout

Allocate an array of size d1.

d1INTEGER, in

Length of the matrix list to be allocated.

Source Code

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

qTensors_f90.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

QmTYPE(qtensor), out

Create and identity matrix of dimension dim x dim.

QtTYPE(qtensor), inout

Needed to extract dimension for identity matrix.

sideINTEGER, 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

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_{lpha} 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

qTensors_f90.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

QmTYPE(qtensorc), out

Create and identity matrix of dimension dim x dim.

QtTYPE(qtensorc), inout

Needed to extract dimension for identity matrix.

sideINTEGER, 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

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_{lpha} 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

qTensors_f90.dagger_qtensor()

fortran-subroutine - October 2016 (dj) Taking complex conjugate followed by transposition of indices or permutation.

Arguments

TensQTYPE(TENSOR_TYPE), inout

Save a transposition/permutation on the indices of this tensor. Complex conjugated values are taken during this subroutine.

permINTEGER(*), 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

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

qTensors_f90.dagger_qtensorc()

fortran-subroutine - October 2016 (dj) Taking complex conjugate followed by transposition of indices or permutation.

Arguments

TensQTYPE(TENSOR_TYPE), inout

Save a transposition/permutation on the indices of this tensor. Complex conjugated values are taken during this subroutine.

permINTEGER(*), 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

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

qTensors_f90.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

QtTYPE(qtensor) , inout

Deallocate all blocks and the arrays of the qtensor.

Source Code

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

qTensors_f90.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

QtTYPE(qtensorc) , inout

Deallocate all blocks and the arrays of the qtensorc.

Source Code

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

qTensors_f90.destroy_qtensorlist()

fortran-subroutine - January 2016 (update dj) Destroy a list of qtensor.

Arguments

MatsTYPE(qtensorlist) , inout

Deallocate the array of matrixs (including each matrix).

Source Code

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

qTensors_f90.destroy_qtensorclist()

fortran-subroutine - January 2016 (update dj) Destroy a list of qtensorc.

Arguments

MatsTYPE(qtensorclist) , inout

Deallocate the array of matrixs (including each matrix).

Source Code

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

qTensors_f90.dot_qtensor()

fortran-function - March 2016 (update dj) Compute dot product <A, B> for qtensor. details (template defined in qTensors_include.f90)

Arguments

QtaTYPE(qtensor), inout

First vector in the dot product (taken with complex conjugated values for complex arrays).

QtbTYPE(qtensor), inout

Second vector in the dot product. Has to be the same size as first vector.

Source Code

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

qTensors_f90.dot_qtensorc()

fortran-function - March 2016 (update dj) Compute dot product <A, B> for qtensorc. details (template defined in qTensors_include.f90)

Arguments

QtaTYPE(qtensorc), inout

First vector in the dot product (taken with complex conjugated values for complex arrays).

QtbTYPE(qtensorc), inout

Second vector in the dot product. Has to be the same size as first vector.

Source Code

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

qTensors_f90.expm_qtensor_real_qtensor()

fortran-subroutine - ?? (dj) Take the exponential of a tensor assuming an underlying matrix.

Arguments

TexpTYPE(qtensor), out

This is on exit the exponetial. Has rank and dimensions of the input tensor.

screal, in

Additional scalar inside exp-function.

TensTYPE(qtensor), inout

Take the exponential of this tensor.

last_row_idxINTEGER, 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

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

qTensors_f90.expm_qtensorc_real_qtensor()

fortran-subroutine - ?? (dj) Take the exponential of a tensor assuming an underlying matrix.

Arguments

TexpTYPE(qtensorc), out

This is on exit the exponetial. Has rank and dimensions of the input tensor.

screal, in

Additional scalar inside exp-function.

TensTYPE(qtensor), inout

Take the exponential of this tensor.

last_row_idxINTEGER, 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

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

qTensors_f90.expm_qtensorc_complex_qtensor()

fortran-subroutine - ?? (dj) Take the exponential of a tensor assuming an underlying matrix.

Arguments

TexpTYPE(qtensorc), out

This is on exit the exponetial. Has rank and dimensions of the input tensor.

sccomplex, in

Additional scalar inside exp-function.

TensTYPE(qtensor), inout

Take the exponential of this tensor.

last_row_idxINTEGER, 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

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

qTensors_f90.expm_qtensorc_real_qtensorc()

fortran-subroutine - ?? (dj) Take the exponential of a tensor assuming an underlying matrix.

Arguments

TexpTYPE(qtensorc), out

This is on exit the exponetial. Has rank and dimensions of the input tensor.

screal, in

Additional scalar inside exp-function.

TensTYPE(qtensorc), inout

Take the exponential of this tensor.

last_row_idxINTEGER, 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

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

qTensors_f90.expm_qtensorc_complex_qtensorc()

fortran-subroutine - ?? (dj) Take the exponential of a tensor assuming an underlying matrix.

Arguments

TexpTYPE(qtensorc), out

This is on exit the exponetial. Has rank and dimensions of the input tensor.

sccomplex, in

Additional scalar inside exp-function.

TensTYPE(qtensorc), inout

Take the exponential of this tensor.

last_row_idxINTEGER, 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

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

qTensors_f90.expmh_real_qtensor()

fortran-subroutine - ?? (dj) Take the exponential of a tensor assuming an underlying hermitian matrix.

Arguments

TexpTYPE(qtensor), out

This is on exit the exponetial. Has rank and dimensions of the input tensor.

screal, in

Additional scalar inside exp-function.

TensTYPE(qtensor), inout

Take the exponential of this tensor.

last_row_idxINTEGER, 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

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

qTensors_f90.expmh_complex_qtensor()

fortran-subroutine - ?? (dj) Take the exponential of a tensor assuming an underlying hermitian matrix.

Arguments

TexpTYPE(qtensorc), out

This is on exit the exponetial. Has rank and dimensions of the input tensor.

sccomplex, in

Additional scalar inside exp-function.

TensTYPE(qtensor), inout

Take the exponential of this tensor.

last_row_idxINTEGER, 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

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

qTensors_f90.expmh_real_qtensorc()

fortran-subroutine - ?? (dj) Take the exponential of a tensor assuming an underlying hermitian matrix.

Arguments

TexpTYPE(qtensorc), out

This is on exit the exponetial. Has rank and dimensions of the input tensor.

screal, in

Additional scalar inside exp-function.

TensTYPE(qtensorc), inout

Take the exponential of this tensor.

last_row_idxINTEGER, 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

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

qTensors_f90.expmh_complex_qtensorc()

fortran-subroutine - ?? (dj) Take the exponential of a tensor assuming an underlying hermitian matrix.

Arguments

TexpTYPE(qtensorc), out

This is on exit the exponetial. Has rank and dimensions of the input tensor.

sccomplex, in

Additional scalar inside exp-function.

TensTYPE(qtensorc), inout

Take the exponential of this tensor.

last_row_idxINTEGER, 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

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

qTensors_f90.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

QtTYPE(qtensor), inout

qTensor which should be checked for its capacity.

nnINTEGER, in

Number of new elements to be stored in the qTensor.

Source Code

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

qTensors_f90.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

QtTYPE(qtensorc), inout

qTensor which should be checked for its capacity.

nnINTEGER, in

Number of new elements to be stored in the qTensor.

Source Code

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

qTensors_f90.fuse_all_qtensor()

fortran-subroutine - October 2017 (dj) Fuse equally sized subsets of links containing in total all links in the tensor.

Arguments

QtTYPE(qtensor), inout

Fuse links in this tensor.

idxINTEGER(*, *), in

Each column is merged together. ii-th column is ii-th new index.

methodCHARACTER, 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

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

qTensors_f90.fuse_all_qtensorc()

fortran-subroutine - October 2017 (dj) Fuse equally sized subsets of links containing in total all links in the tensor.

Arguments

QtTYPE(qtensorc), inout

Fuse links in this tensor.

idxINTEGER(*, *), in

Each column is merged together. ii-th column is ii-th new index.

methodCHARACTER, 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

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

qTensors_f90.gaxpy_qtensor_real_qtensor()

fortran-subroutine - ?? (mlw) Y = Y + a * X for REAL_OR_COMPLEX a details (template defined in qTensors_include.f90)

Arguments

YyTYPE(qtensor), inout

On entry, qtensor. On exit, other qtensor times scalar added to this qtensor. (No duplicates allowed for hashing quantum numbers.)

scREAL_OR_COMPLEX, in

Scalar multiplied with X.

XxTYPE(TENSOR_TYPE), inout

qtensor added to tensor Y. Is scaled with constant sc. (No duplicates allowed for hashing quantum numbers.)

Source Code

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

qTensors_f90.gaxpy_qtensorc_complex_qtensorc()

fortran-subroutine - ?? (mlw) Y = Y + a * X for REAL_OR_COMPLEX a details (template defined in qTensors_include.f90)

Arguments

YyTYPE(qtensorc), inout

On entry, qtensorc. On exit, other qtensorc times scalar added to this qtensorc. (No duplicates allowed for hashing quantum numbers.)

scREAL_OR_COMPLEX, in

Scalar multiplied with X.

XxTYPE(TENSOR_TYPE), inout

qtensorc added to tensor Y. Is scaled with constant sc. (No duplicates allowed for hashing quantum numbers.)

Source Code

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

qTensors_f90.gaxpy_qtensorc_real_qtensor()

fortran-subroutine - ?? (mlw) Y = Y + a * X for REAL_OR_COMPLEX a details (template defined in qTensors_include.f90)

Arguments

YyTYPE(qtensor), inout

On entry, qtensor. On exit, other qtensor times scalar added to this qtensor. (No duplicates allowed for hashing quantum numbers.)

scREAL_OR_COMPLEX, in

Scalar multiplied with X.

XxTYPE(TENSOR_TYPE), inout

qtensor added to tensor Y. Is scaled with constant sc. (No duplicates allowed for hashing quantum numbers.)

Source Code

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

qTensors_f90.gaxpy_qtensorc_complex_qtensor()

fortran-subroutine - ?? (mlw) Y = Y + a * X for REAL_OR_COMPLEX a details (template defined in qTensors_include.f90)

Arguments

YyTYPE(qtensor), inout

On entry, qtensor. On exit, other qtensor times scalar added to this qtensor. (No duplicates allowed for hashing quantum numbers.)

scREAL_OR_COMPLEX, in

Scalar multiplied with X.

XxTYPE(TENSOR_TYPE), inout

qtensor added to tensor Y. Is scaled with constant sc. (No duplicates allowed for hashing quantum numbers.)

Source Code

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

qTensors_f90.gaxpy_qtensorc_real_qtensorc()

fortran-subroutine - ?? (mlw) Y = Y + a * X for REAL_OR_COMPLEX a details (template defined in qTensors_include.f90)

Arguments

YyTYPE(qtensorc), inout

On entry, qtensorc. On exit, other qtensorc times scalar added to this qtensorc. (No duplicates allowed for hashing quantum numbers.)

scREAL_OR_COMPLEX, in

Scalar multiplied with X.

XxTYPE(TENSOR_TYPE), inout

qtensorc added to tensor Y. Is scaled with constant sc. (No duplicates allowed for hashing quantum numbers.)

Source Code

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

qTensors_f90.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

QtensTYPE(qtensor), in

Get the maximal dimension of the 3rd leg. Explanation how to do this with q-tensor should go here ….

Source Code

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

qTensors_f90.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

QtensTYPE(qtensorc), in

Get the maximal dimension of the 3rd leg. Explanation how to do this with q-tensor should go here ….

Source Code

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

qTensors_f90.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

QtaTYPE(qtensor), in

First tensor for contraction.

idxaINTEGER(*), in

The following legs in Qta should be contracted over.

QtbTYPE(qtensor), in

Second tensor for contraction.

idxbINTEGER(*), in

The following legs in Qtb should be contracted over.

degLOGICAL(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.

cidxINTEGER(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.

niuniqueINTEGER, out

Number of unique matches found. To execute contraction, loop to cidx(:, degout(niunique + 1)).

degoutINTEGER(*), 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.

qqqINTEGER(*, *), 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_degoutLOGICAL, 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 the size of the smaller array and the size of the bigger array, it scales as . Sorting both arrays and then looking for matches scales approximately with . For degeneracies, it might depend on the number of unique hashes, which is not predictable beforehand.

Source Code

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

qTensors_f90.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

QtaTYPE(qtensorc), in

First tensor for contraction.

idxaINTEGER(*), in

The following legs in Qta should be contracted over.

QtbTYPE(qtensorc), in

Second tensor for contraction.

idxbINTEGER(*), in

The following legs in Qtb should be contracted over.

degLOGICAL(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.

cidxINTEGER(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.

niuniqueINTEGER, out

Number of unique matches found. To execute contraction, loop to cidx(:, degout(niunique + 1)).

degoutINTEGER(*), 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.

qqqINTEGER(*, *), 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_degoutLOGICAL, 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 the size of the smaller array and the size of the bigger array, it scales as . Sorting both arrays and then looking for matches scales approximately with . For degeneracies, it might depend on the number of unique hashes, which is not predictable beforehand.

Source Code

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

qTensors_f90.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

QtaTYPE(qtensorc), in

First tensor for contraction.

idxaINTEGER(*), in

The following legs in Qta should be contracted over.

QtbTYPE(qtensor), in

Second tensor for contraction.

idxbINTEGER(*), in

The following legs in Qtb should be contracted over.

degLOGICAL(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.

cidxINTEGER(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.

niuniqueINTEGER, out

Number of unique matches found. To execute contraction, loop to cidx(:, degout(niunique + 1)).

degoutINTEGER(*), 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.

qqqINTEGER(*, *), 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_degoutLOGICAL, 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 the size of the smaller array and the size of the bigger array, it scales as . Sorting both arrays and then looking for matches scales approximately with . For degeneracies, it might depend on the number of unique hashes, which is not predictable beforehand.

Source Code

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

qTensors_f90.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

QtaTYPE(qtensor), in

First tensor for contraction.

idxaINTEGER(*), in

The following legs in Qta should be contracted over.

QtbTYPE(qtensorc), in

Second tensor for contraction.

idxbINTEGER(*), in

The following legs in Qtb should be contracted over.

degLOGICAL(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.

cidxINTEGER(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.

niuniqueINTEGER, out

Number of unique matches found. To execute contraction, loop to cidx(:, degout(niunique + 1)).

degoutINTEGER(*), 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.

qqqINTEGER(*, *), 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_degoutLOGICAL, 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 the size of the smaller array and the size of the bigger array, it scales as . Sorting both arrays and then looking for matches scales approximately with . For degeneracies, it might depend on the number of unique hashes, which is not predictable beforehand.

Source Code

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

qTensors_f90.get_hash_qtensor()

fortran-function - October 2016 (dj) Get the hashes of specified indices of a qtensor.

Arguments

QtensTYPE(qtensor), inout

The values of the hashes are set according to the new indices.

idxsINTEGER(*), in

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

iiINTEGER, OPTIONAL, in

Specify index in terms of array of tensors for generating new hash. If not present, all tensors are set again.

Source Code

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

qTensors_f90.get_hash_qtensorc()

fortran-function - October 2016 (dj) Get the hashes of specified indices of a qtensorc.

Arguments

QtensTYPE(qtensorc), inout

The values of the hashes are set according to the new indices.

idxsINTEGER(*), in

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

iiINTEGER, OPTIONAL, in

Specify index in terms of array of tensors for generating new hash. If not present, all tensors are set again.

Source Code

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

qTensors_f90.get_hash_ii_qtensor()

fortran-function - October 2016 (dj) Get the hash of specified indices of a qtensor.

Arguments

QtensTYPE(qtensor), inout

The values of the hashes are set according to the new indices.

idxsINTEGER(*), in

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

iiINTEGER, in

Specify index in terms of array of tensors for generating new hash.

Source Code

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

qTensors_f90.get_hash_ii_qtensorc()

fortran-function - October 2016 (dj) Get the hash of specified indices of a qtensorc.

Arguments

QtensTYPE(qtensorc), inout

The values of the hashes are set according to the new indices.

idxsINTEGER(*), in

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

iiINTEGER, in

Specify index in terms of array of tensors for generating new hash.

Source Code

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

qTensors_f90.get_scalar_qtensor()

fortran-function - July 2017 (dj) Get the scalar if the tensor represents a rank-0 tensor.

Arguments

QtensTYPE(qtensor), in

Return the scalar entry of a rank-0 tensor.

Source Code

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

qTensors_f90.get_scalar_qtensorc()

fortran-function - July 2017 (dj) Get the scalar if the tensor represents a rank-0 tensor.

Arguments

QtensTYPE(qtensorc), in

Return the scalar entry of a rank-0 tensor.

Source Code

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

qTensors_f90.get_sum_idx_qtensor()

fortran-subroutine - Calculate which tensors have the same hash for selected indices.

Arguments

Source Code

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

qTensors_f90.get_sum_idx_qtensorc()

fortran-subroutine - Arguments Calculate which tensors have the same hash for selected indices.

Source Code

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

qTensors_f90.has_nan_qtensor()

fortran-function - October 2017 (dj)

Arguments Check if the tensor has NAN in the actual arrays.

TensTYPE(TENSOR_TYPE), in

Check NAN on the entries of its subtensors. Check does not apply to rank, dimensions, quantum numbers, etc.

Source Code

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

qTensors_f90.has_nan_qtensorc()

fortran-function - October 2017 (dj) Check if the tensor has NAN in the actual arrays.

Arguments

TensTYPE(TENSOR_TYPE), in

Check NAN on the entries of its subtensors. Check does not apply to rank, dimensions, quantum numbers, etc.

Source Code

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

qTensors_f90.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

QtTYPE(qtensor), inout

Increase the number of possible blocks stored in this tensor V.

capacityINTEGER, in

Maximum of capacity and growth rate times the old capacity is taken as new capacity.

Source Code

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

qTensors_f90.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

QtTYPE(qtensorc), inout

Increase the number of possible blocks stored in this tensor V.

capacityINTEGER, in

Maximum of capacity and growth rate times the old capacity is taken as new capacity.

Source Code

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

qTensors_f90.is_eye_qtensor()

fortran-function - August 2017 (dj) Check if the tensor is an identity.

Arguments

TensTYPE(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

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

qTensors_f90.is_eye_qtensorc()

fortran-function - August 2017 (dj) Check if the tensor is an identity.

Arguments

TensTYPE(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

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

qTensors_f90.is_set_qtensor()

fortran-function - August 2017 (dj) Check if a qtensor is in use.

Arguments

QtTYPE(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

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

qTensors_f90.is_set_qtensorc()

fortran-function - August 2017 (dj) Check if a qtensor is in use.

Arguments

QtTYPE(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

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

qTensors_f90.kron_qtensor_qtensor()

fortran-subroutine -

Details

For qtensor, the restriction is to rank-2 tensors and no transformations.

Source Code

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

qTensors_f90.kron_qtensorc_qtensorc()

fortran-subroutine -

Details

For qtensorc, the restriction is to rank-2 tensors and no transformations.

Source Code

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

qTensors_f90.kron_qtensorc_qtensor()

fortran-subroutine -

Details

For qtensor, the restriction is to rank-2 tensors and no transformations.

Source Code

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

qTensors_f90.maxlineardim_qtensor()

fortran-function - June 2017 (updated dj)

Arguments

TensTYPE(qtensor), in

Get the maximal dimension of this tensor.

idxINTEGER(*), 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

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

qTensors_f90.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

TensTYPE(qtensorc), in

Get the maximal dimension of this tensor.

idxINTEGER(*), in

Search only over these indices of the rank-n tensor.

Source Code

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

qTensors_f90.maxvalue_qtensor()

fortran-function - June 2017 (dj) Find the maximal entry in the tensor.

Arguments

TensTYPE(qtensor), in

Find maximal entry in this tensor across all subtensors. For complex tensors, the absolute value is considered.

Source Code

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

qTensors_f90.maxvalue_qtensorc()

fortran-function - June 2017 (dj) Find the maximal entry in the tensor.

Arguments

TensTYPE(qtensorc), in

Find maximal entry in this tensor across all subtensors. For complex tensors, the absolute value is considered.

Source Code

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

qTensors_f90.norm_qtensor()

fortran-function - ?? (mlw) Calculate the norm of the qtensor as <A,A>. details (template defined in qTensors_include.f90)

Arguments

QtTYPE(qtensor), in

Get norm of the qtensor.

Source Code

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

qTensors_f90.norm_qtensorc()

fortran-function - ?? (mlw) Calculate the norm of the qtensorc as <A,A>. details (template defined in qTensors_include.f90)

Arguments

QtTYPE(qtensorc), in

Get norm of the qtensorc.

Source Code

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

qTensors_f90.permute_qnumbers_qtensor()

fortran-subroutine - November 2016 (dj) Permute the quantum numbers; necessary when permuting the legs of the tensors.

Arguments

TensTYPE(qtensor), inout

Save a transposition/permutation on the indices of this tensor.

permINTEGER(*), 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

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

qTensors_f90.permute_qnumbers_qtensorc()

fortran-subroutine - November 2016 (dj) Permute the quantum numbers; necessary when permuting the legs of the tensors.

Arguments

TensTYPE(qtensorc), inout

Save a transposition/permutation on the indices of this tensor.

permINTEGER(*), 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

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

qTensors_f90.perturb_qtensor()

fortran-subroutine - December 2018 (dj) Perturb a tensor by a some small epsilon, entry-by-entry.

Arguments

TensTYPE(qtensor), inout

Tensor to be perturbed..

epsilonreal, OPTIONAL, in

Scale a randomized tensor by epsilon and add to original tensor. Default to 1e-8

Source Code

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

qTensors_f90.perturb_qtensorc()

fortran-subroutine - December 2018 (dj) Perturb a tensor by a some small epsilon, entry-by-entry.

Arguments

TensTYPE(qtensorc), inout

Tensor to be perturbed..

epsilonreal, OPTIONAL, in

Scale a randomized tensor by epsilon and add to original tensor. Default to 1e-8

Source Code

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

qTensors_f90.pointto_qtensor()

fortran-subroutine - March 2018 (dj) Copy Objb to Obja by setting the pointers and nullify Objb.

Arguments

ObjaTYPE(qtensor), inout

On exit, it contains the same information as Objb

ObjbTYPE(qtensor), inout

Empty on exit.

Source Code

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

qTensors_f90.pointto_qtensorc()

fortran-subroutine - March 2018 (dj) Copy Objb to Obja by setting the pointers and nullify Objb.

Arguments

ObjaTYPE(qtensorc), inout

On exit, it contains the same information as Objb

ObjbTYPE(qtensorc), inout

Empty on exit.

Source Code

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

qTensors_f90.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

ObjaTYPE(qtensorc), inout

On exit, it contains the same information as Objb

ObjbTYPE(qtensor), inout

Empty on exit.

Source Code

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

qTensors_f90.print_qtensor()

fortran-subroutine - ?? () Write dimension and non-zero entries to standard out (6) via write_qtensor. (deprecated, use directly write_qtensor) details (template defined in qTensors_include.f90)

Arguments

QtQTYPE(TENSOR_TYPE), in

Write this q-tensor to standard out (dimensions, non-zero entries)

Source Code

show / hide f90 code

  subroutine print_qtensor(Qt, errst)
      type(qtensor), intent(in) :: Qt
      integer, intent(out), optional :: errst

      call write_qtensor(Qt, 6, "6", errst=errst)
      !if(prop_error('print_qtensor: write failed', &
      !              errst=errst)) return

  end subroutine print_qtensor

qTensors_f90.print_qtensorc()

fortran-subroutine - ?? () Write dimension and non-zero entries to standard out (6) via write_qtensorc. (deprecated, use directly write_qtensorc) details (template defined in qTensors_include.f90)

Arguments

QtQTYPE(TENSOR_TYPE), in

Write this q-tensor to standard out (dimensions, non-zero entries)

Source Code

show / hide f90 code

  subroutine print_qtensorc(Qt, errst)
      type(qtensorc), intent(in) :: Qt
      integer, intent(out), optional :: errst

      call write_qtensorc(Qt, 6, "6", errst=errst)
      !if(prop_error('print_qtensorc: write failed', &
      !              errst=errst)) return

  end subroutine print_qtensorc

qTensors_f90.project_qtensor()

fortran-subroutine - March 2016 (updated dj) Apply the projector P to Aa and store in Bb, where P is defined as

Arguments

QtbTYPE(qtensor), out

Store projection of A in this tensor.

QtaTYPE(qtensor), inout

Get projection of this tensor.

PsiProjsTYPE(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

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

qTensors_f90.project_qtensorc()

fortran-subroutine - March 2016 (updated dj) Apply the projector P to Aa and store in Bb, where P is defined as

Arguments

QtbTYPE(qtensorc), out

Store projection of A in this tensor.

QtaTYPE(qtensorc), inout

Get projection of this tensor.

PsiProjsTYPE(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

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

qTensors_f90.qmattomat_qtensor()

fortran-subroutine - November 2017 (dj, update) Transform a qtensor to a tensor assuming that all links are a local Hilbert space.

Arguments

ToutTYPE(tensor), inout

Tensor without symmetry-adapted space.

TinTYPE(qtensor), in

Tensor in symmetry-adapted space to be written a normal tensor.

ImapperTYPE(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

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

qTensors_f90.qmattomat_qtensorc()

fortran-subroutine - November 2017 (dj, update) Transform a qtensorc to a tensorc assuming that all links are a local Hilbert space.

Arguments

ToutTYPE(tensorc), inout

Tensor without symmetry-adapted space.

TinTYPE(qtensorc), in

Tensor in symmetry-adapted space to be written a normal tensor.

ImapperTYPE(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

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

qTensors_f90.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

QtTYPE(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

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

qTensors_f90.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

QtTYPE(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

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

qTensors_f90.rank_qtensor()

fortran-function - June 2017 (dj) Return the rank of a tensor.

Arguments

TensTYPE(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

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

qTensors_f90.rank_qtensorc()

fortran-function - June 2017 (dj) Return the rank of a tensor.

Arguments

TensTYPE(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

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

qTensors_f90.read_qtensor()

fortran-subroutine - August 2015 (dj) Read a q-tensor from a given unit.

Arguments

QtensTYPE(qtensor), out

will be read from given destination.

unitINTEGER, in

read from this unit

formCHARACTER, 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

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

qTensors_f90.read_qtensorc()

fortran-subroutine - August 2015 (dj) Read a q-tensor from a given unit.

Arguments

QtensTYPE(qtensorc), out

will be read from given destination.

unitINTEGER, in

read from this unit

formCHARACTER, 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

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

qTensors_f90.scale_qtensor_real()

fortran-subroutine - ?? (mlw) Scale qtensor by real details (template defined in qTensors_include.f90)

Arguments

screal, in

Scalar to be multiplied with vector.

QtTYPE(qtensor), inout

To be scaled with scalar.

Source Code

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

qTensors_f90.scale_qtensorc_complex()

fortran-subroutine - ?? (mlw) Scale qtensorc by complex details (template defined in qTensors_include.f90)

Arguments

sccomplex, in

Scalar to be multiplied with vector.

QtTYPE(qtensorc), inout

To be scaled with scalar.

Source Code

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

qTensors_f90.scale_qtensorc_real()

fortran-subroutine - ?? (mlw) Scale qtensorc by real details (template defined in qTensors_include.f90)

Arguments

screal, in

Scalar to be multiplied with vector.

QtTYPE(qtensorc), inout

To be scaled with scalar.

Source Code

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

qTensors_f90.set_hash_qtensor()

fortran-subroutine - October 2016 (dj) Set the hashes of specified indices of the qtensor in its internal structure.

Arguments

QtensTYPE(qtensor), inout

The values of the hashes are set according to the new indices.

idxsINTEGER(*), in

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

iiINTEGER, OPTIONAL, in

Specify index in terms of array of tensors for generating new hash. If not present, all tensors are set again.

Source Code

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

qTensors_f90.set_hash_qtensorc()

fortran-subroutine - October 2016 (dj) Set the hashes of specified indices of the qtensorc in its internal structure.

Arguments

QtensTYPE(qtensorc), inout

The values of the hashes are set according to the new indices.

idxsINTEGER(*), in

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

iiINTEGER, OPTIONAL, in

Specify index in terms of array of tensors for generating new hash. If not present, all tensors are set again.

Source Code

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

qTensors_f90.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

QtQTYPE(TENSOR_TYPE), in

Get number of used blocks in the qtensor.

Source Code

show / hide f90 code

  function size_qtensor(Qt) result(siz)
      type(qtensor) :: Qt
      integer :: siz

      siz = Qt%nb

  end function size_qtensor

qTensors_f90.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

QtQTYPE(TENSOR_TYPE), in

Get number of used blocks in the qtensorc.

Source Code

show / hide f90 code

  function size_qtensorc(Qt) result(siz)
      type(qtensorc) :: Qt
      integer :: siz

      siz = Qt%nb

  end function size_qtensorc

qTensors_f90.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

QtTYPE(qtensor), inout

Eliminate all blocks which do not contribute more than a fraction err to the norm.

errREAL, in

Criteria for each block; contribution to complete norm must be greater than the fraction err.

Source Code

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

qTensors_f90.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

QtTYPE(qtensorc), inout

Eliminate all blocks which do not contribute more than a fraction err to the norm.

errREAL, in

Criteria for each block; contribution to complete norm must be greater than the fraction err.

Source Code

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

qTensors_f90.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

QtTYPE(qtensor), inout

Eliminate all blocks which are not marked by the user.

nkeepINTEGER, in

Number of irreps kept.

idxkeepINTEGER(*), in

The indices of the irreps to be kept.

Source Code

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

qTensors_f90.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

QtTYPE(qtensorc), inout

Eliminate all blocks which are not marked by the user.

nkeepINTEGER, in

Number of irreps kept.

idxkeepINTEGER(*), in

The indices of the irreps to be kept.

Source Code

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

qTensors_f90.sort_qtensor()

fortran-subroutine - ?? (mlw) Sort a qtensor in ascending order of its current hashes. details (template defined in qTensors_include.f90)

Arguments

QtTYPE(qtensor), inout

The order of blocks will be changed according to the present hashes.

Source Code

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

qTensors_f90.sort_qtensorc()

fortran-subroutine - ?? (mlw) Sort a qtensor in ascending order of its current hashes. details (template defined in qTensors_include.f90)

Arguments

QtTYPE(qtensorc), inout

The order of blocks will be changed according to the present hashes.

Source Code

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

qTensors_f90.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

QtTYPE(qtensor), inout

Split one link in this tensor.

idxINTEGER, in

Index of the link to be splitted.

SlTYPE(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

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

qTensors_f90.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

QtTYPE(qtensorc), inout

Split one link in this tensor.

idxINTEGER, in

Index of the link to be splitted.

SlTYPE(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

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

qTensors_f90.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

QtTYPE(qtensor), inout

Split all links of this tensor.

SlsTYPE(splitlink)(*), in

Information how to split each link in the current tensor.

Source Code

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

qTensors_f90.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

QtTYPE(qtensorc), inout

Split all links of this tensor.

SlsTYPE(splitlink)(*), in

Information how to split each link in the current tensor.

Source Code

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

qTensors_f90.trace_qtensor()

fortran-function - June 2017 (dj) Returns the trace for rank-2 tensors.

Arguments

TensTYPE(qtensor), in

Calculate the trace assuming it is a rank-2 tensor.

Source Code

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

qTensors_f90.trace_qtensorc()

fortran-function - June 2017 (dj) Returns the trace for rank-2 tensors.

Arguments

TensTYPE(qtensorc), in

Calculate the trace assuming it is a rank-2 tensor.

Source Code

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

qTensors_f90.transposed_qtensor()

fortran-subroutine - July 2016 (dj) Transposition of indices or permutation.

Arguments

TensTYPE(qtensor), inout

Save a transposition/permutation on the indices of this tensor.

permINTEGER(*), 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)

dopermLOGICAL, 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

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

qTensors_f90.transposed_qtensorc()

fortran-subroutine - July 2016 (dj) Transposition of indices or permutation.

Arguments

TensTYPE(qtensorc), inout

Save a transposition/permutation on the indices of this tensor.

permINTEGER(*), 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)

dopermLOGICAL, 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

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

qTensors_f90.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

QtensTYPE(qtensor), in

will be written to given destination.

unitINTEGER, in

write on this unit

formCHARACTER, 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

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

qTensors_f90.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

QtensTYPE(qtensorc), in

will be written to given destination.

unitINTEGER, in

write on this unit

formCHARACTER, 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

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

qTensors_f90.create_splitlink_qtensor()

fortran-subroutine - October 2017 (dj) Create a splitlink object from the identity matrix.

Arguments

SlTYPE(splitlink), inout

Fill this splitlink object with the splitting for an identity matrix.

IdopTYPE(TENSOR_TYPE), in

The dimension is taken from the identity to create the splitlink object.

Source Code

show / hide f90 code

  subroutine create_splitlink_qtensor(Sl, Idop)
      type(splitlink), intent(inout) :: Sl
      type(qtensor), intent(in) :: Idop

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

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

      ! temporary tensors for Kronecker and fusing
      type(qtensor) :: Qa, Qb, Qc

      call copy(Qa, Idop)
      call copy(Qb, Qa)

      call kron(Qc, Qa, Qb, 1, 1, 'N', 'N', 'N')
      call destroy(Qa)
      call destroy(Qb)

      call init(Sl, Qc, [1, 2])

      fidx(:, 1) = [1, 2]
      fidx(:, 2) = [3, 4]
      call fuse(Qc, fidx, '0')

      call finalize(Sl, Qc, 1)

      call destroy(Qc)

  end subroutine create_splitlink_qtensor

qTensors_f90.create_splitlink_qtensorc()

fortran-subroutine - October 2017 (dj) Create a splitlink object from the identity matrix.

Arguments

SlTYPE(splitlink), inout

Fill this splitlink object with the splitting for an identity matrix.

IdopTYPE(TENSOR_TYPE), in

The dimension is taken from the identity to create the splitlink object.

Source Code

show / hide f90 code

  subroutine create_splitlink_qtensorc(Sl, Idop)
      type(splitlink), intent(inout) :: Sl
      type(qtensorc), intent(in) :: Idop

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

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

      ! temporary tensors for Kronecker and fusing
      type(qtensorc) :: Qa, Qb, Qc

      call copy(Qa, Idop)
      call copy(Qb, Qa)

      call kron(Qc, Qa, Qb, 1, 1, 'N', 'N', 'N')
      call destroy(Qa)
      call destroy(Qb)

      call init(Sl, Qc, [1, 2])

      fidx(:, 1) = [1, 2]
      fidx(:, 2) = [3, 4]
      call fuse(Qc, fidx, '0')

      call finalize(Sl, Qc, 1)

      call destroy(Qc)

  end subroutine create_splitlink_qtensorc

qTensors_f90.init_splitlink_qtensor()

fortran-subroutine - October 2017 (dj) Store dimension for splitting a link. The quantum numbers on that link must stay the same.

Arguments

SlTYPE(splitlink), inout

Object storing the dimensions for each hash.

TensTYPE(qtensor), in

Tensor to be fused in the following.

idxINTEGER(*), in

Indices to be fused in the tensor Tens.

Source Code

show / hide f90 code

  subroutine init_splitlink_qtensor(Sl, Tens, idx, errst)
      type(splitlink), intent(inout) :: Sl
      type(qtensor), intent(in) :: Tens
      integer, dimension(:), intent(in) :: idx
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! example for representation
      integer :: i1

      ! number of links fused
      integer :: nn

      ! number of blocks
      integer :: mm

      ! for degenerate sorting
      real(KIND=rKind), dimension(:), allocatable :: hash, littlehash
      integer :: nunique
      integer, dimension(:), allocatable :: ind, deg

      !if(present(errst)) errst = 0

      nn = size(idx, 1)
      mm = Tens%nb

      allocate(hash(mm), littlehash(mm), ind(mm), deg(mm + 1))

      hash = get_hash(Tens, [idx])

      call ascending_hsort(hash, littlehash, ind, nunique, deg, errst=errst)
      !if(prop_error('create_splitlink_qtensor : ascending_'//&
      !               'hsort failed.', 'qTensors_include.f90:6234', errst=errst)) return

      allocate(Sl%hashes(nunique), Sl%dims(nn, nunique))

      do ii = 1, nunique
          i1 = ind(deg(ii) + 1)

          Sl%dims(:, ii) = Tens%Data(i1)%Tens%dl(idx)
          Sl%hashes(ii) = i1
      end do

      deallocate(hash, littlehash, ind, deg)

  end subroutine init_splitlink_qtensor

qTensors_f90.init_splitlink_qtensorc()

fortran-subroutine - October 2017 (dj) Store dimension for splitting a link. The quantum numbers on that link must stay the same.

Arguments

SlTYPE(splitlink), inout

Object storing the dimensions for each hash.

TensTYPE(qtensorc), in

Tensor to be fused in the following.

idxINTEGER(*), in

Indices to be fused in the tensor Tens.

Source Code

show / hide f90 code

  subroutine init_splitlink_qtensorc(Sl, Tens, idx, errst)
      type(splitlink), intent(inout) :: Sl
      type(qtensorc), intent(in) :: Tens
      integer, dimension(:), intent(in) :: idx
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! example for representation
      integer :: i1

      ! number of links fused
      integer :: nn

      ! number of blocks
      integer :: mm

      ! for degenerate sorting
      real(KIND=rKind), dimension(:), allocatable :: hash, littlehash
      integer :: nunique
      integer, dimension(:), allocatable :: ind, deg

      !if(present(errst)) errst = 0

      nn = size(idx, 1)
      mm = Tens%nb

      allocate(hash(mm), littlehash(mm), ind(mm), deg(mm + 1))

      hash = get_hash(Tens, [idx])

      call ascending_hsort(hash, littlehash, ind, nunique, deg, errst=errst)
      !if(prop_error('create_splitlink_qtensorc : ascending_'//&
      !               'hsort failed.', 'qTensors_include.f90:6234', errst=errst)) return

      allocate(Sl%hashes(nunique), Sl%dims(nn, nunique))

      do ii = 1, nunique
          i1 = ind(deg(ii) + 1)

          Sl%dims(:, ii) = Tens%Data(i1)%Tens%dl(idx)
          Sl%hashes(ii) = i1
      end do

      deallocate(hash, littlehash, ind, deg)

  end subroutine init_splitlink_qtensorc

qTensors_f90.finalize_splitlink_qtensor()

fortran-subroutine - October 2017 (dj) This is the second step when creating a splitlink object. It creates the hashes of the fused symmetry numbers.

Arguments

SlTYPE(splitlink), inout

On exit, complete splitlink object. On entry, the hashes are filled with the indices of the corresponding block.

TensTYPE(TENSOR_TYPE), in

The tensor which was fused.

idxINTEGER, in

Index of the new link, which has been fused.

Source Code

show / hide f90 code

  subroutine finalize_splitlink_qtensor(Sl, Tens, idx, errst)
      type(splitlink), intent(inout) :: Sl
      type(qtensor), intent(in) :: Tens
      integer, intent(in) :: idx
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! indices from sorting
      integer, dimension(:), allocatable :: ind

      ! copy for dimensions
      integer, dimension(:, :), allocatable :: dims

      do ii = 1, size(Sl%hashes, 1)
          Sl%hashes(ii) = get_hash(Tens, [idx], int(Sl%hashes(ii)))
      end do

      ! Hashes have to be sorted for `Findtagindex`, but I don't see any
      ! reason why they should be since abelian and discrete quantum numbers
      ! can be permuted. So they should be unique now.

      allocate(ind(size(Sl%hashes, 1)), dims(size(Sl%dims, 1), size(Sl%dims, 2)))

      call ascending_hsort(Sl%hashes, ind)
      Sl%hashes(ind) = Sl%hashes

      dims = Sl%dims

      do ii = 1, size(ind, 1)
          Sl%dims(:, ii) = dims(:, ind(ii))
      end do

      deallocate(ind, dims)

  end subroutine finalize_splitlink_qtensor

qTensors_f90.finalize_splitlink_qtensorc()

fortran-subroutine - October 2017 (dj) This is the second step when creating a splitlink object. It creates the hashes of the fused symmetry numbers.

Arguments

SlTYPE(splitlink), inout

On exit, complete splitlink object. On entry, the hashes are filled with the indices of the corresponding block.

TensTYPE(TENSOR_TYPE), in

The tensor which was fused.

idxINTEGER, in

Index of the new link, which has been fused.

Source Code

show / hide f90 code

  subroutine finalize_splitlink_qtensorc(Sl, Tens, idx, errst)
      type(splitlink), intent(inout) :: Sl
      type(qtensorc), intent(in) :: Tens
      integer, intent(in) :: idx
      integer, intent(out), optional :: errst

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

      ! for looping
      integer :: ii

      ! indices from sorting
      integer, dimension(:), allocatable :: ind

      ! copy for dimensions
      integer, dimension(:, :), allocatable :: dims

      do ii = 1, size(Sl%hashes, 1)
          Sl%hashes(ii) = get_hash(Tens, [idx], int(Sl%hashes(ii)))
      end do

      ! Hashes have to be sorted for `Findtagindex`, but I don't see any
      ! reason why they should be since abelian and discrete quantum numbers
      ! can be permuted. So they should be unique now.

      allocate(ind(size(Sl%hashes, 1)), dims(size(Sl%dims, 1), size(Sl%dims, 2)))

      call ascending_hsort(Sl%hashes, ind)
      Sl%hashes(ind) = Sl%hashes

      dims = Sl%dims

      do ii = 1, size(ind, 1)
          Sl%dims(:, ii) = dims(:, ind(ii))
      end do

      deallocate(ind, dims)

  end subroutine finalize_splitlink_qtensorc