-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathback_transform_matrix.f90
63 lines (42 loc) · 2.64 KB
/
back_transform_matrix.f90
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
subroutine back_transform_matrix(Q_norm,q)
use global
implicit none
integer :: i,j,k,l,m,n
! ------------------------------------------------------------------
! Orthogonal Transformation matrix for free ring-polymer cartesian to normal modes
! ------------------------------------------------------------------
real*8, intent(in) :: Q_norm(ndof,lb_m:ub_m)
real*8, intent(out) :: q(ndof,nb)
real*8 :: cmat(nb,lb_m:ub_m)
real*8 :: qnew(ndof,nb)
real*8 :: pibyn
pibyn = dacos(-1.d0)/nb
do j = 1,nb
do l = lb_m,ub_m
if(l.eq.0)then
cmat(j,l) = 1.0 !1.0/sqrt(real(nb))
else if(l.ge.lb_m.AND.l.lt.0) then
cmat(j,l) = dsqrt(2.0d0)*dsin(2.0*pibyn*j*l)
else if(l.gt.0.AND.l.le.ub_m) then
cmat(j,l) = dsqrt(2.0d0)*dcos(2.0*pibyn*j*l)
endif
enddo
enddo
!========================================================================
!do j = 1,nb
! do l = lb_m,ub_m
! write(4003,*) real(j),real(l),cmat(j,l)
! enddo
!enddo
qnew = 0.0d0
do j = 1,nb
do k = lb_m,ub_m
do m = 1,ndof
qnew(m,j) = qnew(m,j) + Q_norm(m,k)*cmat(j,k)
enddo
enddo
enddo
q = qnew
return
end subroutine back_transform_matrix
!==============================================================================================