mirror of
https://github.com/QuantumPackage/qp2.git
synced 2024-11-07 06:33:49 +01:00
44 lines
972 B
Fortran
44 lines
972 B
Fortran
|
|
||
|
|
! ---
|
||
|
|
|
||
|
|
subroutine LTxSxR(n, m, L, S, R, C)
|
||
|
|
|
||
|
|
implicit none
|
||
|
|
integer, intent(in) :: n, m
|
||
|
|
double precision, intent(in) :: L(n,m), S(n,n), R(n,m)
|
||
|
|
double precision, intent(out) :: C(m,m)
|
||
|
|
integer :: i, j
|
||
|
|
double precision :: accu_d, accu_nd
|
||
|
|
double precision, allocatable :: tmp(:,:)
|
||
|
|
|
||
|
|
! L.T x S x R
|
||
|
|
allocate(tmp(m,n))
|
||
|
|
call dgemm( 'T', 'N', m, n, n, 1.d0 &
|
||
|
|
, L, size(L, 1), S, size(S, 1) &
|
||
|
|
, 0.d0, tmp, size(tmp, 1) )
|
||
|
|
call dgemm( 'N', 'N', m, m, n, 1.d0 &
|
||
|
|
, tmp, size(tmp, 1), R, size(R, 1) &
|
||
|
|
, 0.d0, C, size(C, 1) )
|
||
|
|
deallocate(tmp)
|
||
|
|
|
||
|
|
accu_d = 0.d0
|
||
|
|
accu_nd = 0.d0
|
||
|
|
do i = 1, m
|
||
|
|
do j = 1, m
|
||
|
|
if(j.eq.i) then
|
||
|
|
accu_d += dabs(C(j,i))
|
||
|
|
else
|
||
|
|
accu_nd += C(j,i) * C(j,i)
|
||
|
|
endif
|
||
|
|
enddo
|
||
|
|
enddo
|
||
|
|
accu_nd = dsqrt(accu_nd)
|
||
|
|
|
||
|
|
print*, ' accu_d = ', accu_d
|
||
|
|
print*, ' accu_nd = ', accu_nd
|
||
|
|
|
||
|
|
end subroutine LTxR
|
||
|
|
|
||
|
|
! ---
|
||
|
|
|