"""
Fortran module ContractionOps: May 2017 (dj)
Containing contractions for tensors.
**Authors**
* D. Jaschke
* M. L. Wall
**Details**
The following subroutines / functions are defined in the
module as interfaces.
+-------------------------+
| Procedure |
+=========================+
| diag_times_mat |
+-------------------------+
| mat_times_diag |
+-------------------------+
| diag_contr_tensor |
+-------------------------+
| eigd |
+-------------------------+
| eigsvd |
+-------------------------+
| exp |
+-------------------------+
| exph |
+-------------------------+
| kron |
+-------------------------+
| trace_rho_x_mat |
+-------------------------+
"""
[docs]def contr_tensor():
"""
fortran-subroutine - November 2016 (dj)
Contraction of two different tensors.
**Arguments**
Tc : TYPE(tensor), inout
Result of the contractions as tensor.
Tl : TYPE(tensor), inout
Left tensor in contraction. Destroyed on output and should
be different from Tr since it can be operated on.
Tr : TYPE(tensor), inout
Right tensor in contraction. Destroyed on output and should
be different from Tl since it can be operated on.
idxl : INTEGER(\*), in
Contraction goes over the corresponding indices of the left tensor.
idxr : INTEGER(\*), in
Contraction goes over the corresponding indices of the right tensor.
transl : CHARACTER, OPTIONAL, in
'N' for nothing and 'C' for conjugating tensor (not daggered).
Default to 'N'. Transformation for left tensor.
transr : CHARACTER, OPTIONAL, in
'N' for nothing and 'C' for conjugating tensor (not daggered).
Default to 'N'. Transformation for right tensor.
permout : INTEGER(\*), OPTIONAL, in
Permutation on the output after the contraction.
alpha : real, OPTIONAL, in
Scale contraction.
beta : real, OPTIONAL, in
Add to existing tensor Tc scaled with beta.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine contr_tensor(Tc, Tl, Tr, idxl, idxr, transl, transr, &
permout, alpha, beta, errst)
type(tensor), intent(inout) :: Tc
type(tensor), intent(inout) :: Tl, Tr
integer, dimension(:), intent(in) :: idxl, idxr
character, intent(in), optional :: transl, transr
integer, dimension(:), intent(in), optional :: permout
real(KIND=rKind), intent(in), optional :: alpha, beta
integer, intent(out), optional :: errst
! Local variables
! ---------------
type(contrinfo) :: Cinfo
!if(present(errst)) errst = 0
call contr_meta_info(Cinfo, Tl, Tr, idxl, idxr, transl, transr, &
errst=errst)
!if(prop_error('contr_tensor: contr_meta_info failed.', &
! errst=errst)) return
call contr_prepl(Tl, Cinfo, errst=errst)
!if(prop_error('contr_tensor: contr_prepl failed.', &
! errst=errst)) return
call contr_prepr(Tr, Cinfo, errst=errst)
!if(prop_error('contr_tensor: contr_prepr failed.', &
! errst=errst)) return
call contr_exec(Tc, Tl, Tr, Cinfo, permout, alpha, beta, errst=errst)
!if(prop_error('contr_tensor: contr_prepr failed.', &
! errst=errst)) return
call destroy_contrinfo(Cinfo, errst=errst)
!if(prop_error('contr_tensor: destroy_contrinfo failed.', &
! errst=errst)) return
end subroutine contr_tensor
"""
return
[docs]def contr_tensorc():
"""
fortran-subroutine - November 2016 (dj)
Contraction of two different tensors.
**Arguments**
Tc : TYPE(tensorc), inout
Result of the contractions as tensor.
Tl : TYPE(tensorc), inout
Left tensor in contraction. Destroyed on output and should
be different from Tr since it can be operated on.
Tr : TYPE(tensorc), inout
Right tensor in contraction. Destroyed on output and should
be different from Tl since it can be operated on.
idxl : INTEGER(\*), in
Contraction goes over the corresponding indices of the left tensor.
idxr : INTEGER(\*), in
Contraction goes over the corresponding indices of the right tensor.
transl : CHARACTER, OPTIONAL, in
'N' for nothing and 'C' for conjugating tensor (not daggered).
Default to 'N'. Transformation for left tensor.
transr : CHARACTER, OPTIONAL, in
'N' for nothing and 'C' for conjugating tensor (not daggered).
Default to 'N'. Transformation for right tensor.
permout : INTEGER(\*), OPTIONAL, in
Permutation on the output after the contraction.
alpha : complex, OPTIONAL, in
Scale contraction.
beta : complex, OPTIONAL, in
Add to existing tensor Tc scaled with beta.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine contr_tensorc(Tc, Tl, Tr, idxl, idxr, transl, transr, &
permout, alpha, beta, errst)
type(tensorc), intent(inout) :: Tc
type(tensorc), intent(inout) :: Tl, Tr
integer, dimension(:), intent(in) :: idxl, idxr
character, intent(in), optional :: transl, transr
integer, dimension(:), intent(in), optional :: permout
complex(KIND=rKind), intent(in), optional :: alpha, beta
integer, intent(out), optional :: errst
! Local variables
! ---------------
type(contrinfo) :: Cinfo
!if(present(errst)) errst = 0
call contr_meta_info(Cinfo, Tl, Tr, idxl, idxr, transl, transr, &
errst=errst)
!if(prop_error('contr_tensorc: contr_meta_info failed.', &
! errst=errst)) return
call contr_prepl(Tl, Cinfo, errst=errst)
!if(prop_error('contr_tensorc: contr_prepl failed.', &
! errst=errst)) return
call contr_prepr(Tr, Cinfo, errst=errst)
!if(prop_error('contr_tensorc: contr_prepr failed.', &
! errst=errst)) return
call contr_exec(Tc, Tl, Tr, Cinfo, permout, alpha, beta, errst=errst)
!if(prop_error('contr_tensorc: contr_prepr failed.', &
! errst=errst)) return
call destroy_contrinfo(Cinfo, errst=errst)
!if(prop_error('contr_tensorc: destroy_contrinfo failed.', &
! errst=errst)) return
end subroutine contr_tensorc
"""
return
[docs]def destroy_contrinfo():
"""
fortran-subroutine - October 2017 (dj)
Destroy the meta information for a contraction.
**Arguments**
Cinfo : TYPE(contrinfo), inout
Deallocate arrays inside Cinfo.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine destroy_contrinfo(Cinfo, errst)
type(contrinfo), intent(inout) :: Cinfo
integer, intent(out), optional :: errst
! No local variables
! ------------------
!if(present(errst)) errst = 0
deallocate(Cinfo%lperm, Cinfo%rperm)
end subroutine destroy_contrinfo
"""
return
[docs]def contr_qtensor():
"""
fortran-subroutine - May 2017 (dj)
Contraction of two different tensors.
**Arguments**
Tc : TYPE(TENSOR_TYPE), inout
Result of the contractions as tensor.
Tl : TYPE(TENSOR_TYPE), inout
Left tensor in contraction. Destroyed on output and should
be different from Tr since it can be operated on.
Tr : TYPE(TENSOR_TYPE), inout
Right tensor in contraction. Destroyed on output and should
be different from Tl since it can be operated on.
idxl : INTEGER(\*), in
Contraction goes over the corresponding indices of the left tensor.
idxr : INTEGER(\*), in
Contraction goes over the corresponding indices of the right tensor.
transl : CHARACTER, OPTIONAL, in
'N' for nothing and 'C' for conjugating tensor (not daggered).
Default to 'N'. Transformation for left tensor.
transr : CHARACTER, OPTIONAL, in
'N' for nothing and 'C' for conjugating tensor (not daggered).
Default to 'N'. Transformation for right tensor.
permout : INTEGER(\*), OPTIONAL, in
Permutation on the output after the contraction.
alpha : real, OPTIONAL, in
Scale contraction.
beta : real, OPTIONAL, in
Add to existing tensor Tc scaled with beta.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine contr_qtensor(Tc, Tl, Tr, idxl, idxr, transl, transr, &
permout, alpha, beta, errst)
type(qtensor), intent(inout) :: Tc
type(qtensor), intent(inout) :: Tl, Tr
integer, dimension(:), intent(in) :: idxl, idxr
character, intent(in), optional :: transl, transr
integer, dimension(:), intent(in), optional :: permout
real(KIND=rKind), intent(in), optional :: alpha, beta
integer, intent(out), optional :: errst
! Local variables
! ---------------
! flag to check if beta = 0.0
logical :: betazero
! Temporary tensor for gaxpy
type(qtensor) :: Tens
!if(present(errst)) errst = 0
betazero = .true.
if(present(beta)) then
if(beta /= 0.0) betazero = .false.
end if
! Fast return
if(((Tl%nb == 0) .or. (Tr%nb == 0)) .and. betazero) then
! Have to create an empty tensor
call create(Tc, Tl%nqs, 0, errst=errst)
!if(prop_error('contr_qtensor: create failed.', &
! 'ContractionOps_include.f90:644', errst=errst)) return
return
elseif((Tl%nb == 0) .or. (Tr%nb == 0)) then
! The incoming tensor stays unmodified
return
end if
if(betazero) then
! Standard contraction
! ....................
call internal_contr_qtensor(Tc, Tl, Tr, idxl, idxr, &
transl, transr, permout, &
alpha, errst=errst)
!if(prop_error('contr_qtensor : internal_contr (1) '//&
! 'failed', 'ContractionOps_include.f90:660', errst=errst)) return
if(present(permout)) then
call permute_qnumbers(Tc, permout, errst=errst)
end if
else
! Contraction and addition only works with GAXPY
! ..............................................
call internal_contr_qtensor(Tens, Tl, Tr, idxl, idxr, &
transl, transr, permout, &
alpha=alpha, errst=errst)
!if(prop_error('contr_qtensor : internal_contr (2) '//&
! 'failed', 'ContractionOps_include.f90:673', errst=errst)) return
if(present(permout)) then
call permute_qnumbers(Tens, permout, errst=errst)
end if
if(beta /= done) call scale(beta, Tc)
call gaxpy(Tc, done, Tens, errst=errst)
!if(prop_error('contr_qtensor : gaxpy failed.', &
! 'ContractionOps_include.f90:683', errst=errst)) return
call destroy(Tens)
end if
end subroutine contr_qtensor
"""
return
[docs]def contr_qtensorc():
"""
fortran-subroutine - May 2017 (dj)
Contraction of two different tensors.
**Arguments**
Tc : TYPE(TENSOR_TYPE), inout
Result of the contractions as tensor.
Tl : TYPE(TENSOR_TYPE), inout
Left tensor in contraction. Destroyed on output and should
be different from Tr since it can be operated on.
Tr : TYPE(TENSOR_TYPE), inout
Right tensor in contraction. Destroyed on output and should
be different from Tl since it can be operated on.
idxl : INTEGER(\*), in
Contraction goes over the corresponding indices of the left tensor.
idxr : INTEGER(\*), in
Contraction goes over the corresponding indices of the right tensor.
transl : CHARACTER, OPTIONAL, in
'N' for nothing and 'C' for conjugating tensor (not daggered).
Default to 'N'. Transformation for left tensor.
transr : CHARACTER, OPTIONAL, in
'N' for nothing and 'C' for conjugating tensor (not daggered).
Default to 'N'. Transformation for right tensor.
permout : INTEGER(\*), OPTIONAL, in
Permutation on the output after the contraction.
alpha : complex, OPTIONAL, in
Scale contraction.
beta : complex, OPTIONAL, in
Add to existing tensor Tc scaled with beta.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine contr_qtensorc(Tc, Tl, Tr, idxl, idxr, transl, transr, &
permout, alpha, beta, errst)
type(qtensorc), intent(inout) :: Tc
type(qtensorc), intent(inout) :: Tl, Tr
integer, dimension(:), intent(in) :: idxl, idxr
character, intent(in), optional :: transl, transr
integer, dimension(:), intent(in), optional :: permout
complex(KIND=rKind), intent(in), optional :: alpha, beta
integer, intent(out), optional :: errst
! Local variables
! ---------------
! flag to check if beta = 0.0
logical :: betazero
! Temporary tensor for gaxpy
type(qtensorc) :: Tens
!if(present(errst)) errst = 0
betazero = .true.
if(present(beta)) then
if(beta /= 0.0) betazero = .false.
end if
! Fast return
if(((Tl%nb == 0) .or. (Tr%nb == 0)) .and. betazero) then
! Have to create an empty tensor
call create(Tc, Tl%nqs, 0, errst=errst)
!if(prop_error('contr_qtensorc: create failed.', &
! 'ContractionOps_include.f90:644', errst=errst)) return
return
elseif((Tl%nb == 0) .or. (Tr%nb == 0)) then
! The incoming tensor stays unmodified
return
end if
if(betazero) then
! Standard contraction
! ....................
call internal_contr_qtensorc(Tc, Tl, Tr, idxl, idxr, &
transl, transr, permout, &
alpha, errst=errst)
!if(prop_error('contr_qtensorc : internal_contr (1) '//&
! 'failed', 'ContractionOps_include.f90:660', errst=errst)) return
if(present(permout)) then
call permute_qnumbers(Tc, permout, errst=errst)
end if
else
! Contraction and addition only works with GAXPY
! ..............................................
call internal_contr_qtensorc(Tens, Tl, Tr, idxl, idxr, &
transl, transr, permout, &
alpha=alpha, errst=errst)
!if(prop_error('contr_qtensorc : internal_contr (2) '//&
! 'failed', 'ContractionOps_include.f90:673', errst=errst)) return
if(present(permout)) then
call permute_qnumbers(Tens, permout, errst=errst)
end if
if(beta /= zone) call scale(beta, Tc)
call gaxpy(Tc, zone, Tens, errst=errst)
!if(prop_error('contr_qtensorc : gaxpy failed.', &
! 'ContractionOps_include.f90:683', errst=errst)) return
call destroy(Tens)
end if
end subroutine contr_qtensorc
"""
return
[docs]def contr_tensor_tensorc():
"""
fortran-subroutine - June 2017 (dj)
Contraction of two different tensors.
**Arguments**
Tc : TYPE(tensorc), inout
Result of the contractions as tensor.
Tl : TYPE(tensor), inout
Left tensor in contraction. Destroyed on output and should
be different from Tr since it can be operated on.
Tr : TYPE(tensorc), inout
Right tensor in contraction. Destroyed on output and should
be different from Tl since it can be operated on.
idxl : INTEGER(\*), in
Contraction goes over the corresponding indices of the left tensor.
idxr : INTEGER(\*), in
Contraction goes over the corresponding indices of the right tensor.
transl : CHARACTER, OPTIONAL, in
'N' for nothing and 'C' for conjugating tensor (not daggered).
Default to 'N'. Transformation for left tensor.
transr : CHARACTER, OPTIONAL, in
'N' for nothing and 'C' for conjugating tensor (not daggered).
Default to 'N'. Transformation for right tensor.
permout : INTEGER(\*), OPTIONAL, in
Permutation on the output after the contraction.
alpha : complex, OPTIONAL, in
Scale contraction.
beta : complex, OPTIONAL, in
Add to existing tensor Tc scaled with beta.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine contr_tensor_tensorc(Tc, Tl, Tr, idxl, idxr, transl, &
transr, permout, alpha, beta, &
errst)
type(tensorc), intent(inout) :: Tc
type(tensor), intent(inout) :: Tl
type(tensorc), intent(inout) :: Tr
integer, dimension(:), intent(in) :: idxl, idxr
character, intent(in), optional :: transl, transr
integer, dimension(:), intent(in), optional :: permout
complex(KIND=rKind), intent(in), optional :: alpha, beta
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary complex tensor
type(tensorc) :: Tmp
call copy(Tmp, Tl)
call contr(Tc, Tmp, Tr, idxl, idxr, transl=transl, transr=transr, &
permout=permout, alpha=alpha, beta=beta, errst=errst)
!if(prop_error('contr_tensor_tensorc : '//&
! 'contr failed.')) return
call destroy(Tmp)
end subroutine contr_tensor_tensorc
"""
return
[docs]def contr_qtensor_qtensorc():
"""
fortran-subroutine - June 2017 (dj)
Contraction of two different tensors.
**Arguments**
Tc : TYPE(qtensorc), inout
Result of the contractions as tensor.
Tl : TYPE(qtensor), inout
Left tensor in contraction. Destroyed on output and should
be different from Tr since it can be operated on.
Tr : TYPE(qtensorc), inout
Right tensor in contraction. Destroyed on output and should
be different from Tl since it can be operated on.
idxl : INTEGER(\*), in
Contraction goes over the corresponding indices of the left tensor.
idxr : INTEGER(\*), in
Contraction goes over the corresponding indices of the right tensor.
transl : CHARACTER, OPTIONAL, in
'N' for nothing and 'C' for conjugating tensor (not daggered).
Default to 'N'. Transformation for left tensor.
transr : CHARACTER, OPTIONAL, in
'N' for nothing and 'C' for conjugating tensor (not daggered).
Default to 'N'. Transformation for right tensor.
permout : INTEGER(\*), OPTIONAL, in
Permutation on the output after the contraction.
alpha : complex, OPTIONAL, in
Scale contraction.
beta : complex, OPTIONAL, in
Add to existing tensor Tc scaled with beta.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine contr_qtensor_qtensorc(Tc, Tl, Tr, idxl, idxr, transl, &
transr, permout, alpha, beta, &
errst)
type(qtensorc), intent(inout) :: Tc
type(qtensor), intent(inout) :: Tl
type(qtensorc), intent(inout) :: Tr
integer, dimension(:), intent(in) :: idxl, idxr
character, intent(in), optional :: transl, transr
integer, dimension(:), intent(in), optional :: permout
complex(KIND=rKind), intent(in), optional :: alpha, beta
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary complex tensor
type(qtensorc) :: Tmp
call copy(Tmp, Tl)
call contr(Tc, Tmp, Tr, idxl, idxr, transl=transl, transr=transr, &
permout=permout, alpha=alpha, beta=beta, errst=errst)
!if(prop_error('contr_qtensor_qtensorc : '//&
! 'contr failed.')) return
call destroy(Tmp)
end subroutine contr_qtensor_qtensorc
"""
return
[docs]def contr_tensorc_tensor():
"""
fortran-subroutine - June 2017 (dj)
Contraction of two different tensors.
**Arguments**
Tc : TYPE(tensorc), inout
Result of the contractions as tensor.
Tl : TYPE(tensorc), inout
Left tensor in contraction. Destroyed on output and should
be different from Tr since it can be operated on.
Tr : TYPE(tensor), inout
Right tensor in contraction. Destroyed on output and should
be different from Tl since it can be operated on.
idxl : INTEGER(\*), in
Contraction goes over the corresponding indices of the left tensor.
idxr : INTEGER(\*), in
Contraction goes over the corresponding indices of the right tensor.
transl : CHARACTER, OPTIONAL, in
'N' for nothing and 'C' for conjugating tensor (not daggered).
Default to 'N'. Transformation for left tensor.
transr : CHARACTER, OPTIONAL, in
'N' for nothing and 'C' for conjugating tensor (not daggered).
Default to 'N'. Transformation for right tensor.
permout : INTEGER(\*), OPTIONAL, in
Permutation on the output after the contraction.
alpha : complex, OPTIONAL, in
Scale contraction.
beta : complex, OPTIONAL, in
Add to existing tensor Tc scaled with beta.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine contr_tensorc_tensor(Tc, Tl, Tr, idxl, idxr, transl, &
transr, permout, alpha, beta, &
errst)
type(tensorc), intent(inout) :: Tc
type(tensorc), intent(inout) :: Tl
type(tensor), intent(inout) :: Tr
integer, dimension(:), intent(in) :: idxl, idxr
character, intent(in), optional :: transl, transr
integer, dimension(:), intent(in), optional :: permout
complex(KIND=rKind), intent(in), optional :: alpha, beta
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary complex tensor
type(tensorc) :: Tmp
call copy(Tmp, Tr)
call contr(Tc, Tl, Tmp, idxl, idxr, transl=transl, transr=transr, &
permout=permout, alpha=alpha, beta=beta, errst=errst)
!if(prop_error('contr_tensorc_tensor : '//&
! 'contr failed.')) return
call destroy(Tmp)
end subroutine contr_tensorc_tensor
"""
return
[docs]def contr_qtensorc_qtensor():
"""
fortran-subroutine - June 2017 (dj)
Contraction of two different tensors.
**Arguments**
Tc : TYPE(qtensorc), inout
Result of the contractions as tensor.
Tl : TYPE(qtensorc), inout
Left tensor in contraction. Destroyed on output and should
be different from Tr since it can be operated on.
Tr : TYPE(qtensor), inout
Right tensor in contraction. Destroyed on output and should
be different from Tl since it can be operated on.
idxl : INTEGER(\*), in
Contraction goes over the corresponding indices of the left tensor.
idxr : INTEGER(\*), in
Contraction goes over the corresponding indices of the right tensor.
transl : CHARACTER, OPTIONAL, in
'N' for nothing and 'C' for conjugating tensor (not daggered).
Default to 'N'. Transformation for left tensor.
transr : CHARACTER, OPTIONAL, in
'N' for nothing and 'C' for conjugating tensor (not daggered).
Default to 'N'. Transformation for right tensor.
permout : INTEGER(\*), OPTIONAL, in
Permutation on the output after the contraction.
alpha : complex, OPTIONAL, in
Scale contraction.
beta : complex, OPTIONAL, in
Add to existing tensor Tc scaled with beta.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine contr_qtensorc_qtensor(Tc, Tl, Tr, idxl, idxr, transl, &
transr, permout, alpha, beta, &
errst)
type(qtensorc), intent(inout) :: Tc
type(qtensorc), intent(inout) :: Tl
type(qtensor), intent(inout) :: Tr
integer, dimension(:), intent(in) :: idxl, idxr
character, intent(in), optional :: transl, transr
integer, dimension(:), intent(in), optional :: permout
complex(KIND=rKind), intent(in), optional :: alpha, beta
integer, intent(out), optional :: errst
! Local variables
! ---------------
! temporary complex tensor
type(qtensorc) :: Tmp
call copy(Tmp, Tr)
call contr(Tc, Tl, Tmp, idxl, idxr, transl=transl, transr=transr, &
permout=permout, alpha=alpha, beta=beta, errst=errst)
!if(prop_error('contr_qtensorc_qtensor : '//&
! 'contr failed.')) return
call destroy(Tmp)
end subroutine contr_qtensorc_qtensor
"""
return
[docs]def contr_self_tensor():
"""
fortran-subroutine - May 2017 (dj)
Contract a tensor with itself.
**Arguments**
Tc : TYPE(tensor), inout
Result of the contraction.
Tlr : TYPE(tensor), inout
Tensor to be contracted.
idxl : INTEGER(\*), in
Indices to be contracted on the left tensor.
idxr : INTEGER(\*), OPTIONAL, in
Indices to be contracted on the right tensor. At
the moment, idxl is equal to idxr is required.
Default to idxl.
transl : CHARACTER, OPTIONAL, in
'N' for nothing and 'C' for conjugating tensor (not daggered).
Default to 'N'. Transformation for left tensor.
transr : CHARACTER, OPTIONAL, inout
'N' for nothing and 'C' for conjugating tensor (not daggered).
Default to 'N'. Transformation for left tensor.
permout : INTEGER(\*), OPTIONAL, in
Permutation on the outpur after the contraction.
alpha : real, OPTIONAL, in
Scale contraction.
beta : real, OPTIONAL, in
Add to existing tensor Tc scaled with beta.
uplo : CHARACTER, OPTIONAL, in
If possible, only the upper or lower triangular matrix
can be set. Choose 'U' for the upper triangular, 'L'
for the lower triangular matrix, and 'N' for the full
matrix.
Default to 'N'.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine contr_self_tensor(Tc, Tlr, idxl, idxr, transl, transr, &
permout, alpha, beta, uplo, errst)
type(tensor), intent(inout) :: Tc
type(tensor), intent(inout) :: Tlr
integer, dimension(:), intent(in) :: idxl
integer, dimension(:), intent(in), optional :: idxr
character, intent(in), optional :: transl, transr
integer, dimension(:), intent(in), optional :: permout
real(KIND=rKind), intent(in), optional :: alpha, beta
character, intent(in), optional :: uplo
integer, intent(out), optional :: errst
! Local variables
! ---------------
! Permutations on input (not allowed due to intent(in))
integer, dimension(Tlr%rank) :: perm
! LAPACK transposed etc
character :: loper, roper, oper
! dimensions for LAPACK dgemm
integer :: kk, nn, lda, ldc
! dimension of new tensor
integer, dimension(:), allocatable :: newdl
! duplettes scalars for LAPACK
real(KIND=rKind) :: alp, bet
! flag if left indices equal right
logical :: leqr
! flag for real, complex tensors
logical :: is_real
! flag for filling lower triangle
logical :: fill
! duplettes for optional arguments
character :: transl_, transr_, uplo_
integer, dimension(:), allocatable :: idxr_
!if(present(errst)) errst = 0
is_real = .true.
fill = .false.
if(present(uplo)) then
uplo_ = uplo
else
uplo_ = 'N'
end if
if(present(idxr)) then
allocate(idxr_(size(idxr)))
idxr_ = idxr
else
allocate(idxr_(size(idxl)))
idxr_ = idxl
end if
if(present(transl)) then
transl_ = transl
else
transl_ = 'N'
end if
if(present(transr)) then
transr_ = transr
else
transr_ = 'N'
end if
!if(size(idxl) /= size(idxr)) then
! errst = raise_error('contr_self_tensor: leg numbers', &
! 99, errst=errst)
! return
!end if
!if(any(Tlr%dl(idxl) /= Tlr%dl(idxr))) then
! errst = raise_error('contr_self_tensor: leg numbers', &
! 99, errst=errst)
! return
!end if
! Actual contraction with LAPACK
! ------------------------------
if(present(alpha)) then
alp = alpha
else
alp = done
end if
if(present(beta)) then
bet = beta
else
bet = dzero
end if
if(bet == dzero) then
allocate(newdl(Tlr%rank + Tlr%rank - 2 * size(idxr)))
newdl = get_new_dim(Tlr%dl, Tlr%dl, idxl, idxr, Tlr%rank, Tlr%rank)
call create(Tc, newdl, init='0')
deallocate(newdl)
end if
! Check on permutations
! ---------------------
call lcontr_perm(perm, loper, idxl, Tlr%rank, errst=errst)
!if(prop_error('contr_self_tensor: lcontr_perm failed.', &
! errst=errst)) return
leqr = all(idxl == idxr_)
if(leqr) then
! We may permute indices to the front
if(perm(1) > 0) call transposed(Tlr, perm, doperm=.true., errst=errst)
!if(prop_error('contr_tensor: transpose (l) failed.', &
! errst=errst)) return
! Deduct permutation on right from left
if(loper == 'N') then
roper = 'T'
else
roper = 'N'
end if
if(is_real) then
! Can use DSYRK anyway
! --------------------
if(uplo_ == 'N') then
uplo_ = 'U'
fill = .true.
end if
oper = 'N'
if(loper == 'T') oper = 'C'
if(oper == 'N') then
! Contracted indices over column
nn = product(Tlr%dl(:Tlr%rank - size(idxl)))
kk = product(Tlr%dl) / nn
lda = nn
ldc = nn
else
! Contracted indices over row
kk = product(Tlr%dl(:size(idxl)))
nn = product(Tlr%dl) / kk
lda = kk
ldc = nn
end if
call dsyrk(uplo_, oper, nn, kk, alp, Tlr%elem, lda, &
bet, Tc%elem, ldc)
elseif(transl_ /= transr_) then
! Can use ZHERK
! -------------
if(uplo_ == 'N') then
uplo_ = 'U'
fill = .true.
end if
if((loper == 'T') .and. (transl_ == 'C')) then
oper = 'C'
elseif(loper == 'T') then
call conj(Tlr)
oper = 'C'
elseif(transr_ == 'C') then
oper = 'N'
else
call conj(Tlr)
oper = 'N'
end if
if(oper == 'N') then
! Contracted indices over column
nn = product(Tlr%dl(:Tlr%rank - size(idxl)))
kk = product(Tlr%dl) / nn
lda = nn
ldc = nn
else
! Contracted indices over row
kk = product(Tlr%dl(:size(idxl)))
nn = product(Tlr%dl) / kk
lda = kk
ldc = nn
end if
call dsyrk(uplo_, oper, nn, kk, alp, Tlr%elem, lda, &
bet, Tc%elem, ldc)
else
! Cannot use ZHERK, it's A A^T, (A A^T)* A^T A, or (A^T A)*
! ----------------
! transl_ == transr_: check if complex conjugated
if(transl_ == 'C') then
call conj(Tlr)
end if
if(loper == 'N') then
nn = product(Tlr%dl(:Tlr%rank - size(idxl)))
kk = product(Tlr%dl) / nn
lda = nn
else
nn = product(Tlr%dl(:size(idxl)))
kk = product(Tlr%dl) / nn
lda = kk
end if
call dgemm(loper, roper, nn, nn, kk, alp, Tlr%elem, lda, &
Tlr%elem, lda, bet, Tc%elem, nn)
end if
if(fill) then
call fill_uplo_real(Tc%elem, ldc, errst=errst)
end if
else
! Without permutation there is no way to multiply?
errst = raise_error('contr_self_tensor: idxl is not idxr', &
99, errst=errst)
return
! Check that there is no permutation
!if(perm(1) > 0) then
! errst = raise_error('contr_self_tensor: only input (l)', &
! 99, errst=errst)
! return
!end if
!call rcontr_perm(perm, roper, idxr, Tlr%rank, errst=errst)
!if(prop_error('contr_tensor: rcontr_perm failed.', &
! errst=errst)) return
!if(perm(1) > 0) then
! errst = raise_error('contr_self_tensor: only input (r)', &
! 99, errst=errst)
! return
!end if
end if
! Permutation on output
! ---------------------
if(present(permout)) then
call transposed(Tc, permout, doperm=.true., errst=errst)
end if
deallocate(idxr_)
end subroutine contr_self_tensor
"""
return
[docs]def contr_self_tensorc():
"""
fortran-subroutine - May 2017 (dj)
Contract a tensor with itself.
**Arguments**
Tc : TYPE(tensorc), inout
Result of the contraction.
Tlr : TYPE(tensorc), inout
Tensor to be contracted.
idxl : INTEGER(\*), in
Indices to be contracted on the left tensor.
idxr : INTEGER(\*), OPTIONAL, in
Indices to be contracted on the right tensor. At
the moment, idxl is equal to idxr is required.
Default to idxl.
transl : CHARACTER, OPTIONAL, in
'N' for nothing and 'C' for conjugating tensor (not daggered).
Default to 'N'. Transformation for left tensor.
transr : CHARACTER, OPTIONAL, inout
'N' for nothing and 'C' for conjugating tensor (not daggered).
Default to 'N'. Transformation for left tensor.
permout : INTEGER(\*), OPTIONAL, in
Permutation on the outpur after the contraction.
alpha : complex, OPTIONAL, in
Scale contraction.
beta : complex, OPTIONAL, in
Add to existing tensor Tc scaled with beta.
uplo : CHARACTER, OPTIONAL, in
If possible, only the upper or lower triangular matrix
can be set. Choose 'U' for the upper triangular, 'L'
for the lower triangular matrix, and 'N' for the full
matrix.
Default to 'N'.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine contr_self_tensorc(Tc, Tlr, idxl, idxr, transl, transr, &
permout, alpha, beta, uplo, errst)
type(tensorc), intent(inout) :: Tc
type(tensorc), intent(inout) :: Tlr
integer, dimension(:), intent(in) :: idxl
integer, dimension(:), intent(in), optional :: idxr
character, intent(in), optional :: transl, transr
integer, dimension(:), intent(in), optional :: permout
complex(KIND=rKind), intent(in), optional :: alpha, beta
character, intent(in), optional :: uplo
integer, intent(out), optional :: errst
! Local variables
! ---------------
! Permutations on input (not allowed due to intent(in))
integer, dimension(Tlr%rank) :: perm
! LAPACK transposed etc
character :: loper, roper, oper
! dimensions for LAPACK zgemm
integer :: kk, nn, lda, ldc
! dimension of new tensor
integer, dimension(:), allocatable :: newdl
! duplettes scalars for LAPACK
complex(KIND=rKind) :: alp, bet
! flag if left indices equal right
logical :: leqr
! flag for real, complex tensors
logical :: is_real
! flag for filling lower triangle
logical :: fill
! duplettes for optional arguments
character :: transl_, transr_, uplo_
integer, dimension(:), allocatable :: idxr_
!if(present(errst)) errst = 0
is_real = .false.
fill = .false.
if(present(uplo)) then
uplo_ = uplo
else
uplo_ = 'N'
end if
if(present(idxr)) then
allocate(idxr_(size(idxr)))
idxr_ = idxr
else
allocate(idxr_(size(idxl)))
idxr_ = idxl
end if
if(present(transl)) then
transl_ = transl
else
transl_ = 'N'
end if
if(present(transr)) then
transr_ = transr
else
transr_ = 'N'
end if
!if(size(idxl) /= size(idxr)) then
! errst = raise_error('contr_self_tensorc: leg numbers', &
! 99, errst=errst)
! return
!end if
!if(any(Tlr%dl(idxl) /= Tlr%dl(idxr))) then
! errst = raise_error('contr_self_tensorc: leg numbers', &
! 99, errst=errst)
! return
!end if
! Actual contraction with LAPACK
! ------------------------------
if(present(alpha)) then
alp = alpha
else
alp = zone
end if
if(present(beta)) then
bet = beta
else
bet = zzero
end if
if(bet == zzero) then
allocate(newdl(Tlr%rank + Tlr%rank - 2 * size(idxr)))
newdl = get_new_dim(Tlr%dl, Tlr%dl, idxl, idxr, Tlr%rank, Tlr%rank)
call create(Tc, newdl, init='0')
deallocate(newdl)
end if
! Check on permutations
! ---------------------
call lcontr_perm(perm, loper, idxl, Tlr%rank, errst=errst)
!if(prop_error('contr_self_tensorc: lcontr_perm failed.', &
! errst=errst)) return
leqr = all(idxl == idxr_)
if(leqr) then
! We may permute indices to the front
if(perm(1) > 0) call transposed(Tlr, perm, doperm=.true., errst=errst)
!if(prop_error('contr_tensorc: transpose (l) failed.', &
! errst=errst)) return
! Deduct permutation on right from left
if(loper == 'N') then
roper = 'T'
else
roper = 'N'
end if
if(is_real) then
! Can use DSYRK anyway
! --------------------
if(uplo_ == 'N') then
uplo_ = 'U'
fill = .true.
end if
oper = 'N'
if(loper == 'T') oper = 'C'
if(oper == 'N') then
! Contracted indices over column
nn = product(Tlr%dl(:Tlr%rank - size(idxl)))
kk = product(Tlr%dl) / nn
lda = nn
ldc = nn
else
! Contracted indices over row
kk = product(Tlr%dl(:size(idxl)))
nn = product(Tlr%dl) / kk
lda = kk
ldc = nn
end if
call zherk(uplo_, oper, nn, kk, alp, Tlr%elem, lda, &
bet, Tc%elem, ldc)
elseif(transl_ /= transr_) then
! Can use ZHERK
! -------------
if(uplo_ == 'N') then
uplo_ = 'U'
fill = .true.
end if
if((loper == 'T') .and. (transl_ == 'C')) then
oper = 'C'
elseif(loper == 'T') then
call conj(Tlr)
oper = 'C'
elseif(transr_ == 'C') then
oper = 'N'
else
call conj(Tlr)
oper = 'N'
end if
if(oper == 'N') then
! Contracted indices over column
nn = product(Tlr%dl(:Tlr%rank - size(idxl)))
kk = product(Tlr%dl) / nn
lda = nn
ldc = nn
else
! Contracted indices over row
kk = product(Tlr%dl(:size(idxl)))
nn = product(Tlr%dl) / kk
lda = kk
ldc = nn
end if
call zherk(uplo_, oper, nn, kk, alp, Tlr%elem, lda, &
bet, Tc%elem, ldc)
else
! Cannot use ZHERK, it's A A^T, (A A^T)* A^T A, or (A^T A)*
! ----------------
! transl_ == transr_: check if complex conjugated
if(transl_ == 'C') then
call conj(Tlr)
end if
if(loper == 'N') then
nn = product(Tlr%dl(:Tlr%rank - size(idxl)))
kk = product(Tlr%dl) / nn
lda = nn
else
nn = product(Tlr%dl(:size(idxl)))
kk = product(Tlr%dl) / nn
lda = kk
end if
call zgemm(loper, roper, nn, nn, kk, alp, Tlr%elem, lda, &
Tlr%elem, lda, bet, Tc%elem, nn)
end if
if(fill) then
call fill_uplo_complex(Tc%elem, ldc, errst=errst)
end if
else
! Without permutation there is no way to multiply?
errst = raise_error('contr_self_tensorc: idxl is not idxr', &
99, errst=errst)
return
! Check that there is no permutation
!if(perm(1) > 0) then
! errst = raise_error('contr_self_tensorc: only input (l)', &
! 99, errst=errst)
! return
!end if
!call rcontr_perm(perm, roper, idxr, Tlr%rank, errst=errst)
!if(prop_error('contr_tensorc: rcontr_perm failed.', &
! errst=errst)) return
!if(perm(1) > 0) then
! errst = raise_error('contr_self_tensorc: only input (r)', &
! 99, errst=errst)
! return
!end if
end if
! Permutation on output
! ---------------------
if(present(permout)) then
call transposed(Tc, permout, doperm=.true., errst=errst)
end if
deallocate(idxr_)
end subroutine contr_self_tensorc
"""
return
[docs]def pcontr_tensor():
"""
fortran-subroutine - September 2017 (dj)
Contract indices within a tensor, similar to a partial trace or trace.
**Arguments**
Tc : TYPE(tensor), inout
On exit, result of the contraction. The uncontracted indices
remain in their order.
Tens : TYPE(tensor), inout
Contract indices within the tensor. On exit, modified.
idxl : INTEGER(\*), inout
First set of indices to be contracted.
idxr : INTEGER(\*), inout
Second set of indices to be contracted.
permout : INTEGER(\*), inout
Permute the indices of the result before returning the tensor.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine pcontr_tensor(Tc, Tens, idxl, idxr, permout, errst)
type(tensor), intent(inout) :: Tc
type(tensor), intent(inout) :: Tens
integer, dimension(:), intent(in) :: idxl, idxr
integer, dimension(:), intent(in), optional :: permout
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping, indexing
integer :: ii, jj, kk
! number of links contracted
integer :: nn
! dimension of contraction and remaining dimension
integer :: dc, dr
! permutation of input / indices contracted
integer, dimension(:), allocatable :: permin
logical, dimension(:), allocatable :: cidx
!if(present(errst)) errst = 0
! Save dimesion of contraction before transpose
dc = product(Tens%dl(idxl))
! 1) Permute contracted indices to the front
! ------------------------------------------
allocate(permin(Tens%rank), cidx(Tens%rank))
nn = size(idxl, 1)
permin(:nn) = idxl
permin(nn + 1:2 * nn) = idxr
cidx = .false.
cidx(idxl) = .true.
cidx(idxr) = .true.
jj = 2 * nn + 1
do ii = 1, Tens%rank
if(.not. cidx(ii)) then
permin(jj) = ii
jj = jj + 1
end if
end do
call transposed(Tens, permin, doperm=.true.)
deallocate(permin, cidx)
! 2) Execute contraction
! ----------------------
call create(Tc, Tens%dl(2 * nn + 1:), init='0')
if(Tc%rank > 0) then
dr = product(Tc%dl)
else
dr = 1
end if
kk = dc + 1
do ii = 1, dr
kk = kk - dc
do jj = 1, dc
Tc%elem(ii) = Tc%elem(ii) + Tens%elem(kk)
kk = kk + dc + 1
end do
end do
if(present(permout)) then
call transposed(Tc, perm=permout, doperm=.true.)
end if
end subroutine pcontr_tensor
"""
return
[docs]def pcontr_tensorc():
"""
fortran-subroutine - September 2017 (dj)
Contract indices within a tensor, similar to a partial trace or trace.
**Arguments**
Tc : TYPE(tensorc), inout
On exit, result of the contraction. The uncontracted indices
remain in their order.
Tens : TYPE(tensorc), inout
Contract indices within the tensor. On exit, modified.
idxl : INTEGER(\*), inout
First set of indices to be contracted.
idxr : INTEGER(\*), inout
Second set of indices to be contracted.
permout : INTEGER(\*), inout
Permute the indices of the result before returning the tensor.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine pcontr_tensorc(Tc, Tens, idxl, idxr, permout, errst)
type(tensorc), intent(inout) :: Tc
type(tensorc), intent(inout) :: Tens
integer, dimension(:), intent(in) :: idxl, idxr
integer, dimension(:), intent(in), optional :: permout
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping, indexing
integer :: ii, jj, kk
! number of links contracted
integer :: nn
! dimension of contraction and remaining dimension
integer :: dc, dr
! permutation of input / indices contracted
integer, dimension(:), allocatable :: permin
logical, dimension(:), allocatable :: cidx
!if(present(errst)) errst = 0
! Save dimesion of contraction before transpose
dc = product(Tens%dl(idxl))
! 1) Permute contracted indices to the front
! ------------------------------------------
allocate(permin(Tens%rank), cidx(Tens%rank))
nn = size(idxl, 1)
permin(:nn) = idxl
permin(nn + 1:2 * nn) = idxr
cidx = .false.
cidx(idxl) = .true.
cidx(idxr) = .true.
jj = 2 * nn + 1
do ii = 1, Tens%rank
if(.not. cidx(ii)) then
permin(jj) = ii
jj = jj + 1
end if
end do
call transposed(Tens, permin, doperm=.true.)
deallocate(permin, cidx)
! 2) Execute contraction
! ----------------------
call create(Tc, Tens%dl(2 * nn + 1:), init='0')
if(Tc%rank > 0) then
dr = product(Tc%dl)
else
dr = 1
end if
kk = dc + 1
do ii = 1, dr
kk = kk - dc
do jj = 1, dc
Tc%elem(ii) = Tc%elem(ii) + Tens%elem(kk)
kk = kk + dc + 1
end do
end do
if(present(permout)) then
call transposed(Tc, perm=permout, doperm=.true.)
end if
end subroutine pcontr_tensorc
"""
return
[docs]def pcontr_qtensor():
"""
fortran-subroutine - September 2017 (dj)
Contract indices within a tensor, similar to a partial trace or trace.
**Arguments**
Tc : TYPE(qtensor), inout
On exit, result of the contraction. The uncontracted indices
remain in their order.
Tens : TYPE(qtensor), inout
Contract indices within the tensor. On exit, modified.
idxl : INTEGER(\*), inout
First set of indices to be contracted.
idxr : INTEGER(\*), inout
Second set of indices to be contracted.
permout : INTEGER(\*), inout
Permute the indices of the result before returning the tensor.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine pcontr_qtensor(Tc, Tens, idxl, idxr, permout, errst)
type(qtensor), intent(inout) :: Tc
type(qtensor), intent(inout) :: Tens
integer, dimension(:), intent(in) :: idxl, idxr
integer, dimension(:), intent(in), optional :: permout
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping / indexing
integer :: ii, jj, kk, nn
! rank of the tensor / new tensor
integer :: rnk, nrnk
! total number of quantum numbers
integer :: snqs
! identity uncontracted indices
logical, dimension(:), allocatable :: notcontr
! hashes for left / right indices
real(KIND=rKind) :: hashl, hashr
!if(present(errst)) errst = 0
call create(Tc, Tens%nqs, Tens%nb)
! Fast return
if(Tens%nb == 0) return
snqs = sum(Tens%nqs)
rnk = Tens%Data(1)%Tens%rank
allocate(notcontr(rnk))
notcontr = .true.
notcontr(idxl) = .false.
notcontr(idxr) = .false.
nrnk = rnk - 2 * size(idxl, 1)
do ii = 1, Tens%nb
hashl = get_hash(Tens, idxl, ii)
hashr = get_hash(Tens, idxr, ii)
if(hashl /= hashr) cycle
Tc%nb = Tc%nb + 1
call pcontr(Tc%Data(Tc%nb)%Tens, Tens%Data(ii)%Tens, idxl, idxr)
! Copy quantum numbers
allocate(Tc%Data(Tc%nb)%qq(nrnk * snqs))
kk = 1
do jj = 1, rnk
if(notcontr(jj)) then
nn = (jj - 1) * snqs + 1
Tc%Data(Tc%nb)%qq(kk:kk + snqs - 1) = &
Tens%Data(ii)%qq(nn:nn + snqs - 1)
kk = kk + snqs
end if
end do
end do
deallocate(notcontr)
if(present(permout)) then
call transposed(Tc, perm=permout, doperm=.true.)
end if
end subroutine pcontr_qtensor
"""
return
[docs]def pcontr_qtensorc():
"""
fortran-subroutine - September 2017 (dj)
Contract indices within a tensor, similar to a partial trace or trace.
**Arguments**
Tc : TYPE(qtensorc), inout
On exit, result of the contraction. The uncontracted indices
remain in their order.
Tens : TYPE(qtensorc), inout
Contract indices within the tensor. On exit, modified.
idxl : INTEGER(\*), inout
First set of indices to be contracted.
idxr : INTEGER(\*), inout
Second set of indices to be contracted.
permout : INTEGER(\*), inout
Permute the indices of the result before returning the tensor.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine pcontr_qtensorc(Tc, Tens, idxl, idxr, permout, errst)
type(qtensorc), intent(inout) :: Tc
type(qtensorc), intent(inout) :: Tens
integer, dimension(:), intent(in) :: idxl, idxr
integer, dimension(:), intent(in), optional :: permout
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping / indexing
integer :: ii, jj, kk, nn
! rank of the tensor / new tensor
integer :: rnk, nrnk
! total number of quantum numbers
integer :: snqs
! identity uncontracted indices
logical, dimension(:), allocatable :: notcontr
! hashes for left / right indices
real(KIND=rKind) :: hashl, hashr
!if(present(errst)) errst = 0
call create(Tc, Tens%nqs, Tens%nb)
! Fast return
if(Tens%nb == 0) return
snqs = sum(Tens%nqs)
rnk = Tens%Data(1)%Tens%rank
allocate(notcontr(rnk))
notcontr = .true.
notcontr(idxl) = .false.
notcontr(idxr) = .false.
nrnk = rnk - 2 * size(idxl, 1)
do ii = 1, Tens%nb
hashl = get_hash(Tens, idxl, ii)
hashr = get_hash(Tens, idxr, ii)
if(hashl /= hashr) cycle
Tc%nb = Tc%nb + 1
call pcontr(Tc%Data(Tc%nb)%Tens, Tens%Data(ii)%Tens, idxl, idxr)
! Copy quantum numbers
allocate(Tc%Data(Tc%nb)%qq(nrnk * snqs))
kk = 1
do jj = 1, rnk
if(notcontr(jj)) then
nn = (jj - 1) * snqs + 1
Tc%Data(Tc%nb)%qq(kk:kk + snqs - 1) = &
Tens%Data(ii)%qq(nn:nn + snqs - 1)
kk = kk + snqs
end if
end do
end do
deallocate(notcontr)
if(present(permout)) then
call transposed(Tc, perm=permout, doperm=.true.)
end if
end subroutine pcontr_qtensorc
"""
return
[docs]def fill_uplo_real():
"""
fortran-subroutine - May 2017 (dj)
Build the complete hermitian matrix from an upper or lower
triangular matrix.
**Arguments**
mat : real(dim, dim), inout
On entry upper or lower triangular matrix. On exit, complete
hermitian matrix.
dim : INTEGER, in
Dimension of the square matrix mat.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine fill_uplo_real(mat, dim, errst)
integer, intent(in) :: dim
real(KIND=rKind), dimension(dim, dim), intent(inout) :: mat
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping over diagonal entries
integer :: ii
!if(present(errst)) errst = 0
mat = mat + transpose((mat))
do ii = 1, dim
mat(ii, ii) = 0.5_rKind * mat(ii, ii)
end do
end subroutine fill_uplo_real
"""
return
[docs]def fill_uplo_complex():
"""
fortran-subroutine - May 2017 (dj)
Build the complete hermitian matrix from an upper or lower
triangular matrix.
**Arguments**
mat : complex(dim, dim), inout
On entry upper or lower triangular matrix. On exit, complete
hermitian matrix.
dim : INTEGER, in
Dimension of the square matrix mat.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine fill_uplo_complex(mat, dim, errst)
integer, intent(in) :: dim
complex(KIND=rKind), dimension(dim, dim), intent(inout) :: mat
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping over diagonal entries
integer :: ii
!if(present(errst)) errst = 0
mat = mat + transpose(conjg(mat))
do ii = 1, dim
mat(ii, ii) = 0.5_rKind * mat(ii, ii)
end do
end subroutine fill_uplo_complex
"""
return
[docs]def contr_self_qtensor():
"""
fortran-subroutine - May 2017 (dj)
Contract a tensor with itself.
**Arguments**
Tc : TYPE(TENSOR_TYPE), inout
Result of the contraction.
Tlr : TYPE(TENSOR_TYPE), inout
Tensor to be contracted.
idxl : INTEGER(\*), in
Indices to be contracted on the left tensor.
idxr : INTEGER(\*), OPTIONAL, in
Indices to be contracted on the right tensor. At
the moment, idxl is equal to idxr is required.
Default to idxl.
transl : CHARACTER, OPTIONAL, in
'N' for nothing and 'C' for conjugating tensor (not daggered).
Default to 'N'. Transformation for left tensor.
transr : CHARACTER, OPTIONAL, inout
'N' for nothing and 'C' for conjugating tensor (not daggered).
Default to 'N'. Transformation for left tensor.
permout : INTEGER(\*), OPTIONAL, in
Permutation on the outpur after the contraction.
alpha : real, OPTIONAL, in
Scale contraction.
beta : real, OPTIONAL, in
Add to existing tensor Tc scaled with beta.
uplo : CHARACTER, OPTIONAL, in
If possible, only the upper or lower triangular matrix
can be set. Choose 'U' for the upper triangular, 'L'
for the lower triangular matrix, and 'N' for the full
matrix.
Default to 'N'.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine contr_self_qtensor(Tc, Tlr, idxl, idxr, transl, transr, &
permout, alpha, beta, uplo, errst)
type(qtensor), intent(inout) :: Tc
type(qtensor), intent(inout) :: Tlr
integer, dimension(:), intent(in) :: idxl
integer, dimension(:), intent(in), optional :: idxr
character, intent(in), optional :: transl, transr
integer, dimension(:), intent(in), optional :: permout
real(KIND=rKind), intent(in), optional :: alpha, beta
character, intent(in), optional :: uplo
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! for start stop of quantum number index
integer :: j1, j2, k1, k2, i1, i2
! number of matching blocks, contracted indices
integer :: ni
integer, dimension(:, :), allocatable :: cidx
integer, dimension(:), allocatable :: indout, degout
! number/index of quantum numbers to be copied
integer :: ncl, ncr
integer, dimension(:), allocatable :: copyl, copyr
! duplettes for optional arguments
integer, dimension(:), allocatable :: idxr_
! quantum numbers of result
integer, dimension(:, :), allocatable :: qqq
!if(present(errst)) errst = 0
! Fast return
if(Tlr%nb == 0) then
call create(Tc, Tlr%nqs, 0, errst=errst)
!if(prop_error('contr_self_qtensor: create failed.', &
! 'ContractionOps_include.f90:1803', errst=errst)) return
return
end if
! Copy optional arguments
if(present(idxr)) then
allocate(idxr_(size(idxr)))
idxr_ = idxr
else
allocate(idxr_(size(idxl)))
idxr_ = idxl
end if
! Find contraction indices
allocate(cidx(2, Tlr%nb**2))
call get_contr_idx(Tlr, idxl, Tlr, idxr_, [.true., .true.], cidx, ni, &
indout, degout, qqq=qqq, errst=errst)
!if(prop_error('contr_TENSOR_TYPE: get_contr_idx failed.', &
! 'ContractionOps_include.f90:1821', errst=errst)) return
if(any(cidx(1, :) /= cidx(2, :))) then
errst = raise_error('contr_self_qtensor: cross-blocks.', &
99, errst=errst)
end if
call create(Tc, Tlr%nqs, ni, errst=errst)
!if(prop_error('contr_self_qtensor: create failed (2).', &
! errst=errst)) return
! Set number of blocks
Tc%nb = ni
do ii = 1, ni
i1 = indout(degout(ii) + 1)
call contr(Tc%Data(ii)%Tens, Tlr%Data(cidx(1, i1))%Tens, &
idxl, idxr=idxr_, transl=transl, transr=transr, &
permout=permout, alpha=alpha, beta=beta, uplo=uplo, &
errst=errst)
!if(prop_error('contr_self_qtensor: contr (1) failed.', &
! 'ContractionOps_include.f90:1843', errst=errst)) return
allocate(Tc%Data(ii)%qq(Tc%Data(ii)%Tens%rank * sum(Tc%nqs)))
Tc%Data(ii)%qq = qqq(:, i1)
! Left tensor
! ...........
!ncl = Tlr%Data(cidx(1, i1))%Tens%rank - size(idxl)
!allocate(copyl(ncl))
!kk = 1
!do jj = 1, Tlr%Data(cidx(1, i1))%Tens%rank
! if(any(idxl == jj)) cycle
! copyl(kk) = jj
! kk = kk + 1
!end do
!do jj = 1, ncl
! j2 = jj * sum(Tc%nqs)
! j1 = j2 - sum(Tc%nqs) + 1
! k2 = copyl(jj) * sum(Tlr%nqs)
! k1 = k2 - sum(Tlr%nqs) + 1
! Tc%Data(ii)%qq(j1:j2) = Tlr%Data(cidx(1, i1))%qq(k1:k2)
!end do
! Right tensor
! ............
!ncr = Tlr%Data(cidx(1, i1))%Tens%rank - size(idxr_)
!allocate(copyr(ncr))
!kk = 1
!do jj = 1, Tlr%Data(cidx(1, i1))%Tens%rank
! if(any(idxr_ == jj)) cycle
! copyr(kk) = jj
! kk = kk + 1
!end do
!do jj = 1, ncr
! j2 = (jj + ncl) * sum(Tc%nqs)
! j1 = j2 - sum(Tc%nqs) + 1
! k2 = copyr(jj) * sum(Tlr%nqs)
! k1 = k2 - sum(Tlr%nqs) + 1
! Tc%Data(ii)%qq(j1:j2) = Tlr%Data(cidx(1, i1))%qq(k1:k2)
!end do
!deallocate(copyl, copyr)
do i2 = degout(ii) + 2, degout(ii + 1)
i1 = indout(i2)
call contr(Tc%Data(ii)%Tens, Tlr%Data(cidx(1, i1))%Tens, &
idxl, idxr=idxr_, transl=transl, transr=transr, &
permout=permout, alpha=alpha, beta=done, uplo=uplo, &
errst=errst)
!if(prop_error('contr_self_qtensor: contr (2) '//&
! 'failed.', 'ContractionOps_include.f90:1903', errst=errst)) return
end do
if(present(permout)) then
call permute_qnumbers(Tc, permout, errst=errst)
end if
end do
deallocate(cidx, idxr_)
if(ni > 0) deallocate(indout, degout, qqq)
end subroutine contr_self_qtensor
"""
return
[docs]def contr_self_qtensorc():
"""
fortran-subroutine - May 2017 (dj)
Contract a tensor with itself.
**Arguments**
Tc : TYPE(TENSOR_TYPE), inout
Result of the contraction.
Tlr : TYPE(TENSOR_TYPE), inout
Tensor to be contracted.
idxl : INTEGER(\*), in
Indices to be contracted on the left tensor.
idxr : INTEGER(\*), OPTIONAL, in
Indices to be contracted on the right tensor. At
the moment, idxl is equal to idxr is required.
Default to idxl.
transl : CHARACTER, OPTIONAL, in
'N' for nothing and 'C' for conjugating tensor (not daggered).
Default to 'N'. Transformation for left tensor.
transr : CHARACTER, OPTIONAL, inout
'N' for nothing and 'C' for conjugating tensor (not daggered).
Default to 'N'. Transformation for left tensor.
permout : INTEGER(\*), OPTIONAL, in
Permutation on the outpur after the contraction.
alpha : complex, OPTIONAL, in
Scale contraction.
beta : complex, OPTIONAL, in
Add to existing tensor Tc scaled with beta.
uplo : CHARACTER, OPTIONAL, in
If possible, only the upper or lower triangular matrix
can be set. Choose 'U' for the upper triangular, 'L'
for the lower triangular matrix, and 'N' for the full
matrix.
Default to 'N'.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine contr_self_qtensorc(Tc, Tlr, idxl, idxr, transl, transr, &
permout, alpha, beta, uplo, errst)
type(qtensorc), intent(inout) :: Tc
type(qtensorc), intent(inout) :: Tlr
integer, dimension(:), intent(in) :: idxl
integer, dimension(:), intent(in), optional :: idxr
character, intent(in), optional :: transl, transr
integer, dimension(:), intent(in), optional :: permout
complex(KIND=rKind), intent(in), optional :: alpha, beta
character, intent(in), optional :: uplo
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! for start stop of quantum number index
integer :: j1, j2, k1, k2, i1, i2
! number of matching blocks, contracted indices
integer :: ni
integer, dimension(:, :), allocatable :: cidx
integer, dimension(:), allocatable :: indout, degout
! number/index of quantum numbers to be copied
integer :: ncl, ncr
integer, dimension(:), allocatable :: copyl, copyr
! duplettes for optional arguments
integer, dimension(:), allocatable :: idxr_
! quantum numbers of result
integer, dimension(:, :), allocatable :: qqq
!if(present(errst)) errst = 0
! Fast return
if(Tlr%nb == 0) then
call create(Tc, Tlr%nqs, 0, errst=errst)
!if(prop_error('contr_self_qtensorc: create failed.', &
! 'ContractionOps_include.f90:1803', errst=errst)) return
return
end if
! Copy optional arguments
if(present(idxr)) then
allocate(idxr_(size(idxr)))
idxr_ = idxr
else
allocate(idxr_(size(idxl)))
idxr_ = idxl
end if
! Find contraction indices
allocate(cidx(2, Tlr%nb**2))
call get_contr_idx(Tlr, idxl, Tlr, idxr_, [.true., .true.], cidx, ni, &
indout, degout, qqq=qqq, errst=errst)
!if(prop_error('contr_TENSOR_TYPE: get_contr_idx failed.', &
! 'ContractionOps_include.f90:1821', errst=errst)) return
if(any(cidx(1, :) /= cidx(2, :))) then
errst = raise_error('contr_self_qtensorc: cross-blocks.', &
99, errst=errst)
end if
call create(Tc, Tlr%nqs, ni, errst=errst)
!if(prop_error('contr_self_qtensorc: create failed (2).', &
! errst=errst)) return
! Set number of blocks
Tc%nb = ni
do ii = 1, ni
i1 = indout(degout(ii) + 1)
call contr(Tc%Data(ii)%Tens, Tlr%Data(cidx(1, i1))%Tens, &
idxl, idxr=idxr_, transl=transl, transr=transr, &
permout=permout, alpha=alpha, beta=beta, uplo=uplo, &
errst=errst)
!if(prop_error('contr_self_qtensorc: contr (1) failed.', &
! 'ContractionOps_include.f90:1843', errst=errst)) return
allocate(Tc%Data(ii)%qq(Tc%Data(ii)%Tens%rank * sum(Tc%nqs)))
Tc%Data(ii)%qq = qqq(:, i1)
! Left tensor
! ...........
!ncl = Tlr%Data(cidx(1, i1))%Tens%rank - size(idxl)
!allocate(copyl(ncl))
!kk = 1
!do jj = 1, Tlr%Data(cidx(1, i1))%Tens%rank
! if(any(idxl == jj)) cycle
! copyl(kk) = jj
! kk = kk + 1
!end do
!do jj = 1, ncl
! j2 = jj * sum(Tc%nqs)
! j1 = j2 - sum(Tc%nqs) + 1
! k2 = copyl(jj) * sum(Tlr%nqs)
! k1 = k2 - sum(Tlr%nqs) + 1
! Tc%Data(ii)%qq(j1:j2) = Tlr%Data(cidx(1, i1))%qq(k1:k2)
!end do
! Right tensor
! ............
!ncr = Tlr%Data(cidx(1, i1))%Tens%rank - size(idxr_)
!allocate(copyr(ncr))
!kk = 1
!do jj = 1, Tlr%Data(cidx(1, i1))%Tens%rank
! if(any(idxr_ == jj)) cycle
! copyr(kk) = jj
! kk = kk + 1
!end do
!do jj = 1, ncr
! j2 = (jj + ncl) * sum(Tc%nqs)
! j1 = j2 - sum(Tc%nqs) + 1
! k2 = copyr(jj) * sum(Tlr%nqs)
! k1 = k2 - sum(Tlr%nqs) + 1
! Tc%Data(ii)%qq(j1:j2) = Tlr%Data(cidx(1, i1))%qq(k1:k2)
!end do
!deallocate(copyl, copyr)
do i2 = degout(ii) + 2, degout(ii + 1)
i1 = indout(i2)
call contr(Tc%Data(ii)%Tens, Tlr%Data(cidx(1, i1))%Tens, &
idxl, idxr=idxr_, transl=transl, transr=transr, &
permout=permout, alpha=alpha, beta=zone, uplo=uplo, &
errst=errst)
!if(prop_error('contr_self_qtensorc: contr (2) '//&
! 'failed.', 'ContractionOps_include.f90:1903', errst=errst)) return
end do
if(present(permout)) then
call permute_qnumbers(Tc, permout, errst=errst)
end if
end do
deallocate(cidx, idxr_)
if(ni > 0) deallocate(indout, degout, qqq)
end subroutine contr_self_qtensorc
"""
return
[docs]def contr_uplo_tensor():
"""
fortran-subroutine - June 2017 (dj)
Contract an upper or lower triangular tensor with another dense
tensor.
**Arguments**
Tuplo : TYPE(Qtensor), inout
The upper or lower triangular tensor to be contracted to Tens.
Tens : TYPE(Qtensor), inout
Tens is contracted with Tuplo; on exit the result of the
contraction.
idxuplo : INTEGER(\*), in
Index to be contracted for the tensor Tuplo.
idxt : INTEGER(\*), in
Index to be contracted for the tensor Tens.
permout : INTEGER(\*), in
Permutation on final result.
alpha : real, OPTIONAL, in
Can be used to scale the result.
Default to 1.0
uplo : CHARACTER, OPTIONAL, in
Tuplo is upper triangular for 'U' and lower triangular for 'L'.
Default to 'U'.
diag : CHARACTER, OPTIONAL, in
Tuplo has ones on the diagonal for 'U', otherwise arbitrary
entries for 'N'.
Default to 'N'.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine contr_uplo_tensor(Tuplo, Tens, idxuplo, idxt, &
permout, alpha, uplo, diag, errst)
type(tensor), intent(inout) :: Tuplo
type(tensor), intent(inout) :: Tens
integer, dimension(:), intent(in) :: idxuplo, idxt
integer, dimension(:), intent(out), optional :: permout
real(KIND=rKind), intent(in), optional :: alpha
character, intent(in), optional :: uplo, diag
integer, intent(out), optional :: errst
! Local variables
! ---------------
! rows and columns in Tens (non-uplo)
integer :: rb, cb
! leading dimesion of uplo-matrix
integer :: lda
! dubplette for optional argument
real(KIND=rKind) :: alpha_
! duplette for optional argument
character :: uplo_, diag_
! side for the uplo-matrix
character :: side
! operations yielded from permutation
character :: oper
! for permutations
integer, dimension(:), allocatable :: perm
! Temporary tensor to contract trapezoidal matrices Tuplo
type(tensor) :: Tmp
!if(present(errst)) errst = 0
if(present(uplo)) then
uplo_ = uplo
else
uplo_ = 'U'
end if
if(present(diag)) then
diag_ = diag
else
diag_ = 'N'
end if
if(present(alpha)) then
alpha_ = alpha
else
alpha_ = done
end if
!if(size(idxuplo) /= size(idxt)) then
! errst = raise_error('contr_uplo_tensor: leg numbers', &
! 99, errst=errst)
! return
!end if
!if(any(Tuplo%dl(idxuplo) /= Tens%dl(idxt))) then
! errst = raise_error('contr_uplo_tensor: dim mismatch', &
! 99, errst=errst)
! return
!end if
! Permutations not allowed right now
if(idxuplo(1) == 1) then
! Asumme Tens x Tuplo
side = 'R'
! Leading dimemsion of uplo-matrix
lda = product(Tuplo%dl(idxuplo))
! Dimensions of matrix
cb = product(Tens%dl(idxt))
rb = product(Tens%dl) / cb
!allocate(perm(Tens%rank))
!call lcontr_perm(perm, oper, idxt, Tens%rank, errst=errst)
!if(oper /= 'N') then
! errst = raise_error('contr_uplo_tensor:'//&
! 'cannot transpose (1)', &
! 99, errst=errst)
! return
!end if
!if(perm(1) > 0) then
! errst = raise_error('contr_uplo_tensor:'//&
! 'cannot perm (1)', &
! 99, errst=errst)
! return
!end if
!deallocate(perm)
!allocate(perm(Tuplo%rank))
!call rcontr_perm(perm, oper, idxuplo, Tuplo%rank, errst=errst)
!if(oper /= 'N') then
! errst = raise_error('contr_uplo_tensor:'//&
! 'cannot transpose (2)', &
! 99, errst=errst)
! return
!end if
!if(perm(1) > 0) then
! errst = raise_error('contr_uplo_tensor:'//&
! 'cannot perm (2)', &
! 99, errst=errst)
! return
!end if
!deallocate(perm)
else
! Assume Tuplo x Tens
side = 'L'
! Leading dimension of uplo-matrix
lda = product(Tuplo%dl(idxuplo))
lda = product(Tuplo%dl) / lda
! Dimensions of matrix
rb = product(Tens%dl(idxt))
cb = product(Tens%dl) / rb
!allocate(perm(Tens%rank))
!call rcontr_perm(perm, oper, idxt, Tens%rank, errst=errst)
!if(oper /= 'N') then
! errst = raise_error('contr_uplo_tensor:'//&
! 'cannot transpose (3)', &
! 99, errst=errst)
! return
!end if
!if(perm(1) > 0) then
! errst = raise_error('contr_uplo_tensor:'//&
! 'cannot perm (3)', &
! 99, errst=errst)
! return
!end if
!deallocate(perm)
!allocate(perm(Tuplo%rank))
!call lcontr_perm(perm, oper, idxuplo, Tuplo%rank, errst=errst)
!if(oper /= 'N') then
! errst = raise_error('contr_uplo_tensor:'//&
! 'cannot transpose (4)', &
! 99, errst=errst)
! return
!end if
!if(perm(1) > 0) then
! errst = raise_error('contr_uplo_tensor:'//&
! 'cannot perm (4)', &
! 99, errst=errst)
! return
!end if
!deallocate(perm)
end if
if(lda**2 == Tuplo%dim) then
! Uplo is square matrix
call dtrmm(side, uplo_, 'N', diag_, rb, cb, alpha_, Tuplo%elem, &
lda, Tens%elem, rb)
elseif(side =='R') then
! Trapezoidal matrix from right (use dense)
call contr(Tmp, Tens, Tuplo, [Tens%rank], [1], alpha=alpha_)
call destroy(Tens)
call pointto(Tens, Tmp)
!call destroy(Tmp)
else
! Trapezoidal matrix from left (use dense)
call contr(Tmp, Tuplo, Tens, [Tuplo%rank], [1], alpha=alpha_)
call destroy(Tens)
call pointto(Tens, Tmp)
!call destroy(Tmp)
end if
if(present(permout)) then
call transposed(Tens, permout, doperm=.true., errst=errst)
end if
end subroutine contr_uplo_tensor
"""
return
[docs]def contr_uplo_tensorc():
"""
fortran-subroutine - June 2017 (dj)
Contract an upper or lower triangular tensor with another dense
tensor.
**Arguments**
Tuplo : TYPE(Qtensorc), inout
The upper or lower triangular tensor to be contracted to Tens.
Tens : TYPE(Qtensorc), inout
Tens is contracted with Tuplo; on exit the result of the
contraction.
idxuplo : INTEGER(\*), in
Index to be contracted for the tensor Tuplo.
idxt : INTEGER(\*), in
Index to be contracted for the tensor Tens.
permout : INTEGER(\*), in
Permutation on final result.
alpha : complex, OPTIONAL, in
Can be used to scale the result.
Default to 1.0
uplo : CHARACTER, OPTIONAL, in
Tuplo is upper triangular for 'U' and lower triangular for 'L'.
Default to 'U'.
diag : CHARACTER, OPTIONAL, in
Tuplo has ones on the diagonal for 'U', otherwise arbitrary
entries for 'N'.
Default to 'N'.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine contr_uplo_tensorc(Tuplo, Tens, idxuplo, idxt, &
permout, alpha, uplo, diag, errst)
type(tensorc), intent(inout) :: Tuplo
type(tensorc), intent(inout) :: Tens
integer, dimension(:), intent(in) :: idxuplo, idxt
integer, dimension(:), intent(out), optional :: permout
complex(KIND=rKind), intent(in), optional :: alpha
character, intent(in), optional :: uplo, diag
integer, intent(out), optional :: errst
! Local variables
! ---------------
! rows and columns in Tens (non-uplo)
integer :: rb, cb
! leading dimesion of uplo-matrix
integer :: lda
! dubplette for optional argument
complex(KIND=rKind) :: alpha_
! duplette for optional argument
character :: uplo_, diag_
! side for the uplo-matrix
character :: side
! operations yielded from permutation
character :: oper
! for permutations
integer, dimension(:), allocatable :: perm
! Temporary tensor to contract trapezoidal matrices Tuplo
type(tensorc) :: Tmp
!if(present(errst)) errst = 0
if(present(uplo)) then
uplo_ = uplo
else
uplo_ = 'U'
end if
if(present(diag)) then
diag_ = diag
else
diag_ = 'N'
end if
if(present(alpha)) then
alpha_ = alpha
else
alpha_ = zone
end if
!if(size(idxuplo) /= size(idxt)) then
! errst = raise_error('contr_uplo_tensorc: leg numbers', &
! 99, errst=errst)
! return
!end if
!if(any(Tuplo%dl(idxuplo) /= Tens%dl(idxt))) then
! errst = raise_error('contr_uplo_tensorc: dim mismatch', &
! 99, errst=errst)
! return
!end if
! Permutations not allowed right now
if(idxuplo(1) == 1) then
! Asumme Tens x Tuplo
side = 'R'
! Leading dimemsion of uplo-matrix
lda = product(Tuplo%dl(idxuplo))
! Dimensions of matrix
cb = product(Tens%dl(idxt))
rb = product(Tens%dl) / cb
!allocate(perm(Tens%rank))
!call lcontr_perm(perm, oper, idxt, Tens%rank, errst=errst)
!if(oper /= 'N') then
! errst = raise_error('contr_uplo_tensorc:'//&
! 'cannot transpose (1)', &
! 99, errst=errst)
! return
!end if
!if(perm(1) > 0) then
! errst = raise_error('contr_uplo_tensorc:'//&
! 'cannot perm (1)', &
! 99, errst=errst)
! return
!end if
!deallocate(perm)
!allocate(perm(Tuplo%rank))
!call rcontr_perm(perm, oper, idxuplo, Tuplo%rank, errst=errst)
!if(oper /= 'N') then
! errst = raise_error('contr_uplo_tensorc:'//&
! 'cannot transpose (2)', &
! 99, errst=errst)
! return
!end if
!if(perm(1) > 0) then
! errst = raise_error('contr_uplo_tensorc:'//&
! 'cannot perm (2)', &
! 99, errst=errst)
! return
!end if
!deallocate(perm)
else
! Assume Tuplo x Tens
side = 'L'
! Leading dimension of uplo-matrix
lda = product(Tuplo%dl(idxuplo))
lda = product(Tuplo%dl) / lda
! Dimensions of matrix
rb = product(Tens%dl(idxt))
cb = product(Tens%dl) / rb
!allocate(perm(Tens%rank))
!call rcontr_perm(perm, oper, idxt, Tens%rank, errst=errst)
!if(oper /= 'N') then
! errst = raise_error('contr_uplo_tensorc:'//&
! 'cannot transpose (3)', &
! 99, errst=errst)
! return
!end if
!if(perm(1) > 0) then
! errst = raise_error('contr_uplo_tensorc:'//&
! 'cannot perm (3)', &
! 99, errst=errst)
! return
!end if
!deallocate(perm)
!allocate(perm(Tuplo%rank))
!call lcontr_perm(perm, oper, idxuplo, Tuplo%rank, errst=errst)
!if(oper /= 'N') then
! errst = raise_error('contr_uplo_tensorc:'//&
! 'cannot transpose (4)', &
! 99, errst=errst)
! return
!end if
!if(perm(1) > 0) then
! errst = raise_error('contr_uplo_tensorc:'//&
! 'cannot perm (4)', &
! 99, errst=errst)
! return
!end if
!deallocate(perm)
end if
if(lda**2 == Tuplo%dim) then
! Uplo is square matrix
call ztrmm(side, uplo_, 'N', diag_, rb, cb, alpha_, Tuplo%elem, &
lda, Tens%elem, rb)
elseif(side =='R') then
! Trapezoidal matrix from right (use dense)
call contr(Tmp, Tens, Tuplo, [Tens%rank], [1], alpha=alpha_)
call destroy(Tens)
call pointto(Tens, Tmp)
!call destroy(Tmp)
else
! Trapezoidal matrix from left (use dense)
call contr(Tmp, Tuplo, Tens, [Tuplo%rank], [1], alpha=alpha_)
call destroy(Tens)
call pointto(Tens, Tmp)
!call destroy(Tmp)
end if
if(present(permout)) then
call transposed(Tens, permout, doperm=.true., errst=errst)
end if
end subroutine contr_uplo_tensorc
"""
return
[docs]def contr_uplo_qtensor():
"""
fortran-subroutine - June 2017 (dj)
Contract upper or lower triangular tensors in a qtensor
with another dense qtensor. The contractions is restricted
to one index right now.
**Arguments**
Tuplo : TYPE(qtensor), inout
The upper or lower triangular tensor to be contracted to Tens.
(Hashes are assumed to be unique.)
Tens : TYPE(qtensor), inout
Tens is contracted with Tuplo; on exit the result of the
contraction. (Hashes are assumed to be possibly degenerate.)
idxuplo : INTEGER(\*), in
Index to be contracted for the tensor Tuplo. Restricted
to one index at present.
idxt : INTEGER(\*), in
Index to be contracted for the tensor Tens.
permout : INTEGER(\*), in
Permutation on final result.
alpha : real, OPTIONAL, in
Can be used to scale the result.
Default to 1.0
uplo : CHARACTER, OPTIONAL, in
Tuplo is upper triangular for 'U' and lower triangular for 'L'.
Default to 'U'.
diag : CHARACTER, OPTIONAL, in
Tuplo has ones on the diagonal for 'U', otherwise arbitrary
entries for 'N'.
Default to 'N'.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine contr_uplo_qtensor(Tuplo, Tens, idxuplo, idxt, &
permout, alpha, uplo, diag, errst)
type(qtensor), intent(inout) :: Tuplo
type(qtensor), intent(inout) :: Tens
integer, dimension(:), intent(in) :: idxuplo, idxt
integer, dimension(:), intent(out), optional :: permout
real(KIND=rKind), intent(in), optional :: alpha
character, intent(in), optional :: uplo, diag
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, i1, i2
! number of matching blocks, contracted indices
integer :: ni
integer, dimension(:, :), allocatable :: cidx
integer, dimension(:), allocatable :: indout, degout
! Blocks kept
integer, dimension(:), allocatable :: idxkeep
!if(present(errst)) errst = 0
! Check that only on index is contracted
!if(size(idxt) /= 1) then
! errst = raise_error('contr_uplo_qtensor: size(idxt)', &
! 99, errst=errst)
! return
!end if
! Get indices to be contracted
allocate(cidx(2, Tuplo%nb * Tens%nb), idxkeep(Tens%nb))
call get_contr_idx(Tuplo, idxuplo, Tens, idxt, [.false., .true.], &
cidx, ni, indout, degout, errst=errst)
!if(prop_error('contr_uplo_qtensor : get_contr_idx '//&
! 'failed', 'ContractionOps_include.f90:2291', errst=errst)) return
do ii = 1, ni
do i2 = degout(ii) + 1, degout(ii + 1)
i1 = indout(i2)
call contr_uplo(Tuplo%Data(cidx(1, i1))%Tens, &
Tens%Data(cidx(2, i1))%Tens, idxuplo, idxt, &
alpha=alpha, uplo=uplo, diag=diag, errst=errst)
!if(prop_error('contr_uplo_qtensor : contr_uplo'//&
! ' failed', 'ContractionOps_include.f90:2300', errst=errst)) return
end do
end do
! Hashes in Tuplo should be unique, therefore no index in Tens
! should appear twice
idxkeep(:ni) = cidx(2, :ni)
call skim(Tens, ni, idxkeep, errst=errst)
!if(prop_error('contr_uplo_qtensor : skim '//&
! 'failed', 'ContractionOps_include.f90:2309', errst=errst)) return
deallocate(cidx, idxkeep)
if(ni > 0) deallocate(indout, degout)
if(present(permout)) then
call transposed(Tens, permout, errst=errst)
!if(prop_error('contr_uplo_qtensor : transpose failed', &
! 'ContractionOps_include.f90:2317', errst=errst)) return
end if
end subroutine contr_uplo_qtensor
"""
return
[docs]def contr_uplo_qtensorc():
"""
fortran-subroutine - June 2017 (dj)
Contract upper or lower triangular tensors in a qtensorc
with another dense qtensorc. The contractions is restricted
to one index right now.
**Arguments**
Tuplo : TYPE(qtensorc), inout
The upper or lower triangular tensor to be contracted to Tens.
(Hashes are assumed to be unique.)
Tens : TYPE(qtensorc), inout
Tens is contracted with Tuplo; on exit the result of the
contraction. (Hashes are assumed to be possibly degenerate.)
idxuplo : INTEGER(\*), in
Index to be contracted for the tensor Tuplo. Restricted
to one index at present.
idxt : INTEGER(\*), in
Index to be contracted for the tensor Tens.
permout : INTEGER(\*), in
Permutation on final result.
alpha : complex, OPTIONAL, in
Can be used to scale the result.
Default to 1.0
uplo : CHARACTER, OPTIONAL, in
Tuplo is upper triangular for 'U' and lower triangular for 'L'.
Default to 'U'.
diag : CHARACTER, OPTIONAL, in
Tuplo has ones on the diagonal for 'U', otherwise arbitrary
entries for 'N'.
Default to 'N'.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine contr_uplo_qtensorc(Tuplo, Tens, idxuplo, idxt, &
permout, alpha, uplo, diag, errst)
type(qtensorc), intent(inout) :: Tuplo
type(qtensorc), intent(inout) :: Tens
integer, dimension(:), intent(in) :: idxuplo, idxt
integer, dimension(:), intent(out), optional :: permout
complex(KIND=rKind), intent(in), optional :: alpha
character, intent(in), optional :: uplo, diag
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, i1, i2
! number of matching blocks, contracted indices
integer :: ni
integer, dimension(:, :), allocatable :: cidx
integer, dimension(:), allocatable :: indout, degout
! Blocks kept
integer, dimension(:), allocatable :: idxkeep
!if(present(errst)) errst = 0
! Check that only on index is contracted
!if(size(idxt) /= 1) then
! errst = raise_error('contr_uplo_qtensorc: size(idxt)', &
! 99, errst=errst)
! return
!end if
! Get indices to be contracted
allocate(cidx(2, Tuplo%nb * Tens%nb), idxkeep(Tens%nb))
call get_contr_idx(Tuplo, idxuplo, Tens, idxt, [.false., .true.], &
cidx, ni, indout, degout, errst=errst)
!if(prop_error('contr_uplo_qtensorc : get_contr_idx '//&
! 'failed', 'ContractionOps_include.f90:2291', errst=errst)) return
do ii = 1, ni
do i2 = degout(ii) + 1, degout(ii + 1)
i1 = indout(i2)
call contr_uplo(Tuplo%Data(cidx(1, i1))%Tens, &
Tens%Data(cidx(2, i1))%Tens, idxuplo, idxt, &
alpha=alpha, uplo=uplo, diag=diag, errst=errst)
!if(prop_error('contr_uplo_qtensorc : contr_uplo'//&
! ' failed', 'ContractionOps_include.f90:2300', errst=errst)) return
end do
end do
! Hashes in Tuplo should be unique, therefore no index in Tens
! should appear twice
idxkeep(:ni) = cidx(2, :ni)
call skim(Tens, ni, idxkeep, errst=errst)
!if(prop_error('contr_uplo_qtensorc : skim '//&
! 'failed', 'ContractionOps_include.f90:2309', errst=errst)) return
deallocate(cidx, idxkeep)
if(ni > 0) deallocate(indout, degout)
if(present(permout)) then
call transposed(Tens, permout, errst=errst)
!if(prop_error('contr_uplo_qtensorc : transpose failed', &
! 'ContractionOps_include.f90:2317', errst=errst)) return
end if
end subroutine contr_uplo_qtensorc
"""
return
[docs]def lcontr_perm():
"""
fortran-subroutine - November 2016 (dj)
Check on necessary permutation before contracting tensor. This is
for the left hand side tensor of the contraction.
**Arguments**
perm : INTEGER(rank), out
Permutation before contracting. If -1, then no permutation
is necessary.
oper : CHARACTER, out
Either 'N' or 'T' serving as transposed flag for GEMM.
idx : INTEGER(\*), in
Those indices are contracted over.
rank : INTEGER, in
Rank of the tensor to be contracted.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine lcontr_perm(perm, oper, idx, rank, errst)
integer, intent(in) :: rank
integer, dimension(rank), intent(out) :: perm
character, intent(out) :: oper
integer, dimension(:), intent(in) :: idx
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj
! number of contracted links
integer :: nc
!if(present(errst)) errst = 0
!if(any(idx > rank)) then
! errst = raise_error('lcontr_perm: idx > rank', &
! 2, errst=errst)
! return
!end if
nc = size(idx)
! Setup array for comparison
perm = [(ii, ii = 1, rank)]
if(all(perm(:nc) == idx)) then
! Use transposed method in LAPACK
perm = -1
oper = 'T'
elseif(all(perm(rank - nc + 1:) == idx)) then
! No need to permute
perm = -1
oper = 'N'
else
! Permute indices to front
oper = 'T'
perm(:nc) = idx
jj = nc + 1
do ii = 1, rank
if(any(ii == idx)) cycle
perm(jj) = ii
jj = jj + 1
end do
end if
end subroutine lcontr_perm
"""
return
[docs]def rcontr_perm():
"""
fortran-subroutine - November 2016 (dj)
Check on necessary permutation before contracting tensor. This is
for the right hand side tensor of the contraction.
**Arguments**
perm : INTEGER(rank), out
Permutation before contracting. If -1, then no permutation
is necessary.
oper : CHARACTER, out
Either 'N' or 'T' serving as transposed flag for GEMM.
idx : INTEGER(\*), in
Those indices are contracted over.
rank : INTEGER, in
Rank of the tensor to be contracted.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine rcontr_perm(perm, oper, idx, rank, errst)
integer, intent(in) :: rank
integer, dimension(rank), intent(out) :: perm
character, intent(out) :: oper
integer, dimension(:), intent(in) :: idx
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj
! number of contracted links
integer :: nc
!if(present(errst)) errst = 0
!if(any(idx > rank)) then
! errst = raise_error('rcontr_perm: idx > rank', &
! 2, errst=errst)
! return
!end if
nc = size(idx)
! Setup array for comparison
perm = [(ii, ii = 1, rank)]
if(all(perm(:nc) == idx)) then
! No need to permute
perm = -1
oper = 'N'
elseif(all(perm(rank - nc + 1:) == idx)) then
! Used transposed method in LAPACK
perm = -1
oper = 'T'
else
! Permute indices to the front
oper = 'N'
perm(:nc) = idx
jj = nc + 1
do ii = 1, rank
if(any(ii == idx)) cycle
perm(jj) = ii
jj = jj + 1
end do
end if
end subroutine rcontr_perm
"""
return
[docs]def contr_diag_tensor_tensor():
"""
fortran-subroutine - November 2016 (dj)
Contract tensor with diagonal matrix represented as rank-1 tensor.
**Arguments**
Tens : TYPE(tensor), inout
Tensor to be contracted with diagonal matrix.
Dtens : TYPE(tensor), in
Diagonal rank-2 tensor represented as rank-1 tensor.
idx : INTEGER, in
Contraction of this index of Tens.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine contr_diag_tensor_tensor(Tens, Dtens, idx, errst)
type(tensor), intent(inout) :: Tens
type(tensor), intent(in) :: Dtens
integer, intent(in) :: idx
integer, intent(out), optional :: errst
! Local variables
! ---------------
! dimensions
integer :: n1, n2, n3
!if(present(errst)) errst = 0
!if(Dtens%rank /= 1) then
! errst = raise_error('DiagContr_tensor_tensor:'//&
! 'Diag tensor is not rank 1', 2, &
! errst=errst)
! return
!end if
!if((idx < 0) .or. (idx > Tens%rank)) then
! errst = raise_error('DiagContr_tensor_tensor:'//&
! 'idx not in range of 0 ... rank', 2, &
! errst=errst)
! return
!end if
!if(Dtens%dl(1) /= Tens%dl(idx)) then
! errst = raise_error('DiagContr_tensor_tensor:'//&
! 'dimension mismatch', 3, &
! errst=errst)
! return
!end if
if(idx == 1) then
! Multiply diagonal from left
n2 = product(Tens%dl(2:))
call diag_times_mat_real_real(Tens%elem, Dtens%elem, &
Tens%dl(1), n2, errst=errst)
elseif(idx == Tens%rank) then
! Multiply diagonal from right
n1 = product(Tens%dl(:Tens%rank - 1))
call mat_times_diag_real_real(Tens%elem, Dtens%elem, &
n1, Tens%dl(Tens%rank), errst=errst)
else
! In the middle
n1 = product(Tens%dl(:idx - 1))
n3 = product(Tens%dl(idx + 1:))
call diag_contr_tensor_real_real(Tens%elem, &
Dtens%elem, n1, Tens%dl(idx), n3, errst=errst)
end if
!if(prop_error('contr_diag_tensor_tensor: failed.', &
! errst=errst)) return
end subroutine contr_diag_tensor_tensor
"""
return
[docs]def contr_diag_tensorc_tensor():
"""
fortran-subroutine - November 2016 (dj)
Contract tensor with diagonal matrix represented as rank-1 tensor.
**Arguments**
Tens : TYPE(tensorc), inout
Tensor to be contracted with diagonal matrix.
Dtens : TYPE(tensor), in
Diagonal rank-2 tensor represented as rank-1 tensor.
idx : INTEGER, in
Contraction of this index of Tens.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine contr_diag_tensorc_tensor(Tens, Dtens, idx, errst)
type(tensorc), intent(inout) :: Tens
type(tensor), intent(in) :: Dtens
integer, intent(in) :: idx
integer, intent(out), optional :: errst
! Local variables
! ---------------
! dimensions
integer :: n1, n2, n3
!if(present(errst)) errst = 0
!if(Dtens%rank /= 1) then
! errst = raise_error('DiagContr_tensorc_tensor:'//&
! 'Diag tensor is not rank 1', 2, &
! errst=errst)
! return
!end if
!if((idx < 0) .or. (idx > Tens%rank)) then
! errst = raise_error('DiagContr_tensorc_tensor:'//&
! 'idx not in range of 0 ... rank', 2, &
! errst=errst)
! return
!end if
!if(Dtens%dl(1) /= Tens%dl(idx)) then
! errst = raise_error('DiagContr_tensorc_tensor:'//&
! 'dimension mismatch', 3, &
! errst=errst)
! return
!end if
if(idx == 1) then
! Multiply diagonal from left
n2 = product(Tens%dl(2:))
call diag_times_mat_complex_real(Tens%elem, Dtens%elem, &
Tens%dl(1), n2, errst=errst)
elseif(idx == Tens%rank) then
! Multiply diagonal from right
n1 = product(Tens%dl(:Tens%rank - 1))
call mat_times_diag_complex_real(Tens%elem, Dtens%elem, &
n1, Tens%dl(Tens%rank), errst=errst)
else
! In the middle
n1 = product(Tens%dl(:idx - 1))
n3 = product(Tens%dl(idx + 1:))
call diag_contr_tensor_complex_real(Tens%elem, &
Dtens%elem, n1, Tens%dl(idx), n3, errst=errst)
end if
!if(prop_error('contr_diag_tensorc_tensor: failed.', &
! errst=errst)) return
end subroutine contr_diag_tensorc_tensor
"""
return
[docs]def contr_diag_tensorc_tensorc():
"""
fortran-subroutine - November 2016 (dj)
Contract tensor with diagonal matrix represented as rank-1 tensor.
**Arguments**
Tens : TYPE(tensorc), inout
Tensor to be contracted with diagonal matrix.
Dtens : TYPE(tensorc), in
Diagonal rank-2 tensor represented as rank-1 tensor.
idx : INTEGER, in
Contraction of this index of Tens.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine contr_diag_tensorc_tensorc(Tens, Dtens, idx, errst)
type(tensorc), intent(inout) :: Tens
type(tensorc), intent(in) :: Dtens
integer, intent(in) :: idx
integer, intent(out), optional :: errst
! Local variables
! ---------------
! dimensions
integer :: n1, n2, n3
!if(present(errst)) errst = 0
!if(Dtens%rank /= 1) then
! errst = raise_error('DiagContr_tensorc_tensorc:'//&
! 'Diag tensor is not rank 1', 2, &
! errst=errst)
! return
!end if
!if((idx < 0) .or. (idx > Tens%rank)) then
! errst = raise_error('DiagContr_tensorc_tensorc:'//&
! 'idx not in range of 0 ... rank', 2, &
! errst=errst)
! return
!end if
!if(Dtens%dl(1) /= Tens%dl(idx)) then
! errst = raise_error('DiagContr_tensorc_tensorc:'//&
! 'dimension mismatch', 3, &
! errst=errst)
! return
!end if
if(idx == 1) then
! Multiply diagonal from left
n2 = product(Tens%dl(2:))
call diag_times_mat_complex_complex(Tens%elem, Dtens%elem, &
Tens%dl(1), n2, errst=errst)
elseif(idx == Tens%rank) then
! Multiply diagonal from right
n1 = product(Tens%dl(:Tens%rank - 1))
call mat_times_diag_complex_complex(Tens%elem, Dtens%elem, &
n1, Tens%dl(Tens%rank), errst=errst)
else
! In the middle
n1 = product(Tens%dl(:idx - 1))
n3 = product(Tens%dl(idx + 1:))
call diag_contr_tensor_complex_complex(Tens%elem, &
Dtens%elem, n1, Tens%dl(idx), n3, errst=errst)
end if
!if(prop_error('contr_diag_tensorc_tensorc: failed.', &
! errst=errst)) return
end subroutine contr_diag_tensorc_tensorc
"""
return
[docs]def contr_diag_qtensor_qtensor():
"""
fortran-subroutine - January 2017 (dj)
Contract tensor with diagonal matrix represented as rank-1 tensor.
**Arguments**
Tens : TYPE(TENSOR_TYPE), inout
Tensor to be contracted with diagonal matrix. Hashes assumed
to be possibly degenerate.
Dtens : TYPE(qtensor), in
Diagonal rank-2 tensor represented as rank-1 tensor. Hashes
assumed to be unique.
idx : INTEGER, in
Contraction of this index of Tens.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine contr_diag_qtensor_qtensor(Tens, Dtens, idx, errst)
type(qtensor), intent(inout) :: Tens
type(qtensor), intent(in) :: Dtens
integer, intent(in) :: idx
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! number of matching blocks, contracted indices
integer :: ni
integer, dimension(:, :), allocatable :: cidx
integer, dimension(:), allocatable :: indout, degout
! Blocks kept
integer, dimension(:), allocatable :: idxkeep
!if(present(errst)) errst = 0
! Get indices to be contracted
allocate(cidx(2, max(Tens%nb, Dtens%nb)), idxkeep(Tens%nb))
call get_contr_idx(Tens, [idx], Dtens, [1], [.true., .false.], cidx, &
ni, indout, degout, do_degout=.false., errst=errst)
!if(prop_error('contr_diag_qtensor_qtensor: get_contr'//&
! '_idx failed.', 'ContractionOps_include.f90:2659', errst=errst)) return
do ii = 1, ni
call contr_diag(Tens%Data(cidx(1, ii))%Tens, &
Dtens%Data(cidx(2, ii))%Tens, idx, errst=errst)
!if(prop_error('contr_diag_qtensor_qtensor: failed.', &
! 'ContractionOps_include.f90:2665', errst=errst)) return
end do
! Hashes in Dtens must be unique, therefore no index in Tens should
! appear twice
idxkeep(:ni) = cidx(1, :ni)
call skim(Tens, ni, idxkeep, errst=errst)
deallocate(cidx, idxkeep)
end subroutine contr_diag_qtensor_qtensor
"""
return
[docs]def contr_diag_qtensorc_qtensor():
"""
fortran-subroutine - January 2017 (dj)
Contract tensor with diagonal matrix represented as rank-1 tensor.
**Arguments**
Tens : TYPE(TENSOR_TYPE), inout
Tensor to be contracted with diagonal matrix. Hashes assumed
to be possibly degenerate.
Dtens : TYPE(qtensor), in
Diagonal rank-2 tensor represented as rank-1 tensor. Hashes
assumed to be unique.
idx : INTEGER, in
Contraction of this index of Tens.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine contr_diag_qtensorc_qtensor(Tens, Dtens, idx, errst)
type(qtensorc), intent(inout) :: Tens
type(qtensor), intent(in) :: Dtens
integer, intent(in) :: idx
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! number of matching blocks, contracted indices
integer :: ni
integer, dimension(:, :), allocatable :: cidx
integer, dimension(:), allocatable :: indout, degout
! Blocks kept
integer, dimension(:), allocatable :: idxkeep
!if(present(errst)) errst = 0
! Get indices to be contracted
allocate(cidx(2, max(Tens%nb, Dtens%nb)), idxkeep(Tens%nb))
call get_contr_idx(Tens, [idx], Dtens, [1], [.true., .false.], cidx, &
ni, indout, degout, do_degout=.false., errst=errst)
!if(prop_error('contr_diag_qtensorc_qtensor: get_contr'//&
! '_idx failed.', 'ContractionOps_include.f90:2659', errst=errst)) return
do ii = 1, ni
call contr_diag(Tens%Data(cidx(1, ii))%Tens, &
Dtens%Data(cidx(2, ii))%Tens, idx, errst=errst)
!if(prop_error('contr_diag_qtensorc_qtensor: failed.', &
! 'ContractionOps_include.f90:2665', errst=errst)) return
end do
! Hashes in Dtens must be unique, therefore no index in Tens should
! appear twice
idxkeep(:ni) = cidx(1, :ni)
call skim(Tens, ni, idxkeep, errst=errst)
deallocate(cidx, idxkeep)
end subroutine contr_diag_qtensorc_qtensor
"""
return
[docs]def contr_diag_qtensorc_qtensorc():
"""
fortran-subroutine - January 2017 (dj)
Contract tensor with diagonal matrix represented as rank-1 tensor.
**Arguments**
Tens : TYPE(TENSOR_TYPE), inout
Tensor to be contracted with diagonal matrix. Hashes assumed
to be possibly degenerate.
Dtens : TYPE(qtensorc), in
Diagonal rank-2 tensor represented as rank-1 tensor. Hashes
assumed to be unique.
idx : INTEGER, in
Contraction of this index of Tens.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine contr_diag_qtensorc_qtensorc(Tens, Dtens, idx, errst)
type(qtensorc), intent(inout) :: Tens
type(qtensorc), intent(in) :: Dtens
integer, intent(in) :: idx
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! number of matching blocks, contracted indices
integer :: ni
integer, dimension(:, :), allocatable :: cidx
integer, dimension(:), allocatable :: indout, degout
! Blocks kept
integer, dimension(:), allocatable :: idxkeep
!if(present(errst)) errst = 0
! Get indices to be contracted
allocate(cidx(2, max(Tens%nb, Dtens%nb)), idxkeep(Tens%nb))
call get_contr_idx(Tens, [idx], Dtens, [1], [.true., .false.], cidx, &
ni, indout, degout, do_degout=.false., errst=errst)
!if(prop_error('contr_diag_qtensorc_qtensorc: get_contr'//&
! '_idx failed.', 'ContractionOps_include.f90:2659', errst=errst)) return
do ii = 1, ni
call contr_diag(Tens%Data(cidx(1, ii))%Tens, &
Dtens%Data(cidx(2, ii))%Tens, idx, errst=errst)
!if(prop_error('contr_diag_qtensorc_qtensorc: failed.', &
! 'ContractionOps_include.f90:2665', errst=errst)) return
end do
! Hashes in Dtens must be unique, therefore no index in Tens should
! appear twice
idxkeep(:ni) = cidx(1, :ni)
call skim(Tens, ni, idxkeep, errst=errst)
deallocate(cidx, idxkeep)
end subroutine contr_diag_qtensorc_qtensorc
"""
return
[docs]def mcontr_tensor_tensor():
"""
fortran-subroutine - September 2017 (dj)
Middle contraction or matrix contraction of a large tensor Tl with a small
matrix Tm to Tc = alpha Tl Tm + beta Tc.
**Arguments**
Tc : TYPE(tensor), inout
Result fo the contraction.
Tl : TYPE(tensor), inout
Multi-link tensor which should be contracted over an interior index.
Tm : TYPE(tensor), inout
Tensor (matrix) contracted over first or last index.
idxl : INTEGER, inout
Index for contraction in Tl.
idxm : INTEGER, inout
Index for contraction in Tm, either 1 or 2.
transl : CHARACTER, inout
"N" for no transformation or "C" for complex conjugate of Tl.
transr : CHARACTER, inout
"N" for no transformation or "C" for complex conjugate of Tm.
alpha : real, inout
Scale contraction of Tl with Tm.
beta : real, inout
Scale incoming tensor Tc.
**Details**
The contr-methods wrapping LAPACK require permutation causing an
overhead which is not compensated for contractions with small matrices. This
is only the case, if one of the middle indices is contracted.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_tensor_tensor(Tc, Tl, Tm, idxl, idxm, &
transl, transr, alpha, beta, errst)
type(tensor), intent(inout) :: Tc
type(tensor), intent(inout) :: Tl
type(tensor), intent(inout) :: Tm
integer, dimension(:), intent(in) :: idxl, idxm
character, intent(in), optional :: transl, transr
real(KIND=rKind), intent(in), optional :: alpha, beta
integer, intent(out), optional :: errst
! Local variables
! ---------------
! distinguish cases
integer :: case
! dimension for contraction
integer :: d1, d3
! dimenions for matrix
integer :: m1, m2
! number of indices contracted
integer :: nn
! dimension of new tensor
integer, dimension(:), allocatable :: newdl
! flag tracking beta zero
logical :: betazero
!if(present(errst)) errst = 0
!if(size(idxl, 1) /= size(idxm, 1)) then
! errst = raise_error('mcontr_tensor_tensor: '//&
! 'rank mismatch.', 99, 'ContractionOps_include.f90:2793', &
! errst=errst)
! return
!end if
!if(any(Tl%dl(idxl) /= Tm%dl(idxm))) then
! errst = raise_error('mcontr_tensor_tensor: '//&
! 'dimension mismatch.', 99, 'ContractionOps_include.f90:2800', &
! errst=errst)
! return
!end if
! 0 : 1.0 * Tl * Tm
! 1 : 1.0 * Conj(Tl) * Tm
! 2 : 1.0 * Tl * Conj(Tm)
! 3 : 1.0 * Conj(Tl) * Conj(Tm)
! 4 : alpha * Tl * Tm
! 5 : alpha * Conj(Tl) * Tm
! 6 : alpha * Tl * Conj(Tm)
! 7 : alpha * Conj(Tl) * Conj(Tm)
case = 0
if(present(transl)) then
if(transl == 'C') case = case + 1
end if
if(present(transr)) then
if(transr == 'C') case = case + 2
end if
if(present(alpha)) then
if(alpha /= 1.0_rKind) case = case + 4
end if
nn = size(idxl, 1)
betazero = .true.
if(present(beta)) betazero = (beta == 0.0_rKind)
if(idxm(1) == 1) then
if(.not. betazero) then
if(abs(1.0_rKind - beta) > 1e-14_rKind) then
call scale(beta, Tc, errst=errst)
!if(prop_error('mcontr_tensor_tensor'//&
! ': scale (1) failed.', 'ContractionOps_include.f90:2837', &
! errst=errst)) return
end if
else
allocate(newdl(Tl%rank))
newdl = Tl%dl
newdl(idxl) = Tm%dl(nn + 1:)
call create(Tc, newdl, init='0')
deallocate(newdl)
end if
d1 = product(Tl%dl(:idxl(1) - 1))
d3 = product(Tl%dl(idxl(nn) + 1:))
m1 = product(Tm%dl(idxm))
m2 = Tm%dim / m1
select case(case)
case(0)
call mcontr_elem_col_one___real_real(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, done)
case(1)
call mcontr_elem_col_one_conjg__real_real(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, done)
case(2)
call mcontr_elem_col_one__conjg_real_real(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, done)
case(3)
call mcontr_elem_col_one_conjg_conjg_real_real(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, done)
case(4)
call mcontr_elem_col_alp___real_real(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, alpha)
case(5)
call mcontr_elem_col_alp_conjg__real_real(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, alpha)
case(6)
call mcontr_elem_col_alp__conjg_real_real(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, alpha)
case(7)
call mcontr_elem_col_alp_conjg_conjg_real_real(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, alpha)
end select
elseif(idxm(nn) == Tm%rank) then
if(.not. betazero) then
if(abs(1.0_rKind - beta) > 1e-14_rKind) then
call scale(beta, Tc, errst=errst)
!if(prop_error('mcontr_tensor_tensor'//&
! ': scale (2) failed.', 'ContractionOps_include.f90:2886', &
! errst=errst)) return
end if
else
allocate(newdl(Tl%rank))
newdl = Tl%dl
newdl(idxl) = Tm%dl(:nn)
call create(Tc, newdl, init='0')
deallocate(newdl)
end if
d1 = product(Tl%dl(:idxl(1) - 1))
d3 = product(Tl%dl(idxl(nn) + 1:))
m2 = product(Tm%dl(idxm))
m1 = Tm%dim / m2
select case(case)
case(0)
call mcontr_elem_row_one___real_real(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, done)
case(1)
call mcontr_elem_row_one_conjg__real_real(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, done)
case(2)
call mcontr_elem_row_one__conjg_real_real(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, done)
case(3)
call mcontr_elem_row_one_conjg_conjg_real_real(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, done)
case(4)
call mcontr_elem_row_alp___real_real(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, alpha)
case(5)
call mcontr_elem_row_alp_conjg__real_real(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, alpha)
case(6)
call mcontr_elem_row_alp__conjg_real_real(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, alpha)
case(7)
call mcontr_elem_row_alp_conjg_conjg_real_real(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, alpha)
end select
else
errst = raise_error('mcontr_tensor_tensor: '//&
'wrong indices.', 99, 'ContractionOps_include.f90:2933', &
errst=errst)
return
end if
end subroutine mcontr_tensor_tensor
"""
return
[docs]def mcontr_tensorc_tensor():
"""
fortran-subroutine - September 2017 (dj)
Middle contraction or matrix contraction of a large tensor Tl with a small
matrix Tm to Tc = alpha Tl Tm + beta Tc.
**Arguments**
Tc : TYPE(tensorc), inout
Result fo the contraction.
Tl : TYPE(tensorc), inout
Multi-link tensor which should be contracted over an interior index.
Tm : TYPE(tensor), inout
Tensor (matrix) contracted over first or last index.
idxl : INTEGER, inout
Index for contraction in Tl.
idxm : INTEGER, inout
Index for contraction in Tm, either 1 or 2.
transl : CHARACTER, inout
"N" for no transformation or "C" for complex conjugate of Tl.
transr : CHARACTER, inout
"N" for no transformation or "C" for complex conjugate of Tm.
alpha : complex, inout
Scale contraction of Tl with Tm.
beta : complex, inout
Scale incoming tensor Tc.
**Details**
The contr-methods wrapping LAPACK require permutation causing an
overhead which is not compensated for contractions with small matrices. This
is only the case, if one of the middle indices is contracted.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_tensorc_tensor(Tc, Tl, Tm, idxl, idxm, &
transl, transr, alpha, beta, errst)
type(tensorc), intent(inout) :: Tc
type(tensorc), intent(inout) :: Tl
type(tensor), intent(inout) :: Tm
integer, dimension(:), intent(in) :: idxl, idxm
character, intent(in), optional :: transl, transr
complex(KIND=rKind), intent(in), optional :: alpha, beta
integer, intent(out), optional :: errst
! Local variables
! ---------------
! distinguish cases
integer :: case
! dimension for contraction
integer :: d1, d3
! dimenions for matrix
integer :: m1, m2
! number of indices contracted
integer :: nn
! dimension of new tensor
integer, dimension(:), allocatable :: newdl
! flag tracking beta zero
logical :: betazero
!if(present(errst)) errst = 0
!if(size(idxl, 1) /= size(idxm, 1)) then
! errst = raise_error('mcontr_tensorc_tensor: '//&
! 'rank mismatch.', 99, 'ContractionOps_include.f90:2793', &
! errst=errst)
! return
!end if
!if(any(Tl%dl(idxl) /= Tm%dl(idxm))) then
! errst = raise_error('mcontr_tensorc_tensor: '//&
! 'dimension mismatch.', 99, 'ContractionOps_include.f90:2800', &
! errst=errst)
! return
!end if
! 0 : 1.0 * Tl * Tm
! 1 : 1.0 * Conj(Tl) * Tm
! 2 : 1.0 * Tl * Conj(Tm)
! 3 : 1.0 * Conj(Tl) * Conj(Tm)
! 4 : alpha * Tl * Tm
! 5 : alpha * Conj(Tl) * Tm
! 6 : alpha * Tl * Conj(Tm)
! 7 : alpha * Conj(Tl) * Conj(Tm)
case = 0
if(present(transl)) then
if(transl == 'C') case = case + 1
end if
if(present(transr)) then
if(transr == 'C') case = case + 2
end if
if(present(alpha)) then
if(alpha /= 1.0_rKind) case = case + 4
end if
nn = size(idxl, 1)
betazero = .true.
if(present(beta)) betazero = (beta == 0.0_rKind)
if(idxm(1) == 1) then
if(.not. betazero) then
if(abs(1.0_rKind - beta) > 1e-14_rKind) then
call scale(beta, Tc, errst=errst)
!if(prop_error('mcontr_tensorc_tensor'//&
! ': scale (1) failed.', 'ContractionOps_include.f90:2837', &
! errst=errst)) return
end if
else
allocate(newdl(Tl%rank))
newdl = Tl%dl
newdl(idxl) = Tm%dl(nn + 1:)
call create(Tc, newdl, init='0')
deallocate(newdl)
end if
d1 = product(Tl%dl(:idxl(1) - 1))
d3 = product(Tl%dl(idxl(nn) + 1:))
m1 = product(Tm%dl(idxm))
m2 = Tm%dim / m1
select case(case)
case(0)
call mcontr_elem_col_one___complex_real(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, zone)
case(1)
call mcontr_elem_col_one_conjg__complex_real(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, zone)
case(2)
call mcontr_elem_col_one__conjg_complex_real(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, zone)
case(3)
call mcontr_elem_col_one_conjg_conjg_complex_real(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, zone)
case(4)
call mcontr_elem_col_alp___complex_real(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, alpha)
case(5)
call mcontr_elem_col_alp_conjg__complex_real(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, alpha)
case(6)
call mcontr_elem_col_alp__conjg_complex_real(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, alpha)
case(7)
call mcontr_elem_col_alp_conjg_conjg_complex_real(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, alpha)
end select
elseif(idxm(nn) == Tm%rank) then
if(.not. betazero) then
if(abs(1.0_rKind - beta) > 1e-14_rKind) then
call scale(beta, Tc, errst=errst)
!if(prop_error('mcontr_tensorc_tensor'//&
! ': scale (2) failed.', 'ContractionOps_include.f90:2886', &
! errst=errst)) return
end if
else
allocate(newdl(Tl%rank))
newdl = Tl%dl
newdl(idxl) = Tm%dl(:nn)
call create(Tc, newdl, init='0')
deallocate(newdl)
end if
d1 = product(Tl%dl(:idxl(1) - 1))
d3 = product(Tl%dl(idxl(nn) + 1:))
m2 = product(Tm%dl(idxm))
m1 = Tm%dim / m2
select case(case)
case(0)
call mcontr_elem_row_one___complex_real(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, zone)
case(1)
call mcontr_elem_row_one_conjg__complex_real(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, zone)
case(2)
call mcontr_elem_row_one__conjg_complex_real(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, zone)
case(3)
call mcontr_elem_row_one_conjg_conjg_complex_real(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, zone)
case(4)
call mcontr_elem_row_alp___complex_real(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, alpha)
case(5)
call mcontr_elem_row_alp_conjg__complex_real(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, alpha)
case(6)
call mcontr_elem_row_alp__conjg_complex_real(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, alpha)
case(7)
call mcontr_elem_row_alp_conjg_conjg_complex_real(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, alpha)
end select
else
errst = raise_error('mcontr_tensorc_tensor: '//&
'wrong indices.', 99, 'ContractionOps_include.f90:2933', &
errst=errst)
return
end if
end subroutine mcontr_tensorc_tensor
"""
return
[docs]def mcontr_tensor_tensorc():
"""
fortran-subroutine - September 2017 (dj)
Middle contraction or matrix contraction of a large tensor Tl with a small
matrix Tm to Tc = alpha Tl Tm + beta Tc.
**Arguments**
Tc : TYPE(tensorc), inout
Result fo the contraction.
Tl : TYPE(tensor), inout
Multi-link tensor which should be contracted over an interior index.
Tm : TYPE(tensorc), inout
Tensor (matrix) contracted over first or last index.
idxl : INTEGER, inout
Index for contraction in Tl.
idxm : INTEGER, inout
Index for contraction in Tm, either 1 or 2.
transl : CHARACTER, inout
"N" for no transformation or "C" for complex conjugate of Tl.
transr : CHARACTER, inout
"N" for no transformation or "C" for complex conjugate of Tm.
alpha : complex, inout
Scale contraction of Tl with Tm.
beta : complex, inout
Scale incoming tensor Tc.
**Details**
The contr-methods wrapping LAPACK require permutation causing an
overhead which is not compensated for contractions with small matrices. This
is only the case, if one of the middle indices is contracted.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_tensor_tensorc(Tc, Tl, Tm, idxl, idxm, &
transl, transr, alpha, beta, errst)
type(tensorc), intent(inout) :: Tc
type(tensor), intent(inout) :: Tl
type(tensorc), intent(inout) :: Tm
integer, dimension(:), intent(in) :: idxl, idxm
character, intent(in), optional :: transl, transr
complex(KIND=rKind), intent(in), optional :: alpha, beta
integer, intent(out), optional :: errst
! Local variables
! ---------------
! distinguish cases
integer :: case
! dimension for contraction
integer :: d1, d3
! dimenions for matrix
integer :: m1, m2
! number of indices contracted
integer :: nn
! dimension of new tensor
integer, dimension(:), allocatable :: newdl
! flag tracking beta zero
logical :: betazero
!if(present(errst)) errst = 0
!if(size(idxl, 1) /= size(idxm, 1)) then
! errst = raise_error('mcontr_tensor_tensorc: '//&
! 'rank mismatch.', 99, 'ContractionOps_include.f90:2793', &
! errst=errst)
! return
!end if
!if(any(Tl%dl(idxl) /= Tm%dl(idxm))) then
! errst = raise_error('mcontr_tensor_tensorc: '//&
! 'dimension mismatch.', 99, 'ContractionOps_include.f90:2800', &
! errst=errst)
! return
!end if
! 0 : 1.0 * Tl * Tm
! 1 : 1.0 * Conj(Tl) * Tm
! 2 : 1.0 * Tl * Conj(Tm)
! 3 : 1.0 * Conj(Tl) * Conj(Tm)
! 4 : alpha * Tl * Tm
! 5 : alpha * Conj(Tl) * Tm
! 6 : alpha * Tl * Conj(Tm)
! 7 : alpha * Conj(Tl) * Conj(Tm)
case = 0
if(present(transl)) then
if(transl == 'C') case = case + 1
end if
if(present(transr)) then
if(transr == 'C') case = case + 2
end if
if(present(alpha)) then
if(alpha /= 1.0_rKind) case = case + 4
end if
nn = size(idxl, 1)
betazero = .true.
if(present(beta)) betazero = (beta == 0.0_rKind)
if(idxm(1) == 1) then
if(.not. betazero) then
if(abs(1.0_rKind - beta) > 1e-14_rKind) then
call scale(beta, Tc, errst=errst)
!if(prop_error('mcontr_tensor_tensorc'//&
! ': scale (1) failed.', 'ContractionOps_include.f90:2837', &
! errst=errst)) return
end if
else
allocate(newdl(Tl%rank))
newdl = Tl%dl
newdl(idxl) = Tm%dl(nn + 1:)
call create(Tc, newdl, init='0')
deallocate(newdl)
end if
d1 = product(Tl%dl(:idxl(1) - 1))
d3 = product(Tl%dl(idxl(nn) + 1:))
m1 = product(Tm%dl(idxm))
m2 = Tm%dim / m1
select case(case)
case(0)
call mcontr_elem_col_one___real_complex(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, zone)
case(1)
call mcontr_elem_col_one_conjg__real_complex(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, zone)
case(2)
call mcontr_elem_col_one__conjg_real_complex(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, zone)
case(3)
call mcontr_elem_col_one_conjg_conjg_real_complex(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, zone)
case(4)
call mcontr_elem_col_alp___real_complex(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, alpha)
case(5)
call mcontr_elem_col_alp_conjg__real_complex(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, alpha)
case(6)
call mcontr_elem_col_alp__conjg_real_complex(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, alpha)
case(7)
call mcontr_elem_col_alp_conjg_conjg_real_complex(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, alpha)
end select
elseif(idxm(nn) == Tm%rank) then
if(.not. betazero) then
if(abs(1.0_rKind - beta) > 1e-14_rKind) then
call scale(beta, Tc, errst=errst)
!if(prop_error('mcontr_tensor_tensorc'//&
! ': scale (2) failed.', 'ContractionOps_include.f90:2886', &
! errst=errst)) return
end if
else
allocate(newdl(Tl%rank))
newdl = Tl%dl
newdl(idxl) = Tm%dl(:nn)
call create(Tc, newdl, init='0')
deallocate(newdl)
end if
d1 = product(Tl%dl(:idxl(1) - 1))
d3 = product(Tl%dl(idxl(nn) + 1:))
m2 = product(Tm%dl(idxm))
m1 = Tm%dim / m2
select case(case)
case(0)
call mcontr_elem_row_one___real_complex(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, zone)
case(1)
call mcontr_elem_row_one_conjg__real_complex(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, zone)
case(2)
call mcontr_elem_row_one__conjg_real_complex(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, zone)
case(3)
call mcontr_elem_row_one_conjg_conjg_real_complex(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, zone)
case(4)
call mcontr_elem_row_alp___real_complex(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, alpha)
case(5)
call mcontr_elem_row_alp_conjg__real_complex(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, alpha)
case(6)
call mcontr_elem_row_alp__conjg_real_complex(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, alpha)
case(7)
call mcontr_elem_row_alp_conjg_conjg_real_complex(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, alpha)
end select
else
errst = raise_error('mcontr_tensor_tensorc: '//&
'wrong indices.', 99, 'ContractionOps_include.f90:2933', &
errst=errst)
return
end if
end subroutine mcontr_tensor_tensorc
"""
return
[docs]def mcontr_tensorc_tensorc():
"""
fortran-subroutine - September 2017 (dj)
Middle contraction or matrix contraction of a large tensor Tl with a small
matrix Tm to Tc = alpha Tl Tm + beta Tc.
**Arguments**
Tc : TYPE(tensorc), inout
Result fo the contraction.
Tl : TYPE(tensorc), inout
Multi-link tensor which should be contracted over an interior index.
Tm : TYPE(tensorc), inout
Tensor (matrix) contracted over first or last index.
idxl : INTEGER, inout
Index for contraction in Tl.
idxm : INTEGER, inout
Index for contraction in Tm, either 1 or 2.
transl : CHARACTER, inout
"N" for no transformation or "C" for complex conjugate of Tl.
transr : CHARACTER, inout
"N" for no transformation or "C" for complex conjugate of Tm.
alpha : complex, inout
Scale contraction of Tl with Tm.
beta : complex, inout
Scale incoming tensor Tc.
**Details**
The contr-methods wrapping LAPACK require permutation causing an
overhead which is not compensated for contractions with small matrices. This
is only the case, if one of the middle indices is contracted.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_tensorc_tensorc(Tc, Tl, Tm, idxl, idxm, &
transl, transr, alpha, beta, errst)
type(tensorc), intent(inout) :: Tc
type(tensorc), intent(inout) :: Tl
type(tensorc), intent(inout) :: Tm
integer, dimension(:), intent(in) :: idxl, idxm
character, intent(in), optional :: transl, transr
complex(KIND=rKind), intent(in), optional :: alpha, beta
integer, intent(out), optional :: errst
! Local variables
! ---------------
! distinguish cases
integer :: case
! dimension for contraction
integer :: d1, d3
! dimenions for matrix
integer :: m1, m2
! number of indices contracted
integer :: nn
! dimension of new tensor
integer, dimension(:), allocatable :: newdl
! flag tracking beta zero
logical :: betazero
!if(present(errst)) errst = 0
!if(size(idxl, 1) /= size(idxm, 1)) then
! errst = raise_error('mcontr_tensorc_tensorc: '//&
! 'rank mismatch.', 99, 'ContractionOps_include.f90:2793', &
! errst=errst)
! return
!end if
!if(any(Tl%dl(idxl) /= Tm%dl(idxm))) then
! errst = raise_error('mcontr_tensorc_tensorc: '//&
! 'dimension mismatch.', 99, 'ContractionOps_include.f90:2800', &
! errst=errst)
! return
!end if
! 0 : 1.0 * Tl * Tm
! 1 : 1.0 * Conj(Tl) * Tm
! 2 : 1.0 * Tl * Conj(Tm)
! 3 : 1.0 * Conj(Tl) * Conj(Tm)
! 4 : alpha * Tl * Tm
! 5 : alpha * Conj(Tl) * Tm
! 6 : alpha * Tl * Conj(Tm)
! 7 : alpha * Conj(Tl) * Conj(Tm)
case = 0
if(present(transl)) then
if(transl == 'C') case = case + 1
end if
if(present(transr)) then
if(transr == 'C') case = case + 2
end if
if(present(alpha)) then
if(alpha /= 1.0_rKind) case = case + 4
end if
nn = size(idxl, 1)
betazero = .true.
if(present(beta)) betazero = (beta == 0.0_rKind)
if(idxm(1) == 1) then
if(.not. betazero) then
if(abs(1.0_rKind - beta) > 1e-14_rKind) then
call scale(beta, Tc, errst=errst)
!if(prop_error('mcontr_tensorc_tensorc'//&
! ': scale (1) failed.', 'ContractionOps_include.f90:2837', &
! errst=errst)) return
end if
else
allocate(newdl(Tl%rank))
newdl = Tl%dl
newdl(idxl) = Tm%dl(nn + 1:)
call create(Tc, newdl, init='0')
deallocate(newdl)
end if
d1 = product(Tl%dl(:idxl(1) - 1))
d3 = product(Tl%dl(idxl(nn) + 1:))
m1 = product(Tm%dl(idxm))
m2 = Tm%dim / m1
select case(case)
case(0)
call mcontr_elem_col_one___complex_complex(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, zone)
case(1)
call mcontr_elem_col_one_conjg__complex_complex(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, zone)
case(2)
call mcontr_elem_col_one__conjg_complex_complex(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, zone)
case(3)
call mcontr_elem_col_one_conjg_conjg_complex_complex(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, zone)
case(4)
call mcontr_elem_col_alp___complex_complex(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, alpha)
case(5)
call mcontr_elem_col_alp_conjg__complex_complex(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, alpha)
case(6)
call mcontr_elem_col_alp__conjg_complex_complex(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, alpha)
case(7)
call mcontr_elem_col_alp_conjg_conjg_complex_complex(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, alpha)
end select
elseif(idxm(nn) == Tm%rank) then
if(.not. betazero) then
if(abs(1.0_rKind - beta) > 1e-14_rKind) then
call scale(beta, Tc, errst=errst)
!if(prop_error('mcontr_tensorc_tensorc'//&
! ': scale (2) failed.', 'ContractionOps_include.f90:2886', &
! errst=errst)) return
end if
else
allocate(newdl(Tl%rank))
newdl = Tl%dl
newdl(idxl) = Tm%dl(:nn)
call create(Tc, newdl, init='0')
deallocate(newdl)
end if
d1 = product(Tl%dl(:idxl(1) - 1))
d3 = product(Tl%dl(idxl(nn) + 1:))
m2 = product(Tm%dl(idxm))
m1 = Tm%dim / m2
select case(case)
case(0)
call mcontr_elem_row_one___complex_complex(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, zone)
case(1)
call mcontr_elem_row_one_conjg__complex_complex(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, zone)
case(2)
call mcontr_elem_row_one__conjg_complex_complex(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, zone)
case(3)
call mcontr_elem_row_one_conjg_conjg_complex_complex(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, zone)
case(4)
call mcontr_elem_row_alp___complex_complex(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, alpha)
case(5)
call mcontr_elem_row_alp_conjg__complex_complex(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, alpha)
case(6)
call mcontr_elem_row_alp__conjg_complex_complex(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, alpha)
case(7)
call mcontr_elem_row_alp_conjg_conjg_complex_complex(&
Tc%elem, Tl%elem, Tm%elem, d1, m1, m2, d3, alpha)
end select
else
errst = raise_error('mcontr_tensorc_tensorc: '//&
'wrong indices.', 99, 'ContractionOps_include.f90:2933', &
errst=errst)
return
end if
end subroutine mcontr_tensorc_tensorc
"""
return
[docs]def mcontr_elem_col_one___real_real():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over column.
**Arguments**
dest : real(\*), inout
Add result of contraction to this array.
src : real(\*), in
Entries of the tensor contracted over interior index.
mat : real(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix.
m2 : INTEGER, inout
Second dimension of the matrix (dimension contracted over).
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : real, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_col_one___real_real(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
real(KIND=rKind), dimension(:), intent(inout) :: dest
real(KIND=rKind), dimension(:), intent(in) :: src
real(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
real(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2
! boundary of block used in src
integer :: j1, j2, j_
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
j1 = 1
j2 = d1
j_ = 1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + (src(j1:j2)) &
* (mat(mm))
mm = mm + 1
j1 = j1 + d1
j2 = j2 + d1
end do
k1 = k1 + d1
k2 = k2 + d1
j1 = j_
j2 = j1 + d1 - 1
end do
j1 = j1 + m1 * d1
j2 = j2 + m1 * d1
j_ = j1
end do
end subroutine mcontr_elem_col_one___real_real
"""
return
[docs]def mcontr_elem_row_one___real_real():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over row.
**Arguments**
dest : real(\*), inout
Add result of contraction to this array.
src : real(\*), in
Entries of the tensor contracted over interior index.
mat : real(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix (dimension contracted over).
m2 : INTEGER, inout
Second dimension of the matrix.
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : real, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_row_one___real_real(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
real(KIND=rKind), dimension(:), intent(inout) :: dest
real(KIND=rKind), dimension(:), intent(in) :: src
real(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
real(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2, k_
! boundary of block used in src
integer :: j1, j2
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
k_ = 1
j1 = 1
j2 = d1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + (src(j1:j2)) &
* (mat(mm))
mm = mm + 1
k1 = k1 + d1
k2 = k2 + d1
end do
j1 = j1 + d1
j2 = j2 + d1
k1 = k_
k2 = k1 + d1 - 1
end do
k1 = k1 + m1 * d1
k2 = k2 + m1 * d1
k_ = k1
end do
end subroutine mcontr_elem_row_one___real_real
"""
return
[docs]def mcontr_elem_col_one_conjg__real_real():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over column.
**Arguments**
dest : real(\*), inout
Add result of contraction to this array.
src : real(\*), in
Entries of the tensor contracted over interior index.
mat : real(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix.
m2 : INTEGER, inout
Second dimension of the matrix (dimension contracted over).
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : real, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_col_one_conjg__real_real(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
real(KIND=rKind), dimension(:), intent(inout) :: dest
real(KIND=rKind), dimension(:), intent(in) :: src
real(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
real(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2
! boundary of block used in src
integer :: j1, j2, j_
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
j1 = 1
j2 = d1
j_ = 1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + (src(j1:j2)) &
* (mat(mm))
mm = mm + 1
j1 = j1 + d1
j2 = j2 + d1
end do
k1 = k1 + d1
k2 = k2 + d1
j1 = j_
j2 = j1 + d1 - 1
end do
j1 = j1 + m1 * d1
j2 = j2 + m1 * d1
j_ = j1
end do
end subroutine mcontr_elem_col_one_conjg__real_real
"""
return
[docs]def mcontr_elem_row_one_conjg__real_real():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over row.
**Arguments**
dest : real(\*), inout
Add result of contraction to this array.
src : real(\*), in
Entries of the tensor contracted over interior index.
mat : real(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix (dimension contracted over).
m2 : INTEGER, inout
Second dimension of the matrix.
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : real, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_row_one_conjg__real_real(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
real(KIND=rKind), dimension(:), intent(inout) :: dest
real(KIND=rKind), dimension(:), intent(in) :: src
real(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
real(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2, k_
! boundary of block used in src
integer :: j1, j2
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
k_ = 1
j1 = 1
j2 = d1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + (src(j1:j2)) &
* (mat(mm))
mm = mm + 1
k1 = k1 + d1
k2 = k2 + d1
end do
j1 = j1 + d1
j2 = j2 + d1
k1 = k_
k2 = k1 + d1 - 1
end do
k1 = k1 + m1 * d1
k2 = k2 + m1 * d1
k_ = k1
end do
end subroutine mcontr_elem_row_one_conjg__real_real
"""
return
[docs]def mcontr_elem_col_one__conjg_real_real():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over column.
**Arguments**
dest : real(\*), inout
Add result of contraction to this array.
src : real(\*), in
Entries of the tensor contracted over interior index.
mat : real(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix.
m2 : INTEGER, inout
Second dimension of the matrix (dimension contracted over).
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : real, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_col_one__conjg_real_real(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
real(KIND=rKind), dimension(:), intent(inout) :: dest
real(KIND=rKind), dimension(:), intent(in) :: src
real(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
real(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2
! boundary of block used in src
integer :: j1, j2, j_
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
j1 = 1
j2 = d1
j_ = 1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + (src(j1:j2)) &
* (mat(mm))
mm = mm + 1
j1 = j1 + d1
j2 = j2 + d1
end do
k1 = k1 + d1
k2 = k2 + d1
j1 = j_
j2 = j1 + d1 - 1
end do
j1 = j1 + m1 * d1
j2 = j2 + m1 * d1
j_ = j1
end do
end subroutine mcontr_elem_col_one__conjg_real_real
"""
return
[docs]def mcontr_elem_row_one__conjg_real_real():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over row.
**Arguments**
dest : real(\*), inout
Add result of contraction to this array.
src : real(\*), in
Entries of the tensor contracted over interior index.
mat : real(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix (dimension contracted over).
m2 : INTEGER, inout
Second dimension of the matrix.
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : real, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_row_one__conjg_real_real(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
real(KIND=rKind), dimension(:), intent(inout) :: dest
real(KIND=rKind), dimension(:), intent(in) :: src
real(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
real(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2, k_
! boundary of block used in src
integer :: j1, j2
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
k_ = 1
j1 = 1
j2 = d1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + (src(j1:j2)) &
* (mat(mm))
mm = mm + 1
k1 = k1 + d1
k2 = k2 + d1
end do
j1 = j1 + d1
j2 = j2 + d1
k1 = k_
k2 = k1 + d1 - 1
end do
k1 = k1 + m1 * d1
k2 = k2 + m1 * d1
k_ = k1
end do
end subroutine mcontr_elem_row_one__conjg_real_real
"""
return
[docs]def mcontr_elem_col_one_conjg_conjg_real_real():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over column.
**Arguments**
dest : real(\*), inout
Add result of contraction to this array.
src : real(\*), in
Entries of the tensor contracted over interior index.
mat : real(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix.
m2 : INTEGER, inout
Second dimension of the matrix (dimension contracted over).
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : real, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_col_one_conjg_conjg_real_real(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
real(KIND=rKind), dimension(:), intent(inout) :: dest
real(KIND=rKind), dimension(:), intent(in) :: src
real(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
real(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2
! boundary of block used in src
integer :: j1, j2, j_
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
j1 = 1
j2 = d1
j_ = 1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + (src(j1:j2)) &
* (mat(mm))
mm = mm + 1
j1 = j1 + d1
j2 = j2 + d1
end do
k1 = k1 + d1
k2 = k2 + d1
j1 = j_
j2 = j1 + d1 - 1
end do
j1 = j1 + m1 * d1
j2 = j2 + m1 * d1
j_ = j1
end do
end subroutine mcontr_elem_col_one_conjg_conjg_real_real
"""
return
[docs]def mcontr_elem_row_one_conjg_conjg_real_real():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over row.
**Arguments**
dest : real(\*), inout
Add result of contraction to this array.
src : real(\*), in
Entries of the tensor contracted over interior index.
mat : real(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix (dimension contracted over).
m2 : INTEGER, inout
Second dimension of the matrix.
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : real, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_row_one_conjg_conjg_real_real(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
real(KIND=rKind), dimension(:), intent(inout) :: dest
real(KIND=rKind), dimension(:), intent(in) :: src
real(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
real(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2, k_
! boundary of block used in src
integer :: j1, j2
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
k_ = 1
j1 = 1
j2 = d1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + (src(j1:j2)) &
* (mat(mm))
mm = mm + 1
k1 = k1 + d1
k2 = k2 + d1
end do
j1 = j1 + d1
j2 = j2 + d1
k1 = k_
k2 = k1 + d1 - 1
end do
k1 = k1 + m1 * d1
k2 = k2 + m1 * d1
k_ = k1
end do
end subroutine mcontr_elem_row_one_conjg_conjg_real_real
"""
return
[docs]def mcontr_elem_col_alp___real_real():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over column.
**Arguments**
dest : real(\*), inout
Add result of contraction to this array.
src : real(\*), in
Entries of the tensor contracted over interior index.
mat : real(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix.
m2 : INTEGER, inout
Second dimension of the matrix (dimension contracted over).
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : real, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_col_alp___real_real(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
real(KIND=rKind), dimension(:), intent(inout) :: dest
real(KIND=rKind), dimension(:), intent(in) :: src
real(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
real(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2
! boundary of block used in src
integer :: j1, j2, j_
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
j1 = 1
j2 = d1
j_ = 1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + alpha* (src(j1:j2)) &
* (mat(mm))
mm = mm + 1
j1 = j1 + d1
j2 = j2 + d1
end do
k1 = k1 + d1
k2 = k2 + d1
j1 = j_
j2 = j1 + d1 - 1
end do
j1 = j1 + m1 * d1
j2 = j2 + m1 * d1
j_ = j1
end do
end subroutine mcontr_elem_col_alp___real_real
"""
return
[docs]def mcontr_elem_row_alp___real_real():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over row.
**Arguments**
dest : real(\*), inout
Add result of contraction to this array.
src : real(\*), in
Entries of the tensor contracted over interior index.
mat : real(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix (dimension contracted over).
m2 : INTEGER, inout
Second dimension of the matrix.
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : real, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_row_alp___real_real(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
real(KIND=rKind), dimension(:), intent(inout) :: dest
real(KIND=rKind), dimension(:), intent(in) :: src
real(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
real(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2, k_
! boundary of block used in src
integer :: j1, j2
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
k_ = 1
j1 = 1
j2 = d1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + alpha* (src(j1:j2)) &
* (mat(mm))
mm = mm + 1
k1 = k1 + d1
k2 = k2 + d1
end do
j1 = j1 + d1
j2 = j2 + d1
k1 = k_
k2 = k1 + d1 - 1
end do
k1 = k1 + m1 * d1
k2 = k2 + m1 * d1
k_ = k1
end do
end subroutine mcontr_elem_row_alp___real_real
"""
return
[docs]def mcontr_elem_col_alp_conjg__real_real():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over column.
**Arguments**
dest : real(\*), inout
Add result of contraction to this array.
src : real(\*), in
Entries of the tensor contracted over interior index.
mat : real(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix.
m2 : INTEGER, inout
Second dimension of the matrix (dimension contracted over).
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : real, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_col_alp_conjg__real_real(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
real(KIND=rKind), dimension(:), intent(inout) :: dest
real(KIND=rKind), dimension(:), intent(in) :: src
real(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
real(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2
! boundary of block used in src
integer :: j1, j2, j_
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
j1 = 1
j2 = d1
j_ = 1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + alpha* (src(j1:j2)) &
* (mat(mm))
mm = mm + 1
j1 = j1 + d1
j2 = j2 + d1
end do
k1 = k1 + d1
k2 = k2 + d1
j1 = j_
j2 = j1 + d1 - 1
end do
j1 = j1 + m1 * d1
j2 = j2 + m1 * d1
j_ = j1
end do
end subroutine mcontr_elem_col_alp_conjg__real_real
"""
return
[docs]def mcontr_elem_row_alp_conjg__real_real():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over row.
**Arguments**
dest : real(\*), inout
Add result of contraction to this array.
src : real(\*), in
Entries of the tensor contracted over interior index.
mat : real(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix (dimension contracted over).
m2 : INTEGER, inout
Second dimension of the matrix.
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : real, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_row_alp_conjg__real_real(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
real(KIND=rKind), dimension(:), intent(inout) :: dest
real(KIND=rKind), dimension(:), intent(in) :: src
real(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
real(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2, k_
! boundary of block used in src
integer :: j1, j2
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
k_ = 1
j1 = 1
j2 = d1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + alpha* (src(j1:j2)) &
* (mat(mm))
mm = mm + 1
k1 = k1 + d1
k2 = k2 + d1
end do
j1 = j1 + d1
j2 = j2 + d1
k1 = k_
k2 = k1 + d1 - 1
end do
k1 = k1 + m1 * d1
k2 = k2 + m1 * d1
k_ = k1
end do
end subroutine mcontr_elem_row_alp_conjg__real_real
"""
return
[docs]def mcontr_elem_col_alp__conjg_real_real():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over column.
**Arguments**
dest : real(\*), inout
Add result of contraction to this array.
src : real(\*), in
Entries of the tensor contracted over interior index.
mat : real(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix.
m2 : INTEGER, inout
Second dimension of the matrix (dimension contracted over).
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : real, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_col_alp__conjg_real_real(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
real(KIND=rKind), dimension(:), intent(inout) :: dest
real(KIND=rKind), dimension(:), intent(in) :: src
real(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
real(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2
! boundary of block used in src
integer :: j1, j2, j_
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
j1 = 1
j2 = d1
j_ = 1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + alpha* (src(j1:j2)) &
* (mat(mm))
mm = mm + 1
j1 = j1 + d1
j2 = j2 + d1
end do
k1 = k1 + d1
k2 = k2 + d1
j1 = j_
j2 = j1 + d1 - 1
end do
j1 = j1 + m1 * d1
j2 = j2 + m1 * d1
j_ = j1
end do
end subroutine mcontr_elem_col_alp__conjg_real_real
"""
return
[docs]def mcontr_elem_row_alp__conjg_real_real():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over row.
**Arguments**
dest : real(\*), inout
Add result of contraction to this array.
src : real(\*), in
Entries of the tensor contracted over interior index.
mat : real(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix (dimension contracted over).
m2 : INTEGER, inout
Second dimension of the matrix.
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : real, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_row_alp__conjg_real_real(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
real(KIND=rKind), dimension(:), intent(inout) :: dest
real(KIND=rKind), dimension(:), intent(in) :: src
real(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
real(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2, k_
! boundary of block used in src
integer :: j1, j2
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
k_ = 1
j1 = 1
j2 = d1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + alpha* (src(j1:j2)) &
* (mat(mm))
mm = mm + 1
k1 = k1 + d1
k2 = k2 + d1
end do
j1 = j1 + d1
j2 = j2 + d1
k1 = k_
k2 = k1 + d1 - 1
end do
k1 = k1 + m1 * d1
k2 = k2 + m1 * d1
k_ = k1
end do
end subroutine mcontr_elem_row_alp__conjg_real_real
"""
return
[docs]def mcontr_elem_col_alp_conjg_conjg_real_real():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over column.
**Arguments**
dest : real(\*), inout
Add result of contraction to this array.
src : real(\*), in
Entries of the tensor contracted over interior index.
mat : real(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix.
m2 : INTEGER, inout
Second dimension of the matrix (dimension contracted over).
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : real, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_col_alp_conjg_conjg_real_real(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
real(KIND=rKind), dimension(:), intent(inout) :: dest
real(KIND=rKind), dimension(:), intent(in) :: src
real(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
real(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2
! boundary of block used in src
integer :: j1, j2, j_
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
j1 = 1
j2 = d1
j_ = 1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + alpha* (src(j1:j2)) &
* (mat(mm))
mm = mm + 1
j1 = j1 + d1
j2 = j2 + d1
end do
k1 = k1 + d1
k2 = k2 + d1
j1 = j_
j2 = j1 + d1 - 1
end do
j1 = j1 + m1 * d1
j2 = j2 + m1 * d1
j_ = j1
end do
end subroutine mcontr_elem_col_alp_conjg_conjg_real_real
"""
return
[docs]def mcontr_elem_row_alp_conjg_conjg_real_real():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over row.
**Arguments**
dest : real(\*), inout
Add result of contraction to this array.
src : real(\*), in
Entries of the tensor contracted over interior index.
mat : real(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix (dimension contracted over).
m2 : INTEGER, inout
Second dimension of the matrix.
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : real, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_row_alp_conjg_conjg_real_real(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
real(KIND=rKind), dimension(:), intent(inout) :: dest
real(KIND=rKind), dimension(:), intent(in) :: src
real(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
real(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2, k_
! boundary of block used in src
integer :: j1, j2
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
k_ = 1
j1 = 1
j2 = d1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + alpha* (src(j1:j2)) &
* (mat(mm))
mm = mm + 1
k1 = k1 + d1
k2 = k2 + d1
end do
j1 = j1 + d1
j2 = j2 + d1
k1 = k_
k2 = k1 + d1 - 1
end do
k1 = k1 + m1 * d1
k2 = k2 + m1 * d1
k_ = k1
end do
end subroutine mcontr_elem_row_alp_conjg_conjg_real_real
"""
return
[docs]def mcontr_elem_col_one___complex_real():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over column.
**Arguments**
dest : complex(\*), inout
Add result of contraction to this array.
src : complex(\*), in
Entries of the tensor contracted over interior index.
mat : real(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix.
m2 : INTEGER, inout
Second dimension of the matrix (dimension contracted over).
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : complex, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_col_one___complex_real(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
complex(KIND=rKind), dimension(:), intent(inout) :: dest
complex(KIND=rKind), dimension(:), intent(in) :: src
real(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
complex(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2
! boundary of block used in src
integer :: j1, j2, j_
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
j1 = 1
j2 = d1
j_ = 1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + (src(j1:j2)) &
* (mat(mm))
mm = mm + 1
j1 = j1 + d1
j2 = j2 + d1
end do
k1 = k1 + d1
k2 = k2 + d1
j1 = j_
j2 = j1 + d1 - 1
end do
j1 = j1 + m1 * d1
j2 = j2 + m1 * d1
j_ = j1
end do
end subroutine mcontr_elem_col_one___complex_real
"""
return
[docs]def mcontr_elem_row_one___complex_real():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over row.
**Arguments**
dest : complex(\*), inout
Add result of contraction to this array.
src : complex(\*), in
Entries of the tensor contracted over interior index.
mat : real(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix (dimension contracted over).
m2 : INTEGER, inout
Second dimension of the matrix.
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : complex, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_row_one___complex_real(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
complex(KIND=rKind), dimension(:), intent(inout) :: dest
complex(KIND=rKind), dimension(:), intent(in) :: src
real(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
complex(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2, k_
! boundary of block used in src
integer :: j1, j2
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
k_ = 1
j1 = 1
j2 = d1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + (src(j1:j2)) &
* (mat(mm))
mm = mm + 1
k1 = k1 + d1
k2 = k2 + d1
end do
j1 = j1 + d1
j2 = j2 + d1
k1 = k_
k2 = k1 + d1 - 1
end do
k1 = k1 + m1 * d1
k2 = k2 + m1 * d1
k_ = k1
end do
end subroutine mcontr_elem_row_one___complex_real
"""
return
[docs]def mcontr_elem_col_one_conjg__complex_real():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over column.
**Arguments**
dest : complex(\*), inout
Add result of contraction to this array.
src : complex(\*), in
Entries of the tensor contracted over interior index.
mat : real(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix.
m2 : INTEGER, inout
Second dimension of the matrix (dimension contracted over).
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : complex, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_col_one_conjg__complex_real(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
complex(KIND=rKind), dimension(:), intent(inout) :: dest
complex(KIND=rKind), dimension(:), intent(in) :: src
real(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
complex(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2
! boundary of block used in src
integer :: j1, j2, j_
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
j1 = 1
j2 = d1
j_ = 1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + conjg(src(j1:j2)) &
* (mat(mm))
mm = mm + 1
j1 = j1 + d1
j2 = j2 + d1
end do
k1 = k1 + d1
k2 = k2 + d1
j1 = j_
j2 = j1 + d1 - 1
end do
j1 = j1 + m1 * d1
j2 = j2 + m1 * d1
j_ = j1
end do
end subroutine mcontr_elem_col_one_conjg__complex_real
"""
return
[docs]def mcontr_elem_row_one_conjg__complex_real():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over row.
**Arguments**
dest : complex(\*), inout
Add result of contraction to this array.
src : complex(\*), in
Entries of the tensor contracted over interior index.
mat : real(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix (dimension contracted over).
m2 : INTEGER, inout
Second dimension of the matrix.
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : complex, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_row_one_conjg__complex_real(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
complex(KIND=rKind), dimension(:), intent(inout) :: dest
complex(KIND=rKind), dimension(:), intent(in) :: src
real(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
complex(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2, k_
! boundary of block used in src
integer :: j1, j2
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
k_ = 1
j1 = 1
j2 = d1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + conjg(src(j1:j2)) &
* (mat(mm))
mm = mm + 1
k1 = k1 + d1
k2 = k2 + d1
end do
j1 = j1 + d1
j2 = j2 + d1
k1 = k_
k2 = k1 + d1 - 1
end do
k1 = k1 + m1 * d1
k2 = k2 + m1 * d1
k_ = k1
end do
end subroutine mcontr_elem_row_one_conjg__complex_real
"""
return
[docs]def mcontr_elem_col_one__conjg_complex_real():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over column.
**Arguments**
dest : complex(\*), inout
Add result of contraction to this array.
src : complex(\*), in
Entries of the tensor contracted over interior index.
mat : real(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix.
m2 : INTEGER, inout
Second dimension of the matrix (dimension contracted over).
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : complex, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_col_one__conjg_complex_real(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
complex(KIND=rKind), dimension(:), intent(inout) :: dest
complex(KIND=rKind), dimension(:), intent(in) :: src
real(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
complex(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2
! boundary of block used in src
integer :: j1, j2, j_
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
j1 = 1
j2 = d1
j_ = 1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + (src(j1:j2)) &
* (mat(mm))
mm = mm + 1
j1 = j1 + d1
j2 = j2 + d1
end do
k1 = k1 + d1
k2 = k2 + d1
j1 = j_
j2 = j1 + d1 - 1
end do
j1 = j1 + m1 * d1
j2 = j2 + m1 * d1
j_ = j1
end do
end subroutine mcontr_elem_col_one__conjg_complex_real
"""
return
[docs]def mcontr_elem_row_one__conjg_complex_real():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over row.
**Arguments**
dest : complex(\*), inout
Add result of contraction to this array.
src : complex(\*), in
Entries of the tensor contracted over interior index.
mat : real(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix (dimension contracted over).
m2 : INTEGER, inout
Second dimension of the matrix.
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : complex, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_row_one__conjg_complex_real(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
complex(KIND=rKind), dimension(:), intent(inout) :: dest
complex(KIND=rKind), dimension(:), intent(in) :: src
real(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
complex(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2, k_
! boundary of block used in src
integer :: j1, j2
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
k_ = 1
j1 = 1
j2 = d1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + (src(j1:j2)) &
* (mat(mm))
mm = mm + 1
k1 = k1 + d1
k2 = k2 + d1
end do
j1 = j1 + d1
j2 = j2 + d1
k1 = k_
k2 = k1 + d1 - 1
end do
k1 = k1 + m1 * d1
k2 = k2 + m1 * d1
k_ = k1
end do
end subroutine mcontr_elem_row_one__conjg_complex_real
"""
return
[docs]def mcontr_elem_col_one_conjg_conjg_complex_real():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over column.
**Arguments**
dest : complex(\*), inout
Add result of contraction to this array.
src : complex(\*), in
Entries of the tensor contracted over interior index.
mat : real(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix.
m2 : INTEGER, inout
Second dimension of the matrix (dimension contracted over).
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : complex, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_col_one_conjg_conjg_complex_real(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
complex(KIND=rKind), dimension(:), intent(inout) :: dest
complex(KIND=rKind), dimension(:), intent(in) :: src
real(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
complex(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2
! boundary of block used in src
integer :: j1, j2, j_
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
j1 = 1
j2 = d1
j_ = 1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + conjg(src(j1:j2)) &
* (mat(mm))
mm = mm + 1
j1 = j1 + d1
j2 = j2 + d1
end do
k1 = k1 + d1
k2 = k2 + d1
j1 = j_
j2 = j1 + d1 - 1
end do
j1 = j1 + m1 * d1
j2 = j2 + m1 * d1
j_ = j1
end do
end subroutine mcontr_elem_col_one_conjg_conjg_complex_real
"""
return
[docs]def mcontr_elem_row_one_conjg_conjg_complex_real():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over row.
**Arguments**
dest : complex(\*), inout
Add result of contraction to this array.
src : complex(\*), in
Entries of the tensor contracted over interior index.
mat : real(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix (dimension contracted over).
m2 : INTEGER, inout
Second dimension of the matrix.
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : complex, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_row_one_conjg_conjg_complex_real(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
complex(KIND=rKind), dimension(:), intent(inout) :: dest
complex(KIND=rKind), dimension(:), intent(in) :: src
real(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
complex(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2, k_
! boundary of block used in src
integer :: j1, j2
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
k_ = 1
j1 = 1
j2 = d1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + conjg(src(j1:j2)) &
* (mat(mm))
mm = mm + 1
k1 = k1 + d1
k2 = k2 + d1
end do
j1 = j1 + d1
j2 = j2 + d1
k1 = k_
k2 = k1 + d1 - 1
end do
k1 = k1 + m1 * d1
k2 = k2 + m1 * d1
k_ = k1
end do
end subroutine mcontr_elem_row_one_conjg_conjg_complex_real
"""
return
[docs]def mcontr_elem_col_alp___complex_real():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over column.
**Arguments**
dest : complex(\*), inout
Add result of contraction to this array.
src : complex(\*), in
Entries of the tensor contracted over interior index.
mat : real(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix.
m2 : INTEGER, inout
Second dimension of the matrix (dimension contracted over).
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : complex, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_col_alp___complex_real(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
complex(KIND=rKind), dimension(:), intent(inout) :: dest
complex(KIND=rKind), dimension(:), intent(in) :: src
real(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
complex(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2
! boundary of block used in src
integer :: j1, j2, j_
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
j1 = 1
j2 = d1
j_ = 1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + alpha* (src(j1:j2)) &
* (mat(mm))
mm = mm + 1
j1 = j1 + d1
j2 = j2 + d1
end do
k1 = k1 + d1
k2 = k2 + d1
j1 = j_
j2 = j1 + d1 - 1
end do
j1 = j1 + m1 * d1
j2 = j2 + m1 * d1
j_ = j1
end do
end subroutine mcontr_elem_col_alp___complex_real
"""
return
[docs]def mcontr_elem_row_alp___complex_real():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over row.
**Arguments**
dest : complex(\*), inout
Add result of contraction to this array.
src : complex(\*), in
Entries of the tensor contracted over interior index.
mat : real(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix (dimension contracted over).
m2 : INTEGER, inout
Second dimension of the matrix.
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : complex, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_row_alp___complex_real(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
complex(KIND=rKind), dimension(:), intent(inout) :: dest
complex(KIND=rKind), dimension(:), intent(in) :: src
real(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
complex(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2, k_
! boundary of block used in src
integer :: j1, j2
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
k_ = 1
j1 = 1
j2 = d1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + alpha* (src(j1:j2)) &
* (mat(mm))
mm = mm + 1
k1 = k1 + d1
k2 = k2 + d1
end do
j1 = j1 + d1
j2 = j2 + d1
k1 = k_
k2 = k1 + d1 - 1
end do
k1 = k1 + m1 * d1
k2 = k2 + m1 * d1
k_ = k1
end do
end subroutine mcontr_elem_row_alp___complex_real
"""
return
[docs]def mcontr_elem_col_alp_conjg__complex_real():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over column.
**Arguments**
dest : complex(\*), inout
Add result of contraction to this array.
src : complex(\*), in
Entries of the tensor contracted over interior index.
mat : real(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix.
m2 : INTEGER, inout
Second dimension of the matrix (dimension contracted over).
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : complex, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_col_alp_conjg__complex_real(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
complex(KIND=rKind), dimension(:), intent(inout) :: dest
complex(KIND=rKind), dimension(:), intent(in) :: src
real(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
complex(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2
! boundary of block used in src
integer :: j1, j2, j_
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
j1 = 1
j2 = d1
j_ = 1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + alpha* conjg(src(j1:j2)) &
* (mat(mm))
mm = mm + 1
j1 = j1 + d1
j2 = j2 + d1
end do
k1 = k1 + d1
k2 = k2 + d1
j1 = j_
j2 = j1 + d1 - 1
end do
j1 = j1 + m1 * d1
j2 = j2 + m1 * d1
j_ = j1
end do
end subroutine mcontr_elem_col_alp_conjg__complex_real
"""
return
[docs]def mcontr_elem_row_alp_conjg__complex_real():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over row.
**Arguments**
dest : complex(\*), inout
Add result of contraction to this array.
src : complex(\*), in
Entries of the tensor contracted over interior index.
mat : real(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix (dimension contracted over).
m2 : INTEGER, inout
Second dimension of the matrix.
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : complex, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_row_alp_conjg__complex_real(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
complex(KIND=rKind), dimension(:), intent(inout) :: dest
complex(KIND=rKind), dimension(:), intent(in) :: src
real(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
complex(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2, k_
! boundary of block used in src
integer :: j1, j2
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
k_ = 1
j1 = 1
j2 = d1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + alpha* conjg(src(j1:j2)) &
* (mat(mm))
mm = mm + 1
k1 = k1 + d1
k2 = k2 + d1
end do
j1 = j1 + d1
j2 = j2 + d1
k1 = k_
k2 = k1 + d1 - 1
end do
k1 = k1 + m1 * d1
k2 = k2 + m1 * d1
k_ = k1
end do
end subroutine mcontr_elem_row_alp_conjg__complex_real
"""
return
[docs]def mcontr_elem_col_alp__conjg_complex_real():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over column.
**Arguments**
dest : complex(\*), inout
Add result of contraction to this array.
src : complex(\*), in
Entries of the tensor contracted over interior index.
mat : real(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix.
m2 : INTEGER, inout
Second dimension of the matrix (dimension contracted over).
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : complex, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_col_alp__conjg_complex_real(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
complex(KIND=rKind), dimension(:), intent(inout) :: dest
complex(KIND=rKind), dimension(:), intent(in) :: src
real(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
complex(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2
! boundary of block used in src
integer :: j1, j2, j_
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
j1 = 1
j2 = d1
j_ = 1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + alpha* (src(j1:j2)) &
* (mat(mm))
mm = mm + 1
j1 = j1 + d1
j2 = j2 + d1
end do
k1 = k1 + d1
k2 = k2 + d1
j1 = j_
j2 = j1 + d1 - 1
end do
j1 = j1 + m1 * d1
j2 = j2 + m1 * d1
j_ = j1
end do
end subroutine mcontr_elem_col_alp__conjg_complex_real
"""
return
[docs]def mcontr_elem_row_alp__conjg_complex_real():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over row.
**Arguments**
dest : complex(\*), inout
Add result of contraction to this array.
src : complex(\*), in
Entries of the tensor contracted over interior index.
mat : real(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix (dimension contracted over).
m2 : INTEGER, inout
Second dimension of the matrix.
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : complex, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_row_alp__conjg_complex_real(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
complex(KIND=rKind), dimension(:), intent(inout) :: dest
complex(KIND=rKind), dimension(:), intent(in) :: src
real(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
complex(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2, k_
! boundary of block used in src
integer :: j1, j2
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
k_ = 1
j1 = 1
j2 = d1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + alpha* (src(j1:j2)) &
* (mat(mm))
mm = mm + 1
k1 = k1 + d1
k2 = k2 + d1
end do
j1 = j1 + d1
j2 = j2 + d1
k1 = k_
k2 = k1 + d1 - 1
end do
k1 = k1 + m1 * d1
k2 = k2 + m1 * d1
k_ = k1
end do
end subroutine mcontr_elem_row_alp__conjg_complex_real
"""
return
[docs]def mcontr_elem_col_alp_conjg_conjg_complex_real():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over column.
**Arguments**
dest : complex(\*), inout
Add result of contraction to this array.
src : complex(\*), in
Entries of the tensor contracted over interior index.
mat : real(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix.
m2 : INTEGER, inout
Second dimension of the matrix (dimension contracted over).
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : complex, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_col_alp_conjg_conjg_complex_real(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
complex(KIND=rKind), dimension(:), intent(inout) :: dest
complex(KIND=rKind), dimension(:), intent(in) :: src
real(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
complex(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2
! boundary of block used in src
integer :: j1, j2, j_
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
j1 = 1
j2 = d1
j_ = 1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + alpha* conjg(src(j1:j2)) &
* (mat(mm))
mm = mm + 1
j1 = j1 + d1
j2 = j2 + d1
end do
k1 = k1 + d1
k2 = k2 + d1
j1 = j_
j2 = j1 + d1 - 1
end do
j1 = j1 + m1 * d1
j2 = j2 + m1 * d1
j_ = j1
end do
end subroutine mcontr_elem_col_alp_conjg_conjg_complex_real
"""
return
[docs]def mcontr_elem_row_alp_conjg_conjg_complex_real():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over row.
**Arguments**
dest : complex(\*), inout
Add result of contraction to this array.
src : complex(\*), in
Entries of the tensor contracted over interior index.
mat : real(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix (dimension contracted over).
m2 : INTEGER, inout
Second dimension of the matrix.
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : complex, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_row_alp_conjg_conjg_complex_real(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
complex(KIND=rKind), dimension(:), intent(inout) :: dest
complex(KIND=rKind), dimension(:), intent(in) :: src
real(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
complex(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2, k_
! boundary of block used in src
integer :: j1, j2
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
k_ = 1
j1 = 1
j2 = d1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + alpha* conjg(src(j1:j2)) &
* (mat(mm))
mm = mm + 1
k1 = k1 + d1
k2 = k2 + d1
end do
j1 = j1 + d1
j2 = j2 + d1
k1 = k_
k2 = k1 + d1 - 1
end do
k1 = k1 + m1 * d1
k2 = k2 + m1 * d1
k_ = k1
end do
end subroutine mcontr_elem_row_alp_conjg_conjg_complex_real
"""
return
[docs]def mcontr_elem_col_one___complex_complex():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over column.
**Arguments**
dest : complex(\*), inout
Add result of contraction to this array.
src : complex(\*), in
Entries of the tensor contracted over interior index.
mat : complex(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix.
m2 : INTEGER, inout
Second dimension of the matrix (dimension contracted over).
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : complex, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_col_one___complex_complex(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
complex(KIND=rKind), dimension(:), intent(inout) :: dest
complex(KIND=rKind), dimension(:), intent(in) :: src
complex(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
complex(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2
! boundary of block used in src
integer :: j1, j2, j_
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
j1 = 1
j2 = d1
j_ = 1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + (src(j1:j2)) &
* (mat(mm))
mm = mm + 1
j1 = j1 + d1
j2 = j2 + d1
end do
k1 = k1 + d1
k2 = k2 + d1
j1 = j_
j2 = j1 + d1 - 1
end do
j1 = j1 + m1 * d1
j2 = j2 + m1 * d1
j_ = j1
end do
end subroutine mcontr_elem_col_one___complex_complex
"""
return
[docs]def mcontr_elem_row_one___complex_complex():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over row.
**Arguments**
dest : complex(\*), inout
Add result of contraction to this array.
src : complex(\*), in
Entries of the tensor contracted over interior index.
mat : complex(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix (dimension contracted over).
m2 : INTEGER, inout
Second dimension of the matrix.
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : complex, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_row_one___complex_complex(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
complex(KIND=rKind), dimension(:), intent(inout) :: dest
complex(KIND=rKind), dimension(:), intent(in) :: src
complex(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
complex(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2, k_
! boundary of block used in src
integer :: j1, j2
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
k_ = 1
j1 = 1
j2 = d1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + (src(j1:j2)) &
* (mat(mm))
mm = mm + 1
k1 = k1 + d1
k2 = k2 + d1
end do
j1 = j1 + d1
j2 = j2 + d1
k1 = k_
k2 = k1 + d1 - 1
end do
k1 = k1 + m1 * d1
k2 = k2 + m1 * d1
k_ = k1
end do
end subroutine mcontr_elem_row_one___complex_complex
"""
return
[docs]def mcontr_elem_col_one_conjg__complex_complex():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over column.
**Arguments**
dest : complex(\*), inout
Add result of contraction to this array.
src : complex(\*), in
Entries of the tensor contracted over interior index.
mat : complex(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix.
m2 : INTEGER, inout
Second dimension of the matrix (dimension contracted over).
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : complex, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_col_one_conjg__complex_complex(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
complex(KIND=rKind), dimension(:), intent(inout) :: dest
complex(KIND=rKind), dimension(:), intent(in) :: src
complex(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
complex(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2
! boundary of block used in src
integer :: j1, j2, j_
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
j1 = 1
j2 = d1
j_ = 1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + conjg(src(j1:j2)) &
* (mat(mm))
mm = mm + 1
j1 = j1 + d1
j2 = j2 + d1
end do
k1 = k1 + d1
k2 = k2 + d1
j1 = j_
j2 = j1 + d1 - 1
end do
j1 = j1 + m1 * d1
j2 = j2 + m1 * d1
j_ = j1
end do
end subroutine mcontr_elem_col_one_conjg__complex_complex
"""
return
[docs]def mcontr_elem_row_one_conjg__complex_complex():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over row.
**Arguments**
dest : complex(\*), inout
Add result of contraction to this array.
src : complex(\*), in
Entries of the tensor contracted over interior index.
mat : complex(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix (dimension contracted over).
m2 : INTEGER, inout
Second dimension of the matrix.
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : complex, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_row_one_conjg__complex_complex(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
complex(KIND=rKind), dimension(:), intent(inout) :: dest
complex(KIND=rKind), dimension(:), intent(in) :: src
complex(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
complex(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2, k_
! boundary of block used in src
integer :: j1, j2
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
k_ = 1
j1 = 1
j2 = d1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + conjg(src(j1:j2)) &
* (mat(mm))
mm = mm + 1
k1 = k1 + d1
k2 = k2 + d1
end do
j1 = j1 + d1
j2 = j2 + d1
k1 = k_
k2 = k1 + d1 - 1
end do
k1 = k1 + m1 * d1
k2 = k2 + m1 * d1
k_ = k1
end do
end subroutine mcontr_elem_row_one_conjg__complex_complex
"""
return
[docs]def mcontr_elem_col_one__conjg_complex_complex():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over column.
**Arguments**
dest : complex(\*), inout
Add result of contraction to this array.
src : complex(\*), in
Entries of the tensor contracted over interior index.
mat : complex(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix.
m2 : INTEGER, inout
Second dimension of the matrix (dimension contracted over).
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : complex, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_col_one__conjg_complex_complex(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
complex(KIND=rKind), dimension(:), intent(inout) :: dest
complex(KIND=rKind), dimension(:), intent(in) :: src
complex(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
complex(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2
! boundary of block used in src
integer :: j1, j2, j_
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
j1 = 1
j2 = d1
j_ = 1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + (src(j1:j2)) &
* conjg(mat(mm))
mm = mm + 1
j1 = j1 + d1
j2 = j2 + d1
end do
k1 = k1 + d1
k2 = k2 + d1
j1 = j_
j2 = j1 + d1 - 1
end do
j1 = j1 + m1 * d1
j2 = j2 + m1 * d1
j_ = j1
end do
end subroutine mcontr_elem_col_one__conjg_complex_complex
"""
return
[docs]def mcontr_elem_row_one__conjg_complex_complex():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over row.
**Arguments**
dest : complex(\*), inout
Add result of contraction to this array.
src : complex(\*), in
Entries of the tensor contracted over interior index.
mat : complex(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix (dimension contracted over).
m2 : INTEGER, inout
Second dimension of the matrix.
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : complex, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_row_one__conjg_complex_complex(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
complex(KIND=rKind), dimension(:), intent(inout) :: dest
complex(KIND=rKind), dimension(:), intent(in) :: src
complex(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
complex(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2, k_
! boundary of block used in src
integer :: j1, j2
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
k_ = 1
j1 = 1
j2 = d1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + (src(j1:j2)) &
* conjg(mat(mm))
mm = mm + 1
k1 = k1 + d1
k2 = k2 + d1
end do
j1 = j1 + d1
j2 = j2 + d1
k1 = k_
k2 = k1 + d1 - 1
end do
k1 = k1 + m1 * d1
k2 = k2 + m1 * d1
k_ = k1
end do
end subroutine mcontr_elem_row_one__conjg_complex_complex
"""
return
[docs]def mcontr_elem_col_one_conjg_conjg_complex_complex():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over column.
**Arguments**
dest : complex(\*), inout
Add result of contraction to this array.
src : complex(\*), in
Entries of the tensor contracted over interior index.
mat : complex(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix.
m2 : INTEGER, inout
Second dimension of the matrix (dimension contracted over).
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : complex, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_col_one_conjg_conjg_complex_complex(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
complex(KIND=rKind), dimension(:), intent(inout) :: dest
complex(KIND=rKind), dimension(:), intent(in) :: src
complex(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
complex(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2
! boundary of block used in src
integer :: j1, j2, j_
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
j1 = 1
j2 = d1
j_ = 1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + conjg(src(j1:j2)) &
* conjg(mat(mm))
mm = mm + 1
j1 = j1 + d1
j2 = j2 + d1
end do
k1 = k1 + d1
k2 = k2 + d1
j1 = j_
j2 = j1 + d1 - 1
end do
j1 = j1 + m1 * d1
j2 = j2 + m1 * d1
j_ = j1
end do
end subroutine mcontr_elem_col_one_conjg_conjg_complex_complex
"""
return
[docs]def mcontr_elem_row_one_conjg_conjg_complex_complex():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over row.
**Arguments**
dest : complex(\*), inout
Add result of contraction to this array.
src : complex(\*), in
Entries of the tensor contracted over interior index.
mat : complex(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix (dimension contracted over).
m2 : INTEGER, inout
Second dimension of the matrix.
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : complex, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_row_one_conjg_conjg_complex_complex(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
complex(KIND=rKind), dimension(:), intent(inout) :: dest
complex(KIND=rKind), dimension(:), intent(in) :: src
complex(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
complex(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2, k_
! boundary of block used in src
integer :: j1, j2
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
k_ = 1
j1 = 1
j2 = d1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + conjg(src(j1:j2)) &
* conjg(mat(mm))
mm = mm + 1
k1 = k1 + d1
k2 = k2 + d1
end do
j1 = j1 + d1
j2 = j2 + d1
k1 = k_
k2 = k1 + d1 - 1
end do
k1 = k1 + m1 * d1
k2 = k2 + m1 * d1
k_ = k1
end do
end subroutine mcontr_elem_row_one_conjg_conjg_complex_complex
"""
return
[docs]def mcontr_elem_col_alp___complex_complex():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over column.
**Arguments**
dest : complex(\*), inout
Add result of contraction to this array.
src : complex(\*), in
Entries of the tensor contracted over interior index.
mat : complex(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix.
m2 : INTEGER, inout
Second dimension of the matrix (dimension contracted over).
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : complex, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_col_alp___complex_complex(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
complex(KIND=rKind), dimension(:), intent(inout) :: dest
complex(KIND=rKind), dimension(:), intent(in) :: src
complex(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
complex(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2
! boundary of block used in src
integer :: j1, j2, j_
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
j1 = 1
j2 = d1
j_ = 1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + alpha* (src(j1:j2)) &
* (mat(mm))
mm = mm + 1
j1 = j1 + d1
j2 = j2 + d1
end do
k1 = k1 + d1
k2 = k2 + d1
j1 = j_
j2 = j1 + d1 - 1
end do
j1 = j1 + m1 * d1
j2 = j2 + m1 * d1
j_ = j1
end do
end subroutine mcontr_elem_col_alp___complex_complex
"""
return
[docs]def mcontr_elem_row_alp___complex_complex():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over row.
**Arguments**
dest : complex(\*), inout
Add result of contraction to this array.
src : complex(\*), in
Entries of the tensor contracted over interior index.
mat : complex(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix (dimension contracted over).
m2 : INTEGER, inout
Second dimension of the matrix.
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : complex, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_row_alp___complex_complex(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
complex(KIND=rKind), dimension(:), intent(inout) :: dest
complex(KIND=rKind), dimension(:), intent(in) :: src
complex(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
complex(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2, k_
! boundary of block used in src
integer :: j1, j2
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
k_ = 1
j1 = 1
j2 = d1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + alpha* (src(j1:j2)) &
* (mat(mm))
mm = mm + 1
k1 = k1 + d1
k2 = k2 + d1
end do
j1 = j1 + d1
j2 = j2 + d1
k1 = k_
k2 = k1 + d1 - 1
end do
k1 = k1 + m1 * d1
k2 = k2 + m1 * d1
k_ = k1
end do
end subroutine mcontr_elem_row_alp___complex_complex
"""
return
[docs]def mcontr_elem_col_alp_conjg__complex_complex():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over column.
**Arguments**
dest : complex(\*), inout
Add result of contraction to this array.
src : complex(\*), in
Entries of the tensor contracted over interior index.
mat : complex(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix.
m2 : INTEGER, inout
Second dimension of the matrix (dimension contracted over).
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : complex, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_col_alp_conjg__complex_complex(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
complex(KIND=rKind), dimension(:), intent(inout) :: dest
complex(KIND=rKind), dimension(:), intent(in) :: src
complex(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
complex(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2
! boundary of block used in src
integer :: j1, j2, j_
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
j1 = 1
j2 = d1
j_ = 1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + alpha* conjg(src(j1:j2)) &
* (mat(mm))
mm = mm + 1
j1 = j1 + d1
j2 = j2 + d1
end do
k1 = k1 + d1
k2 = k2 + d1
j1 = j_
j2 = j1 + d1 - 1
end do
j1 = j1 + m1 * d1
j2 = j2 + m1 * d1
j_ = j1
end do
end subroutine mcontr_elem_col_alp_conjg__complex_complex
"""
return
[docs]def mcontr_elem_row_alp_conjg__complex_complex():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over row.
**Arguments**
dest : complex(\*), inout
Add result of contraction to this array.
src : complex(\*), in
Entries of the tensor contracted over interior index.
mat : complex(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix (dimension contracted over).
m2 : INTEGER, inout
Second dimension of the matrix.
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : complex, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_row_alp_conjg__complex_complex(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
complex(KIND=rKind), dimension(:), intent(inout) :: dest
complex(KIND=rKind), dimension(:), intent(in) :: src
complex(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
complex(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2, k_
! boundary of block used in src
integer :: j1, j2
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
k_ = 1
j1 = 1
j2 = d1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + alpha* conjg(src(j1:j2)) &
* (mat(mm))
mm = mm + 1
k1 = k1 + d1
k2 = k2 + d1
end do
j1 = j1 + d1
j2 = j2 + d1
k1 = k_
k2 = k1 + d1 - 1
end do
k1 = k1 + m1 * d1
k2 = k2 + m1 * d1
k_ = k1
end do
end subroutine mcontr_elem_row_alp_conjg__complex_complex
"""
return
[docs]def mcontr_elem_col_alp__conjg_complex_complex():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over column.
**Arguments**
dest : complex(\*), inout
Add result of contraction to this array.
src : complex(\*), in
Entries of the tensor contracted over interior index.
mat : complex(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix.
m2 : INTEGER, inout
Second dimension of the matrix (dimension contracted over).
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : complex, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_col_alp__conjg_complex_complex(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
complex(KIND=rKind), dimension(:), intent(inout) :: dest
complex(KIND=rKind), dimension(:), intent(in) :: src
complex(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
complex(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2
! boundary of block used in src
integer :: j1, j2, j_
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
j1 = 1
j2 = d1
j_ = 1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + alpha* (src(j1:j2)) &
* conjg(mat(mm))
mm = mm + 1
j1 = j1 + d1
j2 = j2 + d1
end do
k1 = k1 + d1
k2 = k2 + d1
j1 = j_
j2 = j1 + d1 - 1
end do
j1 = j1 + m1 * d1
j2 = j2 + m1 * d1
j_ = j1
end do
end subroutine mcontr_elem_col_alp__conjg_complex_complex
"""
return
[docs]def mcontr_elem_row_alp__conjg_complex_complex():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over row.
**Arguments**
dest : complex(\*), inout
Add result of contraction to this array.
src : complex(\*), in
Entries of the tensor contracted over interior index.
mat : complex(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix (dimension contracted over).
m2 : INTEGER, inout
Second dimension of the matrix.
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : complex, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_row_alp__conjg_complex_complex(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
complex(KIND=rKind), dimension(:), intent(inout) :: dest
complex(KIND=rKind), dimension(:), intent(in) :: src
complex(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
complex(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2, k_
! boundary of block used in src
integer :: j1, j2
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
k_ = 1
j1 = 1
j2 = d1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + alpha* (src(j1:j2)) &
* conjg(mat(mm))
mm = mm + 1
k1 = k1 + d1
k2 = k2 + d1
end do
j1 = j1 + d1
j2 = j2 + d1
k1 = k_
k2 = k1 + d1 - 1
end do
k1 = k1 + m1 * d1
k2 = k2 + m1 * d1
k_ = k1
end do
end subroutine mcontr_elem_row_alp__conjg_complex_complex
"""
return
[docs]def mcontr_elem_col_alp_conjg_conjg_complex_complex():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over column.
**Arguments**
dest : complex(\*), inout
Add result of contraction to this array.
src : complex(\*), in
Entries of the tensor contracted over interior index.
mat : complex(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix.
m2 : INTEGER, inout
Second dimension of the matrix (dimension contracted over).
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : complex, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_col_alp_conjg_conjg_complex_complex(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
complex(KIND=rKind), dimension(:), intent(inout) :: dest
complex(KIND=rKind), dimension(:), intent(in) :: src
complex(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
complex(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2
! boundary of block used in src
integer :: j1, j2, j_
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
j1 = 1
j2 = d1
j_ = 1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + alpha* conjg(src(j1:j2)) &
* conjg(mat(mm))
mm = mm + 1
j1 = j1 + d1
j2 = j2 + d1
end do
k1 = k1 + d1
k2 = k2 + d1
j1 = j_
j2 = j1 + d1 - 1
end do
j1 = j1 + m1 * d1
j2 = j2 + m1 * d1
j_ = j1
end do
end subroutine mcontr_elem_col_alp_conjg_conjg_complex_complex
"""
return
[docs]def mcontr_elem_row_alp_conjg_conjg_complex_complex():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over row.
**Arguments**
dest : complex(\*), inout
Add result of contraction to this array.
src : complex(\*), in
Entries of the tensor contracted over interior index.
mat : complex(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix (dimension contracted over).
m2 : INTEGER, inout
Second dimension of the matrix.
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : complex, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_row_alp_conjg_conjg_complex_complex(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
complex(KIND=rKind), dimension(:), intent(inout) :: dest
complex(KIND=rKind), dimension(:), intent(in) :: src
complex(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
complex(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2, k_
! boundary of block used in src
integer :: j1, j2
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
k_ = 1
j1 = 1
j2 = d1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + alpha* conjg(src(j1:j2)) &
* conjg(mat(mm))
mm = mm + 1
k1 = k1 + d1
k2 = k2 + d1
end do
j1 = j1 + d1
j2 = j2 + d1
k1 = k_
k2 = k1 + d1 - 1
end do
k1 = k1 + m1 * d1
k2 = k2 + m1 * d1
k_ = k1
end do
end subroutine mcontr_elem_row_alp_conjg_conjg_complex_complex
"""
return
[docs]def mcontr_elem_col_one___real_complex():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over column.
**Arguments**
dest : complex(\*), inout
Add result of contraction to this array.
src : real(\*), in
Entries of the tensor contracted over interior index.
mat : complex(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix.
m2 : INTEGER, inout
Second dimension of the matrix (dimension contracted over).
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : complex, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_col_one___real_complex(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
complex(KIND=rKind), dimension(:), intent(inout) :: dest
real(KIND=rKind), dimension(:), intent(in) :: src
complex(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
complex(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2
! boundary of block used in src
integer :: j1, j2, j_
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
j1 = 1
j2 = d1
j_ = 1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + (src(j1:j2)) &
* (mat(mm))
mm = mm + 1
j1 = j1 + d1
j2 = j2 + d1
end do
k1 = k1 + d1
k2 = k2 + d1
j1 = j_
j2 = j1 + d1 - 1
end do
j1 = j1 + m1 * d1
j2 = j2 + m1 * d1
j_ = j1
end do
end subroutine mcontr_elem_col_one___real_complex
"""
return
[docs]def mcontr_elem_row_one___real_complex():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over row.
**Arguments**
dest : complex(\*), inout
Add result of contraction to this array.
src : real(\*), in
Entries of the tensor contracted over interior index.
mat : complex(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix (dimension contracted over).
m2 : INTEGER, inout
Second dimension of the matrix.
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : complex, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_row_one___real_complex(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
complex(KIND=rKind), dimension(:), intent(inout) :: dest
real(KIND=rKind), dimension(:), intent(in) :: src
complex(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
complex(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2, k_
! boundary of block used in src
integer :: j1, j2
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
k_ = 1
j1 = 1
j2 = d1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + (src(j1:j2)) &
* (mat(mm))
mm = mm + 1
k1 = k1 + d1
k2 = k2 + d1
end do
j1 = j1 + d1
j2 = j2 + d1
k1 = k_
k2 = k1 + d1 - 1
end do
k1 = k1 + m1 * d1
k2 = k2 + m1 * d1
k_ = k1
end do
end subroutine mcontr_elem_row_one___real_complex
"""
return
[docs]def mcontr_elem_col_one_conjg__real_complex():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over column.
**Arguments**
dest : complex(\*), inout
Add result of contraction to this array.
src : real(\*), in
Entries of the tensor contracted over interior index.
mat : complex(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix.
m2 : INTEGER, inout
Second dimension of the matrix (dimension contracted over).
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : complex, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_col_one_conjg__real_complex(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
complex(KIND=rKind), dimension(:), intent(inout) :: dest
real(KIND=rKind), dimension(:), intent(in) :: src
complex(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
complex(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2
! boundary of block used in src
integer :: j1, j2, j_
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
j1 = 1
j2 = d1
j_ = 1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + (src(j1:j2)) &
* (mat(mm))
mm = mm + 1
j1 = j1 + d1
j2 = j2 + d1
end do
k1 = k1 + d1
k2 = k2 + d1
j1 = j_
j2 = j1 + d1 - 1
end do
j1 = j1 + m1 * d1
j2 = j2 + m1 * d1
j_ = j1
end do
end subroutine mcontr_elem_col_one_conjg__real_complex
"""
return
[docs]def mcontr_elem_row_one_conjg__real_complex():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over row.
**Arguments**
dest : complex(\*), inout
Add result of contraction to this array.
src : real(\*), in
Entries of the tensor contracted over interior index.
mat : complex(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix (dimension contracted over).
m2 : INTEGER, inout
Second dimension of the matrix.
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : complex, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_row_one_conjg__real_complex(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
complex(KIND=rKind), dimension(:), intent(inout) :: dest
real(KIND=rKind), dimension(:), intent(in) :: src
complex(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
complex(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2, k_
! boundary of block used in src
integer :: j1, j2
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
k_ = 1
j1 = 1
j2 = d1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + (src(j1:j2)) &
* (mat(mm))
mm = mm + 1
k1 = k1 + d1
k2 = k2 + d1
end do
j1 = j1 + d1
j2 = j2 + d1
k1 = k_
k2 = k1 + d1 - 1
end do
k1 = k1 + m1 * d1
k2 = k2 + m1 * d1
k_ = k1
end do
end subroutine mcontr_elem_row_one_conjg__real_complex
"""
return
[docs]def mcontr_elem_col_one__conjg_real_complex():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over column.
**Arguments**
dest : complex(\*), inout
Add result of contraction to this array.
src : real(\*), in
Entries of the tensor contracted over interior index.
mat : complex(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix.
m2 : INTEGER, inout
Second dimension of the matrix (dimension contracted over).
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : complex, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_col_one__conjg_real_complex(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
complex(KIND=rKind), dimension(:), intent(inout) :: dest
real(KIND=rKind), dimension(:), intent(in) :: src
complex(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
complex(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2
! boundary of block used in src
integer :: j1, j2, j_
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
j1 = 1
j2 = d1
j_ = 1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + (src(j1:j2)) &
* conjg(mat(mm))
mm = mm + 1
j1 = j1 + d1
j2 = j2 + d1
end do
k1 = k1 + d1
k2 = k2 + d1
j1 = j_
j2 = j1 + d1 - 1
end do
j1 = j1 + m1 * d1
j2 = j2 + m1 * d1
j_ = j1
end do
end subroutine mcontr_elem_col_one__conjg_real_complex
"""
return
[docs]def mcontr_elem_row_one__conjg_real_complex():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over row.
**Arguments**
dest : complex(\*), inout
Add result of contraction to this array.
src : real(\*), in
Entries of the tensor contracted over interior index.
mat : complex(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix (dimension contracted over).
m2 : INTEGER, inout
Second dimension of the matrix.
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : complex, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_row_one__conjg_real_complex(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
complex(KIND=rKind), dimension(:), intent(inout) :: dest
real(KIND=rKind), dimension(:), intent(in) :: src
complex(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
complex(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2, k_
! boundary of block used in src
integer :: j1, j2
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
k_ = 1
j1 = 1
j2 = d1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + (src(j1:j2)) &
* conjg(mat(mm))
mm = mm + 1
k1 = k1 + d1
k2 = k2 + d1
end do
j1 = j1 + d1
j2 = j2 + d1
k1 = k_
k2 = k1 + d1 - 1
end do
k1 = k1 + m1 * d1
k2 = k2 + m1 * d1
k_ = k1
end do
end subroutine mcontr_elem_row_one__conjg_real_complex
"""
return
[docs]def mcontr_elem_col_one_conjg_conjg_real_complex():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over column.
**Arguments**
dest : complex(\*), inout
Add result of contraction to this array.
src : real(\*), in
Entries of the tensor contracted over interior index.
mat : complex(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix.
m2 : INTEGER, inout
Second dimension of the matrix (dimension contracted over).
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : complex, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_col_one_conjg_conjg_real_complex(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
complex(KIND=rKind), dimension(:), intent(inout) :: dest
real(KIND=rKind), dimension(:), intent(in) :: src
complex(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
complex(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2
! boundary of block used in src
integer :: j1, j2, j_
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
j1 = 1
j2 = d1
j_ = 1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + (src(j1:j2)) &
* conjg(mat(mm))
mm = mm + 1
j1 = j1 + d1
j2 = j2 + d1
end do
k1 = k1 + d1
k2 = k2 + d1
j1 = j_
j2 = j1 + d1 - 1
end do
j1 = j1 + m1 * d1
j2 = j2 + m1 * d1
j_ = j1
end do
end subroutine mcontr_elem_col_one_conjg_conjg_real_complex
"""
return
[docs]def mcontr_elem_row_one_conjg_conjg_real_complex():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over row.
**Arguments**
dest : complex(\*), inout
Add result of contraction to this array.
src : real(\*), in
Entries of the tensor contracted over interior index.
mat : complex(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix (dimension contracted over).
m2 : INTEGER, inout
Second dimension of the matrix.
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : complex, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_row_one_conjg_conjg_real_complex(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
complex(KIND=rKind), dimension(:), intent(inout) :: dest
real(KIND=rKind), dimension(:), intent(in) :: src
complex(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
complex(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2, k_
! boundary of block used in src
integer :: j1, j2
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
k_ = 1
j1 = 1
j2 = d1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + (src(j1:j2)) &
* conjg(mat(mm))
mm = mm + 1
k1 = k1 + d1
k2 = k2 + d1
end do
j1 = j1 + d1
j2 = j2 + d1
k1 = k_
k2 = k1 + d1 - 1
end do
k1 = k1 + m1 * d1
k2 = k2 + m1 * d1
k_ = k1
end do
end subroutine mcontr_elem_row_one_conjg_conjg_real_complex
"""
return
[docs]def mcontr_elem_col_alp___real_complex():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over column.
**Arguments**
dest : complex(\*), inout
Add result of contraction to this array.
src : real(\*), in
Entries of the tensor contracted over interior index.
mat : complex(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix.
m2 : INTEGER, inout
Second dimension of the matrix (dimension contracted over).
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : complex, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_col_alp___real_complex(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
complex(KIND=rKind), dimension(:), intent(inout) :: dest
real(KIND=rKind), dimension(:), intent(in) :: src
complex(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
complex(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2
! boundary of block used in src
integer :: j1, j2, j_
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
j1 = 1
j2 = d1
j_ = 1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + alpha* (src(j1:j2)) &
* (mat(mm))
mm = mm + 1
j1 = j1 + d1
j2 = j2 + d1
end do
k1 = k1 + d1
k2 = k2 + d1
j1 = j_
j2 = j1 + d1 - 1
end do
j1 = j1 + m1 * d1
j2 = j2 + m1 * d1
j_ = j1
end do
end subroutine mcontr_elem_col_alp___real_complex
"""
return
[docs]def mcontr_elem_row_alp___real_complex():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over row.
**Arguments**
dest : complex(\*), inout
Add result of contraction to this array.
src : real(\*), in
Entries of the tensor contracted over interior index.
mat : complex(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix (dimension contracted over).
m2 : INTEGER, inout
Second dimension of the matrix.
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : complex, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_row_alp___real_complex(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
complex(KIND=rKind), dimension(:), intent(inout) :: dest
real(KIND=rKind), dimension(:), intent(in) :: src
complex(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
complex(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2, k_
! boundary of block used in src
integer :: j1, j2
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
k_ = 1
j1 = 1
j2 = d1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + alpha* (src(j1:j2)) &
* (mat(mm))
mm = mm + 1
k1 = k1 + d1
k2 = k2 + d1
end do
j1 = j1 + d1
j2 = j2 + d1
k1 = k_
k2 = k1 + d1 - 1
end do
k1 = k1 + m1 * d1
k2 = k2 + m1 * d1
k_ = k1
end do
end subroutine mcontr_elem_row_alp___real_complex
"""
return
[docs]def mcontr_elem_col_alp_conjg__real_complex():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over column.
**Arguments**
dest : complex(\*), inout
Add result of contraction to this array.
src : real(\*), in
Entries of the tensor contracted over interior index.
mat : complex(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix.
m2 : INTEGER, inout
Second dimension of the matrix (dimension contracted over).
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : complex, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_col_alp_conjg__real_complex(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
complex(KIND=rKind), dimension(:), intent(inout) :: dest
real(KIND=rKind), dimension(:), intent(in) :: src
complex(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
complex(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2
! boundary of block used in src
integer :: j1, j2, j_
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
j1 = 1
j2 = d1
j_ = 1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + alpha* (src(j1:j2)) &
* (mat(mm))
mm = mm + 1
j1 = j1 + d1
j2 = j2 + d1
end do
k1 = k1 + d1
k2 = k2 + d1
j1 = j_
j2 = j1 + d1 - 1
end do
j1 = j1 + m1 * d1
j2 = j2 + m1 * d1
j_ = j1
end do
end subroutine mcontr_elem_col_alp_conjg__real_complex
"""
return
[docs]def mcontr_elem_row_alp_conjg__real_complex():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over row.
**Arguments**
dest : complex(\*), inout
Add result of contraction to this array.
src : real(\*), in
Entries of the tensor contracted over interior index.
mat : complex(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix (dimension contracted over).
m2 : INTEGER, inout
Second dimension of the matrix.
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : complex, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_row_alp_conjg__real_complex(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
complex(KIND=rKind), dimension(:), intent(inout) :: dest
real(KIND=rKind), dimension(:), intent(in) :: src
complex(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
complex(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2, k_
! boundary of block used in src
integer :: j1, j2
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
k_ = 1
j1 = 1
j2 = d1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + alpha* (src(j1:j2)) &
* (mat(mm))
mm = mm + 1
k1 = k1 + d1
k2 = k2 + d1
end do
j1 = j1 + d1
j2 = j2 + d1
k1 = k_
k2 = k1 + d1 - 1
end do
k1 = k1 + m1 * d1
k2 = k2 + m1 * d1
k_ = k1
end do
end subroutine mcontr_elem_row_alp_conjg__real_complex
"""
return
[docs]def mcontr_elem_col_alp__conjg_real_complex():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over column.
**Arguments**
dest : complex(\*), inout
Add result of contraction to this array.
src : real(\*), in
Entries of the tensor contracted over interior index.
mat : complex(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix.
m2 : INTEGER, inout
Second dimension of the matrix (dimension contracted over).
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : complex, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_col_alp__conjg_real_complex(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
complex(KIND=rKind), dimension(:), intent(inout) :: dest
real(KIND=rKind), dimension(:), intent(in) :: src
complex(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
complex(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2
! boundary of block used in src
integer :: j1, j2, j_
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
j1 = 1
j2 = d1
j_ = 1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + alpha* (src(j1:j2)) &
* conjg(mat(mm))
mm = mm + 1
j1 = j1 + d1
j2 = j2 + d1
end do
k1 = k1 + d1
k2 = k2 + d1
j1 = j_
j2 = j1 + d1 - 1
end do
j1 = j1 + m1 * d1
j2 = j2 + m1 * d1
j_ = j1
end do
end subroutine mcontr_elem_col_alp__conjg_real_complex
"""
return
[docs]def mcontr_elem_row_alp__conjg_real_complex():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over row.
**Arguments**
dest : complex(\*), inout
Add result of contraction to this array.
src : real(\*), in
Entries of the tensor contracted over interior index.
mat : complex(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix (dimension contracted over).
m2 : INTEGER, inout
Second dimension of the matrix.
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : complex, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_row_alp__conjg_real_complex(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
complex(KIND=rKind), dimension(:), intent(inout) :: dest
real(KIND=rKind), dimension(:), intent(in) :: src
complex(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
complex(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2, k_
! boundary of block used in src
integer :: j1, j2
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
k_ = 1
j1 = 1
j2 = d1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + alpha* (src(j1:j2)) &
* conjg(mat(mm))
mm = mm + 1
k1 = k1 + d1
k2 = k2 + d1
end do
j1 = j1 + d1
j2 = j2 + d1
k1 = k_
k2 = k1 + d1 - 1
end do
k1 = k1 + m1 * d1
k2 = k2 + m1 * d1
k_ = k1
end do
end subroutine mcontr_elem_row_alp__conjg_real_complex
"""
return
[docs]def mcontr_elem_col_alp_conjg_conjg_real_complex():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over column.
**Arguments**
dest : complex(\*), inout
Add result of contraction to this array.
src : real(\*), in
Entries of the tensor contracted over interior index.
mat : complex(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix.
m2 : INTEGER, inout
Second dimension of the matrix (dimension contracted over).
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : complex, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_col_alp_conjg_conjg_real_complex(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
complex(KIND=rKind), dimension(:), intent(inout) :: dest
real(KIND=rKind), dimension(:), intent(in) :: src
complex(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
complex(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2
! boundary of block used in src
integer :: j1, j2, j_
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
j1 = 1
j2 = d1
j_ = 1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + alpha* (src(j1:j2)) &
* conjg(mat(mm))
mm = mm + 1
j1 = j1 + d1
j2 = j2 + d1
end do
k1 = k1 + d1
k2 = k2 + d1
j1 = j_
j2 = j1 + d1 - 1
end do
j1 = j1 + m1 * d1
j2 = j2 + m1 * d1
j_ = j1
end do
end subroutine mcontr_elem_col_alp_conjg_conjg_real_complex
"""
return
[docs]def mcontr_elem_row_alp_conjg_conjg_real_complex():
"""
fortran-subroutine - September 2017 (dj)
Elementary contraction of a tensors interior index with another
tensor represented as matrix. Matrix contracted over row.
**Arguments**
dest : complex(\*), inout
Add result of contraction to this array.
src : real(\*), in
Entries of the tensor contracted over interior index.
mat : complex(\*), inout
Entries of the matrix contracted.
d1 : INTEGER, inout
Cumulated dimension of all indices in front of the contracted index
in src.
m1 : INTEGER, inout
First dimension of the matrix (dimension contracted over).
m2 : INTEGER, inout
Second dimension of the matrix.
d3 : INTEGER, inout
Cumulated dimension of all indices after the contracted index
alpha : complex, inout
Scaling of the contraction of src and mat, if used.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_elem_row_alp_conjg_conjg_real_complex(&
dest, src, mat, d1, m1, m2, d3, alpha, errst)
complex(KIND=rKind), dimension(:), intent(inout) :: dest
real(KIND=rKind), dimension(:), intent(in) :: src
complex(KIND=rKind), dimension(:), intent(in) :: mat
integer, intent(in) :: d1, m1, m2, d3
complex(KIND=rKind), intent(in) :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii, jj, kk
! boundary of block modified in dest
integer :: k1, k2, k_
! boundary of block used in src
integer :: j1, j2
! index inside matrix
integer :: mm
!if(present(errst)) errst = 0
k1 = 1
k2 = d1
k_ = 1
j1 = 1
j2 = d1
do kk = 1, d3
mm = 1
do ii = 1, m2
do jj = 1, m1
dest(k1:k2) = dest(k1:k2) + alpha* (src(j1:j2)) &
* conjg(mat(mm))
mm = mm + 1
k1 = k1 + d1
k2 = k2 + d1
end do
j1 = j1 + d1
j2 = j2 + d1
k1 = k_
k2 = k1 + d1 - 1
end do
k1 = k1 + m1 * d1
k2 = k2 + m1 * d1
k_ = k1
end do
end subroutine mcontr_elem_row_alp_conjg_conjg_real_complex
"""
return
[docs]def mcontr_qtensor_qtensor():
"""
fortran-subroutine - October 2017 (dj)
Middle contraction or matrix contraction of a large tensor Tl with a small
matrix Tm to Tc = alpha Tl Tm + beta Tc.
**Arguments**
Tc : TYPE(qtensor), inout
Result fo the contraction.
Tl : TYPE(qtensor), inout
Multi-link tensor which should be contracted over an interior index.
Tm : TYPE(qtensor), inout
Tensor (matrix) contracted over first or last index.
idxl : INTEGER, inout
Index for contraction in Tl.
idxm : INTEGER, inout
Index for contraction in Tm, either 1 or 2.
transl : CHARACTER, inout
"N" for no transformation or "C" for complex conjugate of Tl.
transr : CHARACTER, inout
"N" for no transformation or "C" for complex conjugate of Tm.
alpha : real, inout
Scale contraction of Tl with Tm.
beta : real, inout
Scale incoming tensor Tc.
**Details**
The contr-methods wrapping LAPACK require permutation causing an
overhead which is not compensated for contractions with small matrices. This
is only the case, if one of the middle indices is contracted.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_qtensor_qtensor(Tc, Tl, Tm, idxl, idxm, &
transl, transr, alpha, beta, errst)
type(qtensor), intent(inout) :: Tc
type(qtensor), intent(inout) :: Tl
type(qtensor), intent(inout) :: Tm
integer, dimension(:), intent(in) :: idxl, idxm
character, intent(in), optional :: transl, transr
real(KIND=rKind), intent(in), optional :: alpha, beta
integer, intent(out), optional :: errst
! Local variables
! ---------------
! flag to check if beta = 0.0
logical :: betazero
! Temporary tensor for gaxpy
type(qtensor) :: Tens
!if(present(errst)) errst = 0
betazero = .true.
if(present(beta)) betazero = (abs(beta) < 1e-14_rKind)
! Fast return
if(((Tl%nb == 0) .or. (Tm%nb == 0)) .and. betazero) then
! Have to create empty tensor
call create(Tc, Tl%nqs, 0, errst=errst)
!if(prop_error('mcontr_qtensor: create failed.', &
! 'ContractionOps_include.f90:3300', errst=errst)) return
return
elseif((Tl%nb == 0) .or. (Tm%nb == 0)) then
! The incoming tensor stays unmodified
return
end if
if(betazero) then
! Standard contraction
! ....................
call internal_mcontr_qtensor_qtensor(Tc, Tl, Tm, &
idxl, idxm, transl, transr, alpha, errst=errst)
!if(prop_error('mcontr_qtensor_'//&
! 'qtensor : internal_mcontr (1) '//&
! 'failed.', 'ContractionOps_include.f90:3316', errst=errst)) return
else
! Contraction and addition only works with GAXPY (for instance)
! ..............................................
call internal_mcontr_qtensor_qtensor(Tens, Tl, Tm, &
idxl, idxm, transl, transr, alpha, errst=errst)
!if(prop_error('mcontr_qtensor_'//&
! 'qtensor : internal_mcontr (2) '//&
! 'failed.', 'ContractionOps_include.f90:3326', errst=errst)) return
if(beta /= done) then
call scale(beta, Tc, errst=errst)
!if(prop_error('qtensor_qtensor'//&
! ': scale failed.', 'ContractionOps_include.f90:3331', &
! errst=errst)) return
end if
call gaxpy(Tc, done, Tens, errst=errst)
!if(prop_error('mcontr_qtensor_'//&
! 'qtensor : gaxpy failed.', &
! 'ContractionOps_include.f90:3338', errst=errst)) return
call destroy(Tens)
end if
end subroutine mcontr_qtensor_qtensor
"""
return
[docs]def mcontr_qtensorc_qtensor():
"""
fortran-subroutine - October 2017 (dj)
Middle contraction or matrix contraction of a large tensor Tl with a small
matrix Tm to Tc = alpha Tl Tm + beta Tc.
**Arguments**
Tc : TYPE(qtensorc), inout
Result fo the contraction.
Tl : TYPE(qtensorc), inout
Multi-link tensor which should be contracted over an interior index.
Tm : TYPE(qtensor), inout
Tensor (matrix) contracted over first or last index.
idxl : INTEGER, inout
Index for contraction in Tl.
idxm : INTEGER, inout
Index for contraction in Tm, either 1 or 2.
transl : CHARACTER, inout
"N" for no transformation or "C" for complex conjugate of Tl.
transr : CHARACTER, inout
"N" for no transformation or "C" for complex conjugate of Tm.
alpha : complex, inout
Scale contraction of Tl with Tm.
beta : complex, inout
Scale incoming tensor Tc.
**Details**
The contr-methods wrapping LAPACK require permutation causing an
overhead which is not compensated for contractions with small matrices. This
is only the case, if one of the middle indices is contracted.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_qtensorc_qtensor(Tc, Tl, Tm, idxl, idxm, &
transl, transr, alpha, beta, errst)
type(qtensorc), intent(inout) :: Tc
type(qtensorc), intent(inout) :: Tl
type(qtensor), intent(inout) :: Tm
integer, dimension(:), intent(in) :: idxl, idxm
character, intent(in), optional :: transl, transr
complex(KIND=rKind), intent(in), optional :: alpha, beta
integer, intent(out), optional :: errst
! Local variables
! ---------------
! flag to check if beta = 0.0
logical :: betazero
! Temporary tensor for gaxpy
type(qtensorc) :: Tens
!if(present(errst)) errst = 0
betazero = .true.
if(present(beta)) betazero = (abs(beta) < 1e-14_rKind)
! Fast return
if(((Tl%nb == 0) .or. (Tm%nb == 0)) .and. betazero) then
! Have to create empty tensor
call create(Tc, Tl%nqs, 0, errst=errst)
!if(prop_error('mcontr_qtensorc: create failed.', &
! 'ContractionOps_include.f90:3300', errst=errst)) return
return
elseif((Tl%nb == 0) .or. (Tm%nb == 0)) then
! The incoming tensor stays unmodified
return
end if
if(betazero) then
! Standard contraction
! ....................
call internal_mcontr_qtensorc_qtensor(Tc, Tl, Tm, &
idxl, idxm, transl, transr, alpha, errst=errst)
!if(prop_error('mcontr_qtensorc_'//&
! 'qtensor : internal_mcontr (1) '//&
! 'failed.', 'ContractionOps_include.f90:3316', errst=errst)) return
else
! Contraction and addition only works with GAXPY (for instance)
! ..............................................
call internal_mcontr_qtensorc_qtensor(Tens, Tl, Tm, &
idxl, idxm, transl, transr, alpha, errst=errst)
!if(prop_error('mcontr_qtensorc_'//&
! 'qtensor : internal_mcontr (2) '//&
! 'failed.', 'ContractionOps_include.f90:3326', errst=errst)) return
if(beta /= zone) then
call scale(beta, Tc, errst=errst)
!if(prop_error('qtensorc_qtensor'//&
! ': scale failed.', 'ContractionOps_include.f90:3331', &
! errst=errst)) return
end if
call gaxpy(Tc, zone, Tens, errst=errst)
!if(prop_error('mcontr_qtensorc_'//&
! 'qtensor : gaxpy failed.', &
! 'ContractionOps_include.f90:3338', errst=errst)) return
call destroy(Tens)
end if
end subroutine mcontr_qtensorc_qtensor
"""
return
[docs]def mcontr_qtensor_qtensorc():
"""
fortran-subroutine - October 2017 (dj)
Middle contraction or matrix contraction of a large tensor Tl with a small
matrix Tm to Tc = alpha Tl Tm + beta Tc.
**Arguments**
Tc : TYPE(qtensorc), inout
Result fo the contraction.
Tl : TYPE(qtensor), inout
Multi-link tensor which should be contracted over an interior index.
Tm : TYPE(qtensorc), inout
Tensor (matrix) contracted over first or last index.
idxl : INTEGER, inout
Index for contraction in Tl.
idxm : INTEGER, inout
Index for contraction in Tm, either 1 or 2.
transl : CHARACTER, inout
"N" for no transformation or "C" for complex conjugate of Tl.
transr : CHARACTER, inout
"N" for no transformation or "C" for complex conjugate of Tm.
alpha : complex, inout
Scale contraction of Tl with Tm.
beta : complex, inout
Scale incoming tensor Tc.
**Details**
The contr-methods wrapping LAPACK require permutation causing an
overhead which is not compensated for contractions with small matrices. This
is only the case, if one of the middle indices is contracted.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_qtensor_qtensorc(Tc, Tl, Tm, idxl, idxm, &
transl, transr, alpha, beta, errst)
type(qtensorc), intent(inout) :: Tc
type(qtensor), intent(inout) :: Tl
type(qtensorc), intent(inout) :: Tm
integer, dimension(:), intent(in) :: idxl, idxm
character, intent(in), optional :: transl, transr
complex(KIND=rKind), intent(in), optional :: alpha, beta
integer, intent(out), optional :: errst
! Local variables
! ---------------
! flag to check if beta = 0.0
logical :: betazero
! Temporary tensor for gaxpy
type(qtensorc) :: Tens
!if(present(errst)) errst = 0
betazero = .true.
if(present(beta)) betazero = (abs(beta) < 1e-14_rKind)
! Fast return
if(((Tl%nb == 0) .or. (Tm%nb == 0)) .and. betazero) then
! Have to create empty tensor
call create(Tc, Tl%nqs, 0, errst=errst)
!if(prop_error('mcontr_qtensorc: create failed.', &
! 'ContractionOps_include.f90:3300', errst=errst)) return
return
elseif((Tl%nb == 0) .or. (Tm%nb == 0)) then
! The incoming tensor stays unmodified
return
end if
if(betazero) then
! Standard contraction
! ....................
call internal_mcontr_qtensor_qtensorc(Tc, Tl, Tm, &
idxl, idxm, transl, transr, alpha, errst=errst)
!if(prop_error('mcontr_qtensor_'//&
! 'qtensorc : internal_mcontr (1) '//&
! 'failed.', 'ContractionOps_include.f90:3316', errst=errst)) return
else
! Contraction and addition only works with GAXPY (for instance)
! ..............................................
call internal_mcontr_qtensor_qtensorc(Tens, Tl, Tm, &
idxl, idxm, transl, transr, alpha, errst=errst)
!if(prop_error('mcontr_qtensor_'//&
! 'qtensorc : internal_mcontr (2) '//&
! 'failed.', 'ContractionOps_include.f90:3326', errst=errst)) return
if(beta /= zone) then
call scale(beta, Tc, errst=errst)
!if(prop_error('qtensor_qtensorc'//&
! ': scale failed.', 'ContractionOps_include.f90:3331', &
! errst=errst)) return
end if
call gaxpy(Tc, zone, Tens, errst=errst)
!if(prop_error('mcontr_qtensor_'//&
! 'qtensorc : gaxpy failed.', &
! 'ContractionOps_include.f90:3338', errst=errst)) return
call destroy(Tens)
end if
end subroutine mcontr_qtensor_qtensorc
"""
return
[docs]def mcontr_qtensorc_qtensorc():
"""
fortran-subroutine - October 2017 (dj)
Middle contraction or matrix contraction of a large tensor Tl with a small
matrix Tm to Tc = alpha Tl Tm + beta Tc.
**Arguments**
Tc : TYPE(qtensorc), inout
Result fo the contraction.
Tl : TYPE(qtensorc), inout
Multi-link tensor which should be contracted over an interior index.
Tm : TYPE(qtensorc), inout
Tensor (matrix) contracted over first or last index.
idxl : INTEGER, inout
Index for contraction in Tl.
idxm : INTEGER, inout
Index for contraction in Tm, either 1 or 2.
transl : CHARACTER, inout
"N" for no transformation or "C" for complex conjugate of Tl.
transr : CHARACTER, inout
"N" for no transformation or "C" for complex conjugate of Tm.
alpha : complex, inout
Scale contraction of Tl with Tm.
beta : complex, inout
Scale incoming tensor Tc.
**Details**
The contr-methods wrapping LAPACK require permutation causing an
overhead which is not compensated for contractions with small matrices. This
is only the case, if one of the middle indices is contracted.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine mcontr_qtensorc_qtensorc(Tc, Tl, Tm, idxl, idxm, &
transl, transr, alpha, beta, errst)
type(qtensorc), intent(inout) :: Tc
type(qtensorc), intent(inout) :: Tl
type(qtensorc), intent(inout) :: Tm
integer, dimension(:), intent(in) :: idxl, idxm
character, intent(in), optional :: transl, transr
complex(KIND=rKind), intent(in), optional :: alpha, beta
integer, intent(out), optional :: errst
! Local variables
! ---------------
! flag to check if beta = 0.0
logical :: betazero
! Temporary tensor for gaxpy
type(qtensorc) :: Tens
!if(present(errst)) errst = 0
betazero = .true.
if(present(beta)) betazero = (abs(beta) < 1e-14_rKind)
! Fast return
if(((Tl%nb == 0) .or. (Tm%nb == 0)) .and. betazero) then
! Have to create empty tensor
call create(Tc, Tl%nqs, 0, errst=errst)
!if(prop_error('mcontr_qtensorc: create failed.', &
! 'ContractionOps_include.f90:3300', errst=errst)) return
return
elseif((Tl%nb == 0) .or. (Tm%nb == 0)) then
! The incoming tensor stays unmodified
return
end if
if(betazero) then
! Standard contraction
! ....................
call internal_mcontr_qtensorc_qtensorc(Tc, Tl, Tm, &
idxl, idxm, transl, transr, alpha, errst=errst)
!if(prop_error('mcontr_qtensorc_'//&
! 'qtensorc : internal_mcontr (1) '//&
! 'failed.', 'ContractionOps_include.f90:3316', errst=errst)) return
else
! Contraction and addition only works with GAXPY (for instance)
! ..............................................
call internal_mcontr_qtensorc_qtensorc(Tens, Tl, Tm, &
idxl, idxm, transl, transr, alpha, errst=errst)
!if(prop_error('mcontr_qtensorc_'//&
! 'qtensorc : internal_mcontr (2) '//&
! 'failed.', 'ContractionOps_include.f90:3326', errst=errst)) return
if(beta /= zone) then
call scale(beta, Tc, errst=errst)
!if(prop_error('qtensorc_qtensorc'//&
! ': scale failed.', 'ContractionOps_include.f90:3331', &
! errst=errst)) return
end if
call gaxpy(Tc, zone, Tens, errst=errst)
!if(prop_error('mcontr_qtensorc_'//&
! 'qtensorc : gaxpy failed.', &
! 'ContractionOps_include.f90:3338', errst=errst)) return
call destroy(Tens)
end if
end subroutine mcontr_qtensorc_qtensorc
"""
return
[docs]def internal_mcontr_qtensor_qtensor():
"""
fortran-subroutine - September 2017 (dj)
Middle contraction or matrix contraction of a large tensor Tl with a small
matrix Tm to Tc = alpha Tl Tm + beta Tc.
**Arguments**
Tc : TYPE(qtensor), inout
Result fo the contraction.
Tl : TYPE(qtensor), inout
Multi-link tensor which should be contracted over an interior index.
Hashes are assumed to be possibly degenerate.
Tm : TYPE(qtensor), inout
Tensor (matrix) contracted over first or last index. Hashes are
assumed to be unique.
idxl : INTEGER, inout
Index for contraction in Tl.
idxm : INTEGER, inout
Index for contraction in Tm, either 1 or 2.
transl : CHARACTER, inout
"N" for no transformation or "C" for complex conjugate of Tl.
transr : CHARACTER, inout
"N" for no transformation or "C" for complex conjugate of Tm.
alpha : real, inout
Scale contraction of Tl with Tm.
**Details**
The contr-methods wrapping LAPACK require permutation causing an
overhead which is not compensated for contractions with small matrices. This
is only the case, if one of the middle indices is contracted.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine internal_mcontr_qtensor_qtensor(Tc, Tl, Tm, idxl, idxm, &
transl, transr, alpha, errst)
type(qtensor), intent(inout) :: Tc
type(qtensor), intent(inout) :: Tl
type(qtensor), intent(inout) :: Tm
integer, dimension(:), intent(in) :: idxl, idxm
character, intent(in), optional :: transl, transr
real(KIND=rKind), intent(in), optional :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! looping / indexing for degenerate list
integer :: i1, i2
! copying quantum numbers
integer :: k1, k2, j1, j2
! total number of quantum numbers
integer :: snqs
! number of matching blocks, contracted indices, degeneracy
integer :: ni
integer, dimension(:, :), allocatable :: cidx
integer, dimension(:), allocatable :: indout, degout
! quantum numbers of result
integer, dimension(:, :), allocatable :: qqq
!if(present(errst)) errst = 0
! Get indices to be contracted
allocate(cidx(2, Tl%nb * Tm%nb))
call get_contr_idx(Tl, idxl, Tm, idxm, [.true., .true.], cidx, ni, &
indout, degout, qqq=qqq, errst=errst)
!if(prop_error('contr_TENSOR_TYPE: get_contr_idx failed.', &
! errst=errst)) return
call create(Tc, Tl%nqs, ni, errst=errst)
!if(prop_error('contr_TENSOR_TYPE: create failed.', &
! errst=errst)) return
snqs = sum(Tl%nqs)
! Set number of blocks
Tc%nb = ni
do ii = 1, ni
i1 = indout(degout(ii) + 1)
call mcontr(Tc%Data(ii)%Tens, Tl%Data(cidx(1, i1))%Tens, &
Tm%Data(cidx(2, i1))%Tens, idxl, idxm, transl, &
transr, alpha, errst=errst)
!if(prop_error('internal_mcontr_qtensor_'//&
! 'qtensor : mcontr (1) failed.', &
! 'ContractionOps_include.f90:3480', errst=errst)) return
allocate(Tc%Data(ii)%qq(Tc%Data(ii)%Tens%rank * snqs))
!Tc%Data(ii)%qq = qqq(:, i1) ! Cannot use this one without perm
Tc%Data(ii)%qq = Tl%Data(cidx(1, i1))%qq
k1 = snqs * (idxl(1) - 1) + 1
k2 = snqs * idxl(size(idxl, 1))
if(idxm(1) == 1) then
j1 = snqs * idxm(size(idxm, 1)) + 1
j2 = snqs * Tm%Data(cidx(2, i1))%Tens%rank
else
j1 = 1
j2 = snqs * (idxm(1) - 1)
end if
Tc%Data(ii)%qq(k1:k2) = Tm%Data(cidx(2, i1))%qq(j1:j2)
do i2 = degout(ii) + 2, degout(ii + 1)
i1 = indout(i2)
call mcontr(Tc%Data(ii)%Tens, Tl%Data(cidx(1, i1))%Tens, &
Tm%Data(cidx(2, i1))%Tens, idxl, idxm, transl, &
transr, alpha, done, errst=errst)
!if(prop_error('internal_mcontr_qtensor_'//&
! 'qtensor : mcontr (2) failed.', &
! 'ContractionOps_include.f90:3508', errst=errst)) return
end do
end do
deallocate(cidx)
if(ni > 0) deallocate(indout, degout, qqq)
end subroutine internal_mcontr_qtensor_qtensor
"""
return
[docs]def internal_mcontr_qtensorc_qtensor():
"""
fortran-subroutine - September 2017 (dj)
Middle contraction or matrix contraction of a large tensor Tl with a small
matrix Tm to Tc = alpha Tl Tm + beta Tc.
**Arguments**
Tc : TYPE(qtensorc), inout
Result fo the contraction.
Tl : TYPE(qtensorc), inout
Multi-link tensor which should be contracted over an interior index.
Hashes are assumed to be possibly degenerate.
Tm : TYPE(qtensor), inout
Tensor (matrix) contracted over first or last index. Hashes are
assumed to be unique.
idxl : INTEGER, inout
Index for contraction in Tl.
idxm : INTEGER, inout
Index for contraction in Tm, either 1 or 2.
transl : CHARACTER, inout
"N" for no transformation or "C" for complex conjugate of Tl.
transr : CHARACTER, inout
"N" for no transformation or "C" for complex conjugate of Tm.
alpha : complex, inout
Scale contraction of Tl with Tm.
**Details**
The contr-methods wrapping LAPACK require permutation causing an
overhead which is not compensated for contractions with small matrices. This
is only the case, if one of the middle indices is contracted.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine internal_mcontr_qtensorc_qtensor(Tc, Tl, Tm, idxl, idxm, &
transl, transr, alpha, errst)
type(qtensorc), intent(inout) :: Tc
type(qtensorc), intent(inout) :: Tl
type(qtensor), intent(inout) :: Tm
integer, dimension(:), intent(in) :: idxl, idxm
character, intent(in), optional :: transl, transr
complex(KIND=rKind), intent(in), optional :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! looping / indexing for degenerate list
integer :: i1, i2
! copying quantum numbers
integer :: k1, k2, j1, j2
! total number of quantum numbers
integer :: snqs
! number of matching blocks, contracted indices, degeneracy
integer :: ni
integer, dimension(:, :), allocatable :: cidx
integer, dimension(:), allocatable :: indout, degout
! quantum numbers of result
integer, dimension(:, :), allocatable :: qqq
!if(present(errst)) errst = 0
! Get indices to be contracted
allocate(cidx(2, Tl%nb * Tm%nb))
call get_contr_idx(Tl, idxl, Tm, idxm, [.true., .true.], cidx, ni, &
indout, degout, qqq=qqq, errst=errst)
!if(prop_error('contr_TENSOR_TYPE: get_contr_idx failed.', &
! errst=errst)) return
call create(Tc, Tl%nqs, ni, errst=errst)
!if(prop_error('contr_TENSOR_TYPE: create failed.', &
! errst=errst)) return
snqs = sum(Tl%nqs)
! Set number of blocks
Tc%nb = ni
do ii = 1, ni
i1 = indout(degout(ii) + 1)
call mcontr(Tc%Data(ii)%Tens, Tl%Data(cidx(1, i1))%Tens, &
Tm%Data(cidx(2, i1))%Tens, idxl, idxm, transl, &
transr, alpha, errst=errst)
!if(prop_error('internal_mcontr_qtensorc_'//&
! 'qtensor : mcontr (1) failed.', &
! 'ContractionOps_include.f90:3480', errst=errst)) return
allocate(Tc%Data(ii)%qq(Tc%Data(ii)%Tens%rank * snqs))
!Tc%Data(ii)%qq = qqq(:, i1) ! Cannot use this one without perm
Tc%Data(ii)%qq = Tl%Data(cidx(1, i1))%qq
k1 = snqs * (idxl(1) - 1) + 1
k2 = snqs * idxl(size(idxl, 1))
if(idxm(1) == 1) then
j1 = snqs * idxm(size(idxm, 1)) + 1
j2 = snqs * Tm%Data(cidx(2, i1))%Tens%rank
else
j1 = 1
j2 = snqs * (idxm(1) - 1)
end if
Tc%Data(ii)%qq(k1:k2) = Tm%Data(cidx(2, i1))%qq(j1:j2)
do i2 = degout(ii) + 2, degout(ii + 1)
i1 = indout(i2)
call mcontr(Tc%Data(ii)%Tens, Tl%Data(cidx(1, i1))%Tens, &
Tm%Data(cidx(2, i1))%Tens, idxl, idxm, transl, &
transr, alpha, zone, errst=errst)
!if(prop_error('internal_mcontr_qtensorc_'//&
! 'qtensor : mcontr (2) failed.', &
! 'ContractionOps_include.f90:3508', errst=errst)) return
end do
end do
deallocate(cidx)
if(ni > 0) deallocate(indout, degout, qqq)
end subroutine internal_mcontr_qtensorc_qtensor
"""
return
[docs]def internal_mcontr_qtensor_qtensorc():
"""
fortran-subroutine - September 2017 (dj)
Middle contraction or matrix contraction of a large tensor Tl with a small
matrix Tm to Tc = alpha Tl Tm + beta Tc.
**Arguments**
Tc : TYPE(qtensorc), inout
Result fo the contraction.
Tl : TYPE(qtensor), inout
Multi-link tensor which should be contracted over an interior index.
Hashes are assumed to be possibly degenerate.
Tm : TYPE(qtensorc), inout
Tensor (matrix) contracted over first or last index. Hashes are
assumed to be unique.
idxl : INTEGER, inout
Index for contraction in Tl.
idxm : INTEGER, inout
Index for contraction in Tm, either 1 or 2.
transl : CHARACTER, inout
"N" for no transformation or "C" for complex conjugate of Tl.
transr : CHARACTER, inout
"N" for no transformation or "C" for complex conjugate of Tm.
alpha : complex, inout
Scale contraction of Tl with Tm.
**Details**
The contr-methods wrapping LAPACK require permutation causing an
overhead which is not compensated for contractions with small matrices. This
is only the case, if one of the middle indices is contracted.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine internal_mcontr_qtensor_qtensorc(Tc, Tl, Tm, idxl, idxm, &
transl, transr, alpha, errst)
type(qtensorc), intent(inout) :: Tc
type(qtensor), intent(inout) :: Tl
type(qtensorc), intent(inout) :: Tm
integer, dimension(:), intent(in) :: idxl, idxm
character, intent(in), optional :: transl, transr
complex(KIND=rKind), intent(in), optional :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! looping / indexing for degenerate list
integer :: i1, i2
! copying quantum numbers
integer :: k1, k2, j1, j2
! total number of quantum numbers
integer :: snqs
! number of matching blocks, contracted indices, degeneracy
integer :: ni
integer, dimension(:, :), allocatable :: cidx
integer, dimension(:), allocatable :: indout, degout
! quantum numbers of result
integer, dimension(:, :), allocatable :: qqq
!if(present(errst)) errst = 0
! Get indices to be contracted
allocate(cidx(2, Tl%nb * Tm%nb))
call get_contr_idx(Tl, idxl, Tm, idxm, [.true., .true.], cidx, ni, &
indout, degout, qqq=qqq, errst=errst)
!if(prop_error('contr_TENSOR_TYPE: get_contr_idx failed.', &
! errst=errst)) return
call create(Tc, Tl%nqs, ni, errst=errst)
!if(prop_error('contr_TENSOR_TYPE: create failed.', &
! errst=errst)) return
snqs = sum(Tl%nqs)
! Set number of blocks
Tc%nb = ni
do ii = 1, ni
i1 = indout(degout(ii) + 1)
call mcontr(Tc%Data(ii)%Tens, Tl%Data(cidx(1, i1))%Tens, &
Tm%Data(cidx(2, i1))%Tens, idxl, idxm, transl, &
transr, alpha, errst=errst)
!if(prop_error('internal_mcontr_qtensor_'//&
! 'qtensorc : mcontr (1) failed.', &
! 'ContractionOps_include.f90:3480', errst=errst)) return
allocate(Tc%Data(ii)%qq(Tc%Data(ii)%Tens%rank * snqs))
!Tc%Data(ii)%qq = qqq(:, i1) ! Cannot use this one without perm
Tc%Data(ii)%qq = Tl%Data(cidx(1, i1))%qq
k1 = snqs * (idxl(1) - 1) + 1
k2 = snqs * idxl(size(idxl, 1))
if(idxm(1) == 1) then
j1 = snqs * idxm(size(idxm, 1)) + 1
j2 = snqs * Tm%Data(cidx(2, i1))%Tens%rank
else
j1 = 1
j2 = snqs * (idxm(1) - 1)
end if
Tc%Data(ii)%qq(k1:k2) = Tm%Data(cidx(2, i1))%qq(j1:j2)
do i2 = degout(ii) + 2, degout(ii + 1)
i1 = indout(i2)
call mcontr(Tc%Data(ii)%Tens, Tl%Data(cidx(1, i1))%Tens, &
Tm%Data(cidx(2, i1))%Tens, idxl, idxm, transl, &
transr, alpha, zone, errst=errst)
!if(prop_error('internal_mcontr_qtensor_'//&
! 'qtensorc : mcontr (2) failed.', &
! 'ContractionOps_include.f90:3508', errst=errst)) return
end do
end do
deallocate(cidx)
if(ni > 0) deallocate(indout, degout, qqq)
end subroutine internal_mcontr_qtensor_qtensorc
"""
return
[docs]def internal_mcontr_qtensorc_qtensorc():
"""
fortran-subroutine - September 2017 (dj)
Middle contraction or matrix contraction of a large tensor Tl with a small
matrix Tm to Tc = alpha Tl Tm + beta Tc.
**Arguments**
Tc : TYPE(qtensorc), inout
Result fo the contraction.
Tl : TYPE(qtensorc), inout
Multi-link tensor which should be contracted over an interior index.
Hashes are assumed to be possibly degenerate.
Tm : TYPE(qtensorc), inout
Tensor (matrix) contracted over first or last index. Hashes are
assumed to be unique.
idxl : INTEGER, inout
Index for contraction in Tl.
idxm : INTEGER, inout
Index for contraction in Tm, either 1 or 2.
transl : CHARACTER, inout
"N" for no transformation or "C" for complex conjugate of Tl.
transr : CHARACTER, inout
"N" for no transformation or "C" for complex conjugate of Tm.
alpha : complex, inout
Scale contraction of Tl with Tm.
**Details**
The contr-methods wrapping LAPACK require permutation causing an
overhead which is not compensated for contractions with small matrices. This
is only the case, if one of the middle indices is contracted.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
subroutine internal_mcontr_qtensorc_qtensorc(Tc, Tl, Tm, idxl, idxm, &
transl, transr, alpha, errst)
type(qtensorc), intent(inout) :: Tc
type(qtensorc), intent(inout) :: Tl
type(qtensorc), intent(inout) :: Tm
integer, dimension(:), intent(in) :: idxl, idxm
character, intent(in), optional :: transl, transr
complex(KIND=rKind), intent(in), optional :: alpha
integer, intent(out), optional :: errst
! Local variables
! ---------------
! for looping
integer :: ii
! looping / indexing for degenerate list
integer :: i1, i2
! copying quantum numbers
integer :: k1, k2, j1, j2
! total number of quantum numbers
integer :: snqs
! number of matching blocks, contracted indices, degeneracy
integer :: ni
integer, dimension(:, :), allocatable :: cidx
integer, dimension(:), allocatable :: indout, degout
! quantum numbers of result
integer, dimension(:, :), allocatable :: qqq
!if(present(errst)) errst = 0
! Get indices to be contracted
allocate(cidx(2, Tl%nb * Tm%nb))
call get_contr_idx(Tl, idxl, Tm, idxm, [.true., .true.], cidx, ni, &
indout, degout, qqq=qqq, errst=errst)
!if(prop_error('contr_TENSOR_TYPE: get_contr_idx failed.', &
! errst=errst)) return
call create(Tc, Tl%nqs, ni, errst=errst)
!if(prop_error('contr_TENSOR_TYPE: create failed.', &
! errst=errst)) return
snqs = sum(Tl%nqs)
! Set number of blocks
Tc%nb = ni
do ii = 1, ni
i1 = indout(degout(ii) + 1)
call mcontr(Tc%Data(ii)%Tens, Tl%Data(cidx(1, i1))%Tens, &
Tm%Data(cidx(2, i1))%Tens, idxl, idxm, transl, &
transr, alpha, errst=errst)
!if(prop_error('internal_mcontr_qtensorc_'//&
! 'qtensorc : mcontr (1) failed.', &
! 'ContractionOps_include.f90:3480', errst=errst)) return
allocate(Tc%Data(ii)%qq(Tc%Data(ii)%Tens%rank * snqs))
!Tc%Data(ii)%qq = qqq(:, i1) ! Cannot use this one without perm
Tc%Data(ii)%qq = Tl%Data(cidx(1, i1))%qq
k1 = snqs * (idxl(1) - 1) + 1
k2 = snqs * idxl(size(idxl, 1))
if(idxm(1) == 1) then
j1 = snqs * idxm(size(idxm, 1)) + 1
j2 = snqs * Tm%Data(cidx(2, i1))%Tens%rank
else
j1 = 1
j2 = snqs * (idxm(1) - 1)
end if
Tc%Data(ii)%qq(k1:k2) = Tm%Data(cidx(2, i1))%qq(j1:j2)
do i2 = degout(ii) + 2, degout(ii + 1)
i1 = indout(i2)
call mcontr(Tc%Data(ii)%Tens, Tl%Data(cidx(1, i1))%Tens, &
Tm%Data(cidx(2, i1))%Tens, idxl, idxm, transl, &
transr, alpha, zone, errst=errst)
!if(prop_error('internal_mcontr_qtensorc_'//&
! 'qtensorc : mcontr (2) failed.', &
! 'ContractionOps_include.f90:3508', errst=errst)) return
end do
end do
deallocate(cidx)
if(ni > 0) deallocate(indout, degout, qqq)
end subroutine internal_mcontr_qtensorc_qtensorc
"""
return
[docs]def trace_rho_x_mat_tensor_tensor():
"""
fortran-function - November 2016 (dj)
Trace of the matrix-matrix multiplication of a density matrix and
a matrix.
**Arguments**
rho : RHO_TYOE(\*, \*), in
Density matrix. Must be hermitian since this property is used.
mat : tensor(\*, \*), in
Operator matrix.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function trace_rho_x_mat_tensor_tensor(Rho, Mat) result(tr)
type(tensor), intent(in) :: Rho
type(tensor), intent(in) :: Mat
real(KIND=rKind) :: tr
if(Rho%rank == 2) then
tr = trace_rho_x_mat_real_real(Rho%elem, Mat%elem, &
Rho%dl(1))
else
stop 'trace_rho_x_mat not implemented'
end if
end function trace_rho_x_mat_tensor_tensor
"""
return
[docs]def trace_rho_x_mat_tensorc_tensor():
"""
fortran-function - November 2016 (dj)
Trace of the matrix-matrix multiplication of a density matrix and
a matrix.
**Arguments**
rho : RHO_TYOE(\*, \*), in
Density matrix. Must be hermitian since this property is used.
mat : tensor(\*, \*), in
Operator matrix.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function trace_rho_x_mat_tensorc_tensor(Rho, Mat) result(tr)
type(tensorc), intent(in) :: Rho
type(tensor), intent(in) :: Mat
complex(KIND=rKind) :: tr
if(Rho%rank == 2) then
tr = trace_rho_x_mat_complex_real(Rho%elem, Mat%elem, &
Rho%dl(1))
else
stop 'trace_rho_x_mat not implemented'
end if
end function trace_rho_x_mat_tensorc_tensor
"""
return
[docs]def trace_rho_x_mat_tensorc_tensorc():
"""
fortran-function - November 2016 (dj)
Trace of the matrix-matrix multiplication of a density matrix and
a matrix.
**Arguments**
rho : RHO_TYOE(\*, \*), in
Density matrix. Must be hermitian since this property is used.
mat : tensorc(\*, \*), in
Operator matrix.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function trace_rho_x_mat_tensorc_tensorc(Rho, Mat) result(tr)
type(tensorc), intent(in) :: Rho
type(tensorc), intent(in) :: Mat
complex(KIND=rKind) :: tr
if(Rho%rank == 2) then
tr = trace_rho_x_mat_complex_complex(Rho%elem, Mat%elem, &
Rho%dl(1))
else
stop 'trace_rho_x_mat not implemented'
end if
end function trace_rho_x_mat_tensorc_tensorc
"""
return
[docs]def trace_rho_x_mat_qtensor_qtensor():
"""
fortran-function - November 2016 (dj)
Trace of the matrix-matrix multiplication of a density matrix and
a matrix.
**Arguments**
rho : RHO_TYOE(\*, \*), in
Density matrix. Must be hermitian since this property is used.
mat : qtensor(\*, \*), in
Operator matrix.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function trace_rho_x_mat_qtensor_qtensor(Rho, Mat) result(tr)
type(qtensor), intent(in) :: Rho
type(qtensor), intent(in) :: Mat
real(KIND=rKind) :: tr
! Local variables
! ---------------
! for looping
integer :: ii, jj
tr = dzero
! Fast return
if(Mat%nb == 0) return
! Note that rho is always diagonal in the quantum numbers
! And so only Delta q=0 matrices contribute (second return)
if(get_hash(Mat, [1], 1) - get_hash(Mat, [2], 1) .ne. 0.0_rKind) return
! Now assumed that M is invariant (Delta q=0)
! both matrices are already hashed and sorted
do ii = 1, Mat%nb
jj = Findtagindex(Mat%hash(ii), Rho%hash(1:rho%nb))
if(jj > 0) then
tr = tr + trace_rho_x_mat(Rho%Data(jj)%Tens, &
Mat%Data(ii)%Tens)
end if
end do
end function trace_rho_x_mat_qtensor_qtensor
"""
return
[docs]def trace_rho_x_mat_qtensorc_qtensor():
"""
fortran-function - November 2016 (dj)
Trace of the matrix-matrix multiplication of a density matrix and
a matrix.
**Arguments**
rho : RHO_TYOE(\*, \*), in
Density matrix. Must be hermitian since this property is used.
mat : qtensor(\*, \*), in
Operator matrix.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function trace_rho_x_mat_qtensorc_qtensor(Rho, Mat) result(tr)
type(qtensorc), intent(in) :: Rho
type(qtensor), intent(in) :: Mat
complex(KIND=rKind) :: tr
! Local variables
! ---------------
! for looping
integer :: ii, jj
tr = zzero
! Fast return
if(Mat%nb == 0) return
! Note that rho is always diagonal in the quantum numbers
! And so only Delta q=0 matrices contribute (second return)
if(get_hash(Mat, [1], 1) - get_hash(Mat, [2], 1) .ne. 0.0_rKind) return
! Now assumed that M is invariant (Delta q=0)
! both matrices are already hashed and sorted
do ii = 1, Mat%nb
jj = Findtagindex(Mat%hash(ii), Rho%hash(1:rho%nb))
if(jj > 0) then
tr = tr + trace_rho_x_mat(Rho%Data(jj)%Tens, &
Mat%Data(ii)%Tens)
end if
end do
end function trace_rho_x_mat_qtensorc_qtensor
"""
return
[docs]def trace_rho_x_mat_qtensorc_qtensorc():
"""
fortran-function - November 2016 (dj)
Trace of the matrix-matrix multiplication of a density matrix and
a matrix.
**Arguments**
rho : RHO_TYOE(\*, \*), in
Density matrix. Must be hermitian since this property is used.
mat : qtensorc(\*, \*), in
Operator matrix.
**Source Code**
.. hidden-code-block:: fortran
:label: show / hide f90 code
function trace_rho_x_mat_qtensorc_qtensorc(Rho, Mat) result(tr)
type(qtensorc), intent(in) :: Rho
type(qtensorc), intent(in) :: Mat
complex(KIND=rKind) :: tr
! Local variables
! ---------------
! for looping
integer :: ii, jj
tr = zzero
! Fast return
if(Mat%nb == 0) return
! Note that rho is always diagonal in the quantum numbers
! And so only Delta q=0 matrices contribute (second return)
if(get_hash(Mat, [1], 1) - get_hash(Mat, [2], 1) .ne. 0.0_rKind) return
! Now assumed that M is invariant (Delta q=0)
! both matrices are already hashed and sorted
do ii = 1, Mat%nb
jj = Findtagindex(Mat%hash(ii), Rho%hash(1:rho%nb))
if(jj > 0) then
tr = tr + trace_rho_x_mat(Rho%Data(jj)%Tens, &
Mat%Data(ii)%Tens)
end if
end do
end function trace_rho_x_mat_qtensorc_qtensorc
"""
return