45 #include "../base/base_uses.f90"
56 CHARACTER(len=*),
PARAMETER,
PRIVATE :: moduleN =
'pint_qtb'
69 TYPE(qtb_therm_type),
POINTER :: qtb_therm
70 TYPE(pint_env_type),
INTENT(INOUT) :: pint_env
71 TYPE(normalmode_env_type),
POINTER :: normalmode_env
72 TYPE(section_vals_type),
POINTER :: section
74 CHARACTER(LEN=rng_record_length) :: rng_record
77 REAL(kind=
dp) :: dti2, ex
78 REAL(kind=
dp),
DIMENSION(3, 2) :: initial_seed
79 TYPE(section_vals_type),
POINTER :: rng_section
82 cpabort(
"QTB is designed to work with the RPMD propagator only")
85 pint_env%e_qtb = 0.0_dp
87 qtb_therm%thermostat_energy = 0.0_dp
99 dti2 = 0.5_dp*pint_env%dt
100 ALLOCATE (qtb_therm%c1(p))
101 ALLOCATE (qtb_therm%c2(p))
102 ALLOCATE (qtb_therm%g_fric(p))
103 ALLOCATE (qtb_therm%massfact(p, pint_env%ndim))
106 qtb_therm%g_fric(1) = 1.0_dp/qtb_therm%tau
108 qtb_therm%g_fric(i) = sqrt((1.d0/qtb_therm%tau)**2 + (qtb_therm%lamb)**2* &
109 normalmode_env%lambda(i))
112 ex = -dti2*qtb_therm%g_fric(i)
113 qtb_therm%c1(i) = exp(ex)
114 ex = qtb_therm%c1(i)*qtb_therm%c1(i)
115 qtb_therm%c2(i) = sqrt(1.0_dp - ex)
117 DO j = 1, pint_env%ndim
119 qtb_therm%massfact(i, j) = sqrt(1.0_dp/pint_env%mass_fict(i, j))
124 NULLIFY (rng_section)
126 subsection_name=
"RNG_INIT")
130 i_rep_val=1, c_val=rng_record)
133 initial_seed(:, :) = real(pint_env%thermostat_rng_seed,
dp)
134 qtb_therm%gaussian_rng_stream = rng_stream_type( &
135 name=
"qtb_rng_gaussian", distribution_type=
gaussian, &
136 extended_precision=.true., &
141 CALL pint_qtb_forces_init(pint_env, normalmode_env, qtb_therm, restart)
155 REAL(kind=
dp),
DIMENSION(:, :),
POINTER :: vold, vnew
156 INTEGER,
INTENT(IN) :: p, ndim
157 REAL(kind=
dp),
DIMENSION(:, :),
INTENT(IN) :: masses
158 TYPE(qtb_therm_type),
POINTER :: qtb_therm
160 CHARACTER(len=*),
PARAMETER :: routinen =
'pint_qtb_step'
162 INTEGER :: handle, i, ibead, idim
163 REAL(kind=
dp) :: delta_ekin
165 CALL timeset(routinen, handle)
170 qtb_therm%cpt(ibead) = qtb_therm%cpt(ibead) + 1
172 IF (qtb_therm%cpt(ibead) == 2*qtb_therm%step(ibead))
THEN
175 DO i = 1, qtb_therm%nf - 1
176 qtb_therm%rng_status(i) = qtb_therm%rng_status(i + 1)
178 CALL qtb_therm%gaussian_rng_stream%dump(qtb_therm%rng_status(qtb_therm%nf))
182 DO i = 1, qtb_therm%nf - 1
183 qtb_therm%r(i, ibead, idim) = qtb_therm%r(i + 1, ibead, idim)
185 qtb_therm%r(qtb_therm%nf, ibead, idim) = qtb_therm%gaussian_rng_stream%next()
187 qtb_therm%rf(ibead, idim) = 0.0_dp
188 DO i = 1, qtb_therm%nf
189 qtb_therm%rf(ibead, idim) = qtb_therm%rf(ibead, idim) + &
190 qtb_therm%h(i, ibead)*qtb_therm%r(i, ibead, idim)
193 qtb_therm%cpt(ibead) = 0
200 vnew(ibead, idim) = qtb_therm%c1(ibead)*vold(ibead, idim) + &
201 qtb_therm%massfact(ibead, idim)*qtb_therm%c2(ibead)* &
202 qtb_therm%rf(ibead, idim)
203 delta_ekin = delta_ekin + masses(ibead, idim)*( &
204 vnew(ibead, idim)*vnew(ibead, idim) - &
205 vold(ibead, idim)*vold(ibead, idim))
209 qtb_therm%thermostat_energy = qtb_therm%thermostat_energy - 0.5_dp*delta_ekin
211 CALL timestop(handle)
220 TYPE(qtb_therm_type),
INTENT(INOUT) :: qtb_therm
222 DEALLOCATE (qtb_therm%c1)
223 DEALLOCATE (qtb_therm%c2)
224 DEALLOCATE (qtb_therm%g_fric)
225 DEALLOCATE (qtb_therm%massfact)
226 DEALLOCATE (qtb_therm%rf)
227 DEALLOCATE (qtb_therm%h)
228 DEALLOCATE (qtb_therm%r)
229 DEALLOCATE (qtb_therm%cpt)
230 DEALLOCATE (qtb_therm%step)
231 DEALLOCATE (qtb_therm%rng_status)
240 TYPE(pint_env_type),
INTENT(INOUT) :: pint_env
242 IF (
ASSOCIATED(pint_env%qtb_therm))
THEN
243 pint_env%e_qtb = pint_env%qtb_therm%thermostat_energy
256 SUBROUTINE pint_qtb_forces_init(pint_env, normalmode_env, qtb_therm, restart)
257 TYPE(pint_env_type),
INTENT(IN) :: pint_env
258 TYPE(normalmode_env_type),
POINTER :: normalmode_env
259 TYPE(qtb_therm_type),
POINTER :: qtb_therm
262 CHARACTER(len=*),
PARAMETER :: routinen =
'pint_qtb_forces_init'
264 COMPLEX(KIND=dp) :: tmp1
265 COMPLEX(KIND=dp),
ALLOCATABLE,
DIMENSION(:) :: filter
266 INTEGER :: handle, i, ibead, idim, log_unit, ndim, &
267 nf, p, print_level, step
268 REAL(kind=
dp) :: aa, bb, correct, dt, dw, fcut, h, kt, &
270 REAL(kind=
dp),
ALLOCATABLE,
DIMENSION(:) :: fp
271 REAL(kind=
dp),
DIMENSION(:),
POINTER :: fp1
272 TYPE(cp_logger_type),
POINTER :: logger
273 TYPE(fft_plan_type) :: plan
274 TYPE(mp_para_env_type),
POINTER :: para_env
276 CALL timeset(routinen, handle)
278 IF (
fft_type /= 3)
CALL cp_warn(__location__,
"The FFT library in use cannot"// &
279 " handle transformation of an arbitrary length.")
284 IF (mod(qtb_therm%nf, 2) /= 0) qtb_therm%nf = qtb_therm%nf + 1
287 para_env => pint_env%logger%para_env
289 ALLOCATE (qtb_therm%rng_status(nf))
290 ALLOCATE (qtb_therm%h(nf, p))
291 ALLOCATE (qtb_therm%step(p))
294 IF (para_env%is_source())
THEN
298 print_level = logger%iter_info%print_level
301 kt = pint_env%kT*pint_env%propagator%temp_sim2phys
304 ALLOCATE (filter(0:nf - 1))
308 CALL open_file(file_name=trim(logger%iter_info%project_name)//
".qtbLog", &
309 file_action=
"WRITE", file_status=
"UNKNOWN", unit_number=log_unit)
310 WRITE (log_unit,
'(A)')
' # Log file for the QTB random forces generation'
311 WRITE (log_unit,
'(A)')
' # ------------------------------------------------'
312 WRITE (log_unit,
'(A,I5)')
' # Number of beads P = ', p
313 WRITE (log_unit,
'(A,I6)')
' # Number of dimension 3*N = ', ndim
314 WRITE (log_unit,
'(A,I4)')
' # Number of filter parameters Nf=', nf
320 fcut = sqrt((1.d0/qtb_therm%taucut)**2 + (qtb_therm%lambcut)**2* &
321 normalmode_env%lambda(ibead))
324 qtb_therm%step(ibead) = nint(1.0_dp/(2.0_dp*fcut*dt))
325 IF (qtb_therm%step(ibead) == 0) qtb_therm%step(ibead) = 1
326 step = qtb_therm%step(ibead)
333 IF (qtb_therm%fp == 0)
THEN
334 CALL pint_qtb_computefp0(pint_env, fp, fp1, dw, aa, bb, log_unit, ibead, print_level)
336 CALL pint_qtb_computefp1(pint_env, fp, fp1, dw, aa, bb, log_unit, ibead, print_level)
341 WRITE (log_unit,
'(A,I4,A)')
' # -------- NM ', ibead,
' --------'
342 WRITE (log_unit,
'(A,I4,A)')
' # New random forces every ', step,
' MD steps'
343 WRITE (log_unit,
'(A,ES13.3,A)')
' # Angular cutoff freq. = ',
twopi*fcut*4.1341e4_dp,
' rad/ps'
344 WRITE (log_unit,
'(A,ES13.3,A)')
' # Free ring polymer angular freq.= ', &
345 sqrt(normalmode_env%lambda(ibead))*4.1341e4_dp,
' rad/ps'
346 WRITE (log_unit,
'(A,ES13.3,A)')
' # Friction coeff. = ', qtb_therm%g_fric(ibead)*4.1341e4_dp,
' THz'
347 WRITE (log_unit,
'(A,ES13.3,A)')
' # Angular frequency step dw = ', dw*4.1341e4_dp,
' rad/ps'
352 filter(0) = sqrt(kt)*(1.0_dp, 0.0_dp)
353 ELSE IF (qtb_therm%fp == 1 .AND. ibead == 1)
THEN
354 filter(0) = sqrt(p*kt)*(1.0_dp, 0.0_dp)
356 filter(0) = sqrt(p*kt*fp1(1))*(1.0_dp, 0.0_dp)
361 correct = sin(tmp)/tmp
362 filter(i) = sqrt(fp(i))/correct*(1.0_dp, 0.0_dp)
363 filter(nf - i) = conjg(filter(i))
367 CALL pint_qtb_fft(filter, filter, plan, nf)
374 tmp1 = filter(i)/(nf*sqrt(2.0_dp*step))
375 filter(i) = filter(nf/2 + i)/(nf*sqrt(2.0_dp*step))
376 filter(nf/2 + i) = tmp1
380 qtb_therm%h(i + 1, ibead) = real(filter(i),
dp)
386 IF (p > 1)
DEALLOCATE (fp1)
389 CALL para_env%bcast(qtb_therm%h)
390 CALL para_env%bcast(qtb_therm%step)
392 ALLOCATE (qtb_therm%r(nf, p, ndim))
393 ALLOCATE (qtb_therm%cpt(p))
394 ALLOCATE (qtb_therm%rf(p, ndim))
397 CALL pint_qtb_restart(pint_env, qtb_therm)
400 DO i = 1, qtb_therm%nf
401 CALL qtb_therm%gaussian_rng_stream%dump(qtb_therm%rng_status(i))
408 qtb_therm%r(i, ibead, idim) = qtb_therm%gaussian_rng_stream%next()
417 qtb_therm%rf(ibead, idim) = 0.0_dp
419 qtb_therm%rf(ibead, idim) = qtb_therm%rf(ibead, idim) + &
420 qtb_therm%h(i, ibead)*qtb_therm%r(i, ibead, idim)
425 CALL timestop(handle)
426 END SUBROUTINE pint_qtb_forces_init
435 SUBROUTINE pint_qtb_restart(pint_env, qtb_therm)
436 TYPE(pint_env_type),
INTENT(IN) :: pint_env
437 TYPE(qtb_therm_type),
POINTER :: qtb_therm
439 INTEGER :: begin, i, ibead, idim, istep
441 begin = pint_env%first_step - mod(pint_env%first_step, qtb_therm%step(1)) - &
442 (qtb_therm%nf - 1)*qtb_therm%step(1)
447 DO i = 1, qtb_therm%nf
448 CALL qtb_therm%gaussian_rng_stream%dump(qtb_therm%rng_status(i))
451 DO idim = 1, pint_env%ndim
452 DO ibead = 1, pint_env%p
453 DO i = 1, qtb_therm%nf
454 qtb_therm%r(i, ibead, idim) = qtb_therm%gaussian_rng_stream%next()
460 qtb_therm%cpt(1) = 2*(qtb_therm%step(1) - 1)
461 DO ibead = 2, pint_env%p
462 qtb_therm%cpt(ibead) = 2*mod(begin - 1, qtb_therm%step(ibead))
469 DO istep = 1, 2*(pint_env%first_step - begin + 1)
470 DO ibead = 1, pint_env%p
471 qtb_therm%cpt(ibead) = qtb_therm%cpt(ibead) + 1
473 IF (qtb_therm%cpt(ibead) == 2*qtb_therm%step(ibead))
THEN
476 DO i = 1, qtb_therm%nf - 1
477 qtb_therm%rng_status(i) = qtb_therm%rng_status(i + 1)
479 CALL qtb_therm%gaussian_rng_stream%dump(qtb_therm%rng_status(qtb_therm%nf))
481 DO idim = 1, pint_env%ndim
483 DO i = 1, qtb_therm%nf - 1
484 qtb_therm%r(i, ibead, idim) = qtb_therm%r(i + 1, ibead, idim)
486 qtb_therm%r(qtb_therm%nf, ibead, idim) = qtb_therm%gaussian_rng_stream%next()
488 qtb_therm%cpt(ibead) = 0
493 END SUBROUTINE pint_qtb_restart
509 SUBROUTINE pint_qtb_computefp0(pint_env, fp, fp1, dw, aa, bb, log_unit, ibead, print_level)
510 TYPE(pint_env_type),
INTENT(IN) :: pint_env
511 REAL(kind=
dp),
DIMENSION(:),
INTENT(INOUT) :: fp
512 REAL(kind=
dp),
DIMENSION(:),
POINTER :: fp1
513 REAL(kind=
dp),
INTENT(IN) :: dw, aa, bb
514 INTEGER,
INTENT(IN) :: log_unit, ibead, print_level
516 CHARACTER(len=200) :: line
517 INTEGER :: i, j, k, n, niter, nx, p
518 INTEGER,
ALLOCATABLE,
DIMENSION(:, :) :: kk
519 REAL(kind=
dp) :: dx, dx1, err, fprev, hbokt, malpha, op, &
520 r2, tmp, w, x1, xmax, xmin, xx
521 REAL(kind=
dp),
ALLOCATABLE,
DIMENSION(:) :: h, x, x2
522 REAL(kind=
dp),
ALLOCATABLE,
DIMENSION(:, :) :: fpxk, xk, xk2
528 hbokt = 1.0_dp/(pint_env%kT*pint_env%propagator%temp_sim2phys)
536 fp(j) = tmp*(0.5_dp + 1.0_dp/(exp(tmp) - 1.0_dp))
540 WRITE (log_unit,
'(A)')
' # ------------------------------------------------'
541 WRITE (log_unit,
'(A)')
' # computed fp^(0) function'
542 WRITE (log_unit,
'(A)')
' # i, w(a.u.), fp'
544 WRITE (log_unit, *) j, j*dw, j*0.5_dp*hbokt*dw, fp(j)
550 dx1 = 0.5_dp*hbokt*dw
554 nx = int((xmax - xmin)/dx) + 1
563 WRITE (log_unit,
'(A)')
' # ------------------------------------------------'
564 WRITE (log_unit,
'(A)')
' # computing fp^(0) function'
565 WRITE (log_unit,
'(A)')
' # parameters used:'
566 WRITE (log_unit,
'(A,ES13.3)')
' # dx = ', dx
567 WRITE (log_unit,
'(A,ES13.3)')
' # xmin = ', xmin
568 WRITE (log_unit,
'(A,ES13.3)')
' # xmax = ', xmax
569 WRITE (log_unit,
'(A,I8,I8)')
' # nx, n = ', nx, n
576 ALLOCATE (xk(p - 1, nx))
577 ALLOCATE (xk2(p - 1, nx))
578 ALLOCATE (kk(p - 1, nx))
579 ALLOCATE (fpxk(p - 1, nx))
585 x(j) = xmin + (j - 1)*dx
587 h(j) = x(j)/tanh(x(j))
588 IF (x(j) <= 1.0e-10_dp) h(j) = 1.0_dp
589 fp1(j) = op*x(j)/tanh(x(j)*op)
590 IF (x(j)*op <= 1.0e-10_dp) fp1(j) = 1.0_dp
592 xk2(k, j) = x2(j) + (p*sin(k*
pi*op))**2
593 xk(k, j) = sqrt(xk2(k, j))
594 kk(k, j) = nint((xk(k, j) - xmin)/dx) + 1
595 fpxk(k, j) = xk(k, j)*op/tanh(xk(k, j)*op)
596 IF (xk(k, j)*op <= 1.0e-10_dp) fpxk(k, j) = 1.0_dp
607 tmp = tmp + fpxk(k, j)*x2(j)/xk2(k, j)
610 fp1(j) = malpha*(h(j) - tmp) + (1.0_dp - malpha)*fp1(j)
611 IF (j <= n) err = err + abs(1.0_dp - fp1(j)/fprev)
616 CALL pint_qtb_linreg(fp1(8*nx/10:nx), x(8*nx/10:nx), aa, bb, r2, log_unit, print_level)
623 IF (kk(k, j) < nx)
THEN
624 fpxk(k, j) = fp1(kk(k, j)) + (fp1(kk(k, j) + 1) - fp1(kk(k, j)))/dx* &
625 (xk(k, j) - x(kk(k, j)))
627 fpxk(k, j) = aa*xk(k, j) + bb
635 WRITE (log_unit,
'(A,ES9.3)')
' # average error during computation: ', err
636 WRITE (log_unit,
'(A,ES9.3)')
' # slope of F_P at high freq. - theoretical: ', op
637 WRITE (log_unit,
'(A,ES9.3)')
' # slope of F_P at high freq. - calculated: ', aa
638 WRITE (log_unit,
'(A,F6.3)')
' # F_P at zero freq. - theoretical: ', 1.0_dp
639 WRITE (log_unit,
'(A,F6.3)')
' # F_P at zero freq. - calculated: ', fp1(1)
641 CALL pint_write_line(
"QTB| Initialization of random forces using fP0 function")
643 WRITE (line,
'(A,ES9.3)')
'QTB| average error ', err
645 WRITE (line,
'(A,ES9.3)')
'QTB| slope at high frequency - theoretical: ', op
647 WRITE (line,
'(A,ES9.3)')
'QTB| slope at high frequency - calculated: ', aa
649 WRITE (line,
'(A,F6.3)')
'QTB| value at zero frequency - theoretical: ', 1.0_dp
651 WRITE (line,
'(A,F6.3)')
'QTB| value at zero frequency - calculated: ', fp1(1)
657 WRITE (log_unit,
'(A)')
' # ------------------------------------------------'
658 WRITE (log_unit,
'(A)')
' # computed fp function'
659 WRITE (log_unit,
'(A)')
' # i, w(a.u.), x, fp'
661 WRITE (log_unit, *) j, j*dw, xmin + (j - 1)*dx, fp1(j)
678 k = nint((x1 - xmin)/dx) + 1
681 ELSE IF (k <= 0)
THEN
683 cpabort(
"Error in fp computation (x < xmin) in initialization of QTB random forces")
685 xx = xmin + (k - 1)*dx
687 fp(j) = fp1(k) + (fp1(k + 1) - fp1(k))/dx*(x1 - xx)
689 fp(j) = fp1(k) + (fp1(k) - fp1(k - 1))/dx*(x1 - xx)
696 END SUBROUTINE pint_qtb_computefp0
712 SUBROUTINE pint_qtb_computefp1(pint_env, fp, fp1, dw, aa, bb, log_unit, ibead, print_level)
713 TYPE(pint_env_type),
INTENT(IN) :: pint_env
714 REAL(kind=
dp),
DIMENSION(:),
INTENT(INOUT) :: fp
715 REAL(kind=
dp),
DIMENSION(:),
POINTER :: fp1
716 REAL(kind=
dp) :: dw, aa, bb
717 INTEGER,
INTENT(IN) :: log_unit, ibead, print_level
719 CHARACTER(len=200) :: line
720 INTEGER :: i, j, k, n, niter, nx, p
721 INTEGER,
ALLOCATABLE,
DIMENSION(:, :) :: kk
722 REAL(kind=
dp) :: dx, dx1, err, fprev, hbokt, malpha, op, &
723 op1, r2, tmp, tmp1, xmax, xmin, xx
724 REAL(kind=
dp),
ALLOCATABLE,
DIMENSION(:) :: h, x, x2
725 REAL(kind=
dp),
ALLOCATABLE,
DIMENSION(:, :) :: fpxk, xk, xk2
731 hbokt = 1.0_dp/(pint_env%kT*pint_env%propagator%temp_sim2phys)
741 dx1 = 0.5_dp*hbokt*dw
745 nx = int((xmax - xmin)/dx) + 1
756 WRITE (log_unit,
'(A)')
' # ------------------------------------------------'
757 WRITE (log_unit,
'(A)')
' # computing fp^(1) function'
758 WRITE (log_unit,
'(A)')
' # parameters used:'
759 WRITE (log_unit,
'(A,ES13.3)')
' # dx = ', dx
760 WRITE (log_unit,
'(A,ES13.3)')
' # xmin = ', xmin
761 WRITE (log_unit,
'(A,ES13.3)')
' # xmax = ', xmax
762 WRITE (log_unit,
'(A,I8,I8)')
' # nx, n = ', nx, n
769 ALLOCATE (xk(p - 1, nx))
770 ALLOCATE (xk2(p - 1, nx))
771 ALLOCATE (kk(p - 1, nx))
772 ALLOCATE (fpxk(p - 1, nx))
778 x(j) = xmin + (j - 1)*dx
780 h(j) = x(j)/tanh(x(j))
781 IF (x(j) <= 1.0e-10_dp) h(j) = 1.0_dp
782 fp1(j) = op1*x(j)/tanh(x(j)*op1)
783 IF (x(j)*op1 <= 1.0e-10_dp) fp1(j) = 1.0_dp
785 xk2(k, j) = x2(j) + (p*sin(k*
pi*op))**2
786 xk(k, j) = sqrt(xk2(k, j) - (p*sin(
pi*op))**2)
787 kk(k, j) = nint((xk(k, j) - xmin)/dx) + 1
788 fpxk(k, j) = xk(k, j)*op1/tanh(xk(k, j)*op1)
789 IF (xk(k, j)*op1 <= 1.0e-10_dp) fpxk(k, j) = 1.0_dp
800 tmp = tmp + fpxk(k, j)*x2(j)/xk2(k, j)
803 tmp1 = 1.0_dp + (p*sin(
pi*op)/x(j))**2
804 fp1(j) = malpha*tmp1*(h(j) - 1.0_dp - tmp) + (1.0_dp - malpha)*fp1(j)
805 IF (j <= n) err = err + abs(1.0_dp - fp1(j)/fprev)
810 CALL pint_qtb_linreg(fp1(8*nx/10:nx), x(8*nx/10:nx), aa, bb, r2, log_unit, print_level)
817 IF (kk(k, j) < nx)
THEN
818 fpxk(k, j) = fp1(kk(k, j)) + (fp1(kk(k, j) + 1) - fp1(kk(k, j)))/dx* &
819 (xk(k, j) - x(kk(k, j)))
821 fpxk(k, j) = aa*xk(k, j) + bb
829 WRITE (log_unit,
'(A,ES9.3)')
' # average error during computation: ', err
830 WRITE (log_unit,
'(A,ES9.3)')
' # slope of F_P at high freq. - theoretical: ', op1
831 WRITE (log_unit,
'(A,ES9.3)')
' # slope of F_P at high freq. - calculated: ', aa
833 CALL pint_write_line(
"QTB| Initialization of random forces using fP1 function")
835 WRITE (line,
'(A,ES9.3)')
'QTB| average error ', err
837 WRITE (line,
'(A,ES9.3)')
'QTB| slope at high frequency - theoretical: ', op1
839 WRITE (line,
'(A,ES9.3)')
'QTB| slope at high frequency - calculated: ', aa
845 WRITE (log_unit,
'(A)')
' # ------------------------------------------------'
846 WRITE (log_unit,
'(A)')
' # computed fp function'
847 WRITE (log_unit,
'(A)')
' # i, w(a.u.), x, fp'
849 WRITE (log_unit, *) j, j*dw, xmin + (j - 1)*dx, fp1(j)
864 tmp = (j*dx1)**2 - (p*sin(
pi*op))**2
869 k = nint((tmp - xmin)/dx) + 1
872 ELSE IF (k <= 0)
THEN
875 xx = xmin + (k - 1)*dx
877 fp(j) = fp1(k) + (fp1(k + 1) - fp1(k))/dx*(tmp - xx)
879 fp(j) = fp1(k) + (fp1(k) - fp1(k - 1))/dx*(tmp - xx)
887 END SUBROUTINE pint_qtb_computefp1
900 SUBROUTINE pint_qtb_linreg(y, x, a, b, r2, log_unit, print_level)
901 REAL(kind=
dp),
DIMENSION(:) :: y, x
902 REAL(kind=
dp) :: a, b, r2
903 INTEGER :: log_unit, print_level
905 CHARACTER(len=200) :: line
907 REAL(kind=
dp) :: xav, xvar, xycov, yav, yvar
920 xycov = xycov + x(i)*y(i)
921 xvar = xvar + x(i)**2
922 yvar = yvar + y(i)**2
928 xycov = xycov - xav*yav
937 r2 = xycov/sqrt(xvar*yvar)
939 IF (r2 < 0.9_dp)
THEN
941 WRITE (log_unit,
'(A, E10.3)')
'# possible error during linear regression: r^2 = ', r2
943 WRITE (line,
'(A,E10.3)')
'QTB| possible error during linear regression: r^2 = ', r2
948 END SUBROUTINE pint_qtb_linreg
957 SUBROUTINE pint_qtb_fft(z_in, z_out, plan, n)
960 TYPE(fft_plan_type) :: plan
961 COMPLEX(KIND=dp),
DIMENSION(n) :: z_out, z_in
966 CALL fft_1dm(plan, z_in, z_out, 1.d0, stat)
968 END SUBROUTINE pint_qtb_fft
Utility routines to open and close files. Tracking of preconnections.
subroutine, public open_file(file_name, file_status, file_form, file_action, file_position, file_pad, unit_number, debug, skip_get_unit_number, file_access)
Opens the requested file using a free unit number.
various routines to log and control the output. The idea is that decisions about where to log should ...
type(cp_logger_type) function, pointer, public cp_get_default_logger()
returns the default logger
routines to handle the output, The idea is to remove the decision of wheter to output and what to out...
integer, parameter, public debug_print_level
integer, parameter, public silent_print_level
subroutine, public fft_create_plan_1dm(plan, fft_type, fsign, trans, n, m, zin, zout, plan_style)
...
subroutine, public fft_destroy_plan(plan)
...
subroutine, public fft_1dm(plan, zin, zout, scale, stat)
...
Type to store data about a (1D or 3D) FFT, including FFTW plan.
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
Interface to the message passing library MPI.
Parallel (pseudo)random number generator (RNG) for multiple streams and substreams of random numbers.
type(rng_stream_type) function, public rng_stream_type_from_record(rng_record)
Create a RNG stream from a record given as an internal file (string).
integer, parameter, public rng_record_length
integer, parameter, public gaussian
I/O subroutines for pint_env.
subroutine, public pint_write_line(line)
Writes out a line of text to the default output unit.
Methods to apply the QTB thermostat to PI runs. Based on the PILE implementation from Felix Uhl (pint...
subroutine, public pint_qtb_step(vold, vnew, p, ndim, masses, qtb_therm)
...
subroutine, public pint_calc_qtb_energy(pint_env)
returns the qtb kinetic energy contribution
subroutine, public pint_qtb_release(qtb_therm)
releases the qtb environment
subroutine, public pint_qtb_init(qtb_therm, pint_env, normalmode_env, section)
initializes the data for a QTB run