28#include "../base/base_uses.f90"
33 LOGICAL,
PRIVATE,
PARAMETER :: debug_this_module = .true.
34 CHARACTER(len=*),
PARAMETER,
PRIVATE :: moduleN =
'pint_normalmode'
58 INTEGER,
INTENT(in) :: p
59 REAL(kind=
dp),
INTENT(in) :: kt
60 INTEGER,
INTENT(in) :: propagator
62 INTEGER :: i, j, k, li
63 LOGICAL :: explicit_gamma, explicit_modefactor
64 REAL(kind=
dp) :: gamma_parameter, invsqrtp, pip, sqrt2p, &
67 ALLOCATE (normalmode_env%x2u(p, p))
68 ALLOCATE (normalmode_env%u2x(p, p))
69 ALLOCATE (normalmode_env%lambda(p))
74 r_val=normalmode_env%Q_centroid)
76 r_val=normalmode_env%Q_bead)
78 explicit=explicit_modefactor, &
79 r_val=normalmode_env%modefactor)
81 r_val=gamma_parameter, &
82 explicit=explicit_gamma)
84 IF (explicit_modefactor .AND. explicit_gamma)
THEN
85 cpabort(
"Both GAMMA and MODEFACTOR have been declared. Please use only one.")
87 IF (explicit_gamma)
THEN
88 normalmode_env%modefactor = 1.0_dp/gamma_parameter**2
92 IF (.NOT. explicit_gamma)
THEN
93 cpabort(
"GAMMA needs to be specified with CMD PROPAGATOR")
95 IF (gamma_parameter <= 1.0_dp)
THEN
96 cpwarn(
"GAMMA should be larger than 1.0 for CMD PROPAGATOR")
100 IF (normalmode_env%Q_centroid < 0.0_dp)
THEN
101 normalmode_env%Q_centroid = -normalmode_env%Q_centroid/(kt*p)
103 IF (normalmode_env%Q_bead < 0.0_dp)
THEN
104 normalmode_env%Q_bead = -normalmode_env%Q_bead/(kt*p)
111 normalmode_env%harm = p*kt*kt/normalmode_env%modefactor
113 normalmode_env%harm = p*kt*kt*gamma_parameter*gamma_parameter
114 normalmode_env%modefactor = 1.0_dp/(gamma_parameter*gamma_parameter)
119 normalmode_env%lambda(i) = 2.0_dp*(1.0_dp - cos(
pi*(i/2)*2.0_dp/p))
121 k = ((i/2)*(j - 1))/p
122 k = (i/2)*(j - 1) - k*p
123 li = 2*(i - 2*(i/2))*p - p
124 normalmode_env%u2x(j, i) = sqrt(2.0_dp/p)*sin(
twopi*(k + 0.125_dp*li)/p)
127 normalmode_env%lambda(1) = 1.0_dp/(p*normalmode_env%modefactor)
130 normalmode_env%x2u(i, j) = sqrt(normalmode_env%lambda(i)* &
131 normalmode_env%modefactor)* &
132 normalmode_env%u2x(j, i)
137 normalmode_env%u2x(i, j) = normalmode_env%u2x(i, j)/ &
138 sqrt(normalmode_env%lambda(j)* &
139 normalmode_env%modefactor)
142 normalmode_env%lambda(:) = normalmode_env%harm
145 normalmode_env%harm = kt/normalmode_env%modefactor
146 sqrt2p = sqrt(2.0_dp/real(p,
dp))
149 invsqrtp = 1.0_dp/sqrt(real(p,
dp))
150 normalmode_env%x2u(:, :) = 0.0_dp
151 normalmode_env%x2u(1, :) = invsqrtp
154 normalmode_env%x2u(i, j) = sqrt2p*cos(twopip*(i - 1)*(j - 1))
157 normalmode_env%x2u(i, j) = sqrt2p*sin(twopip*(i - 1)*(j - 1))
160 IF (mod(p, 2) == 0)
THEN
162 normalmode_env%x2u(p/2 + 1, i) = invsqrtp
163 normalmode_env%x2u(p/2 + 1, i + 1) = -1.0_dp*invsqrtp
167 normalmode_env%u2x = transpose(normalmode_env%x2u)
170 normalmode_env%lambda(1) = 0.0_dp
172 normalmode_env%lambda(i) = 2.0_dp*normalmode_env%harm*sin((i - 1)*pip)
173 normalmode_env%lambda(i) = normalmode_env%lambda(i)*normalmode_env%lambda(i)
175 normalmode_env%harm = kt*kt
177 cpabort(
"UNKNOWN PROPAGATOR FOR PINT SELECTED")
191 DEALLOCATE (normalmode_env%x2u)
192 DEALLOCATE (normalmode_env%u2x)
193 DEALLOCATE (normalmode_env%lambda)
211 REAL(kind=
dp),
DIMENSION(:),
INTENT(in) :: mass
212 REAL(kind=
dp),
DIMENSION(:, :),
INTENT(out), &
213 OPTIONAL :: mass_beads, mass_fict
214 REAL(kind=
dp),
DIMENSION(:),
INTENT(out),
OPTIONAL :: q
219 q = normalmode_env%Q_bead
220 q(1) = normalmode_env%Q_centroid
222 IF (
PRESENT(mass_beads) .OR.
PRESENT(mass_fict))
THEN
223 IF (
PRESENT(mass_beads))
THEN
224 DO iat = 1,
SIZE(mass)
225 mass_beads(1, iat) = 0.0_dp
226 DO ib = 2, normalmode_env%p
227 mass_beads(ib, iat) = mass(iat)
231 IF (
PRESENT(mass_fict))
THEN
232 DO iat = 1,
SIZE(mass)
233 DO ib = 1, normalmode_env%p
234 mass_fict(ib, iat) = mass(iat)
252 REAL(kind=
dp),
DIMENSION(:, :),
INTENT(out) :: ux
253 REAL(kind=
dp),
DIMENSION(:, :),
INTENT(in) :: x
255 CALL dgemm(
'N',
'N', normalmode_env%p,
SIZE(x, 2), normalmode_env%p, 1.0_dp, &
256 normalmode_env%x2u(1, 1),
SIZE(normalmode_env%x2u, 1), x(1, 1),
SIZE(x, 1), &
257 0.0_dp, ux,
SIZE(ux, 1))
270 REAL(kind=
dp),
DIMENSION(:, :),
INTENT(in) :: ux
271 REAL(kind=
dp),
DIMENSION(:, :),
INTENT(out) :: x
273 CALL dgemm(
'N',
'N', normalmode_env%p,
SIZE(ux, 2), normalmode_env%p, 1.0_dp, &
274 normalmode_env%u2x(1, 1),
SIZE(normalmode_env%u2x, 1), ux(1, 1),
SIZE(ux, 1), &
275 0.0_dp, x,
SIZE(x, 1))
287 REAL(kind=
dp),
DIMENSION(:, :),
INTENT(out) :: uf
288 REAL(kind=
dp),
DIMENSION(:, :),
INTENT(in) :: f
290 CALL dgemm(
'T',
'N', normalmode_env%p,
SIZE(f, 2), normalmode_env%p, 1.0_dp, &
291 normalmode_env%u2x(1, 1),
SIZE(normalmode_env%u2x, 1), f(1, 1),
SIZE(f, 1), &
292 0.0_dp, uf,
SIZE(uf, 1))
306 REAL(kind=
dp),
DIMENSION(:, :),
POINTER :: mass_beads, ux, uf_h
307 REAL(kind=
dp),
INTENT(OUT) :: e_h
309 INTEGER :: ibead, idim
313 DO idim = 1,
SIZE(mass_beads, 2)
318 uf_h(1, idim) = 0.0_dp
319 DO ibead = 2, normalmode_env%p
320 f = -mass_beads(ibead, idim)*normalmode_env%lambda(ibead)*ux(ibead, idim)
321 uf_h(ibead, idim) = f
323 e_h = e_h - 0.5_dp*ux(ibead, idim)*f
static void dgemm(const char transa, const char transb, const int m, const int n, const int k, const double alpha, const double *a, const int lda, const double *b, const int ldb, const double beta, double *c, const int ldc)
Convenient wrapper to hide Fortran nature of dgemm_, swapping a and b.
Defines the basic variable types.
integer, parameter, public dp
Definition of mathematical constants and functions.
real(kind=dp), parameter, public pi
real(kind=dp), parameter, public twopi
Data type and methods dealing with PI calcs in normal mode coords.
pure subroutine, public normalmode_calc_uf_h(normalmode_env, mass_beads, ux, uf_h, e_h)
calculates the harmonic force in the normal mode basis
subroutine, public normalmode_x2u(normalmode_env, ux, x)
Transforms from the x into the u variables using a normal mode transformation for the positions.
subroutine, public normalmode_u2x(normalmode_env, ux, x)
transform from the u variable to the x (back normal mode transformation for the positions)
pure subroutine, public normalmode_release(normalmode_env)
releases the normalmode environment
subroutine, public normalmode_f2uf(normalmode_env, uf, f)
normalmode transformation for the forces
subroutine, public normalmode_env_create(normalmode_env, normalmode_section, p, kt, propagator)
creates the data needed for a normal mode transformation
pure subroutine, public normalmode_init_masses(normalmode_env, mass, mass_beads, mass_fict, q)
initializes the masses and fictitious masses compatible with the normal mode information
data to perform the normalmode transformation