mirror of
https://github.com/QuantumPackage/qp2.git
synced 2024-09-02 01:03:45 +02:00
2.4 KiB
2.4 KiB
Rotation matrix with the iterative method
\begin{align*}
\textbf{R} = \sum_{k=0}^{\infty} \frac{1}{k!} \textbf{X}^k
\end{align*}
!!! Doesn't work !!!
subroutine rotation_matrix_iterative(m,X,R)
implicit none
! in
integer, intent(in) :: m
double precision, intent(in) :: X(m,m)
! out
double precision, intent(out) :: R(m,m)
! internal
double precision :: max_elem, pre_factor
double precision :: t1,t2,t3
integer :: k,l,i,j
logical :: not_converged
double precision, allocatable :: RRT(:,:), A(:,:), B(:,:)
! Functions
integer :: factorial
print*,'---rotation_matrix_iterative---'
call wall_time(t1)
allocate(RRT(m,m),A(m,m),B(m,m))
! k = 0
R = 0d0
do i = 1, m
R(i,i) = 1d0
enddo
! k = 1
R = R + X
k = 2
not_converged = .True.
do while (not_converged)
pre_factor = 1d0/DBLE(factorial(k))
if (pre_factor < 1d-15) then
print*,'pre factor=', pre_factor,'< 1d-15, exit'
exit
endif
A = X
B = 0d0
do l = 1, k-1
call dgemm('N','N',m,m,m,1d0,X,size(X,1),A,size(A,1),0d0,B,size(B,1))
A = B
enddo
!print*,'B'
!do i = 1, m
! print*,B(i,:) * 1d0/DBLE(factorial(k))
!enddo
R = R + pre_factor * B
k = k + 1
call dgemm('T','N',m,m,m,1d0,R,size(R,1),R,size(R,1),0d0,RRT,size(RRT,1))
!print*,'R'
!do i = 1, m
! write(*,'(10(E12.5))') R(i,:)
!enddo
do i = 1, m
RRT(i,i) = RRT(i,i) - 1d0
enddo
!print*,'RRT'
!do i = 1, m
! write(*,'(10(E12.5))') RRT(i,:)
!enddo
max_elem = 0d0
do j = 1, m
do i = 1, m
if (dabs(RRT(i,j)) > max_elem) then
max_elem = dabs(RRT(i,j))
endif
enddo
enddo
print*, 'Iteration:', k
print*, 'Max error in R:', max_elem
if (max_elem < 1d-12) then
not_converged = .False.
endif
enddo
deallocate(RRT,A,B)
call wall_time(t2)
t3 = t2 - t1
print*,'Time in rotation matrix iterative:', t3
print*,'---End roration_matrix_iterative---'
print*,'Does not work yet, abort'
call abort
end
Factorial
function factorial(n)
implicit none
integer, intent(in) :: n
integer :: factorial, k
factorial = 1
do k = 1, n
factorial = factorial * k
enddo
end