diff --git a/src/common/bibliography.F b/src/common/bibliography.F index 2772e96736..c5752b2fa3 100644 --- a/src/common/bibliography.F +++ b/src/common/bibliography.F @@ -74,7 +74,9 @@ MODULE bibliography Khaliullin2007, Khaliullin2008, Merlot2014, Lin2009, Lin2013, & QUIP_ref, DelBen2015, Souza2002, Umari2002, Stengel2009, & Luber2014, Berghold2011, DelBen2015b, Campana2009, & - Schiffmann2015, Bruck2014, Rappe1992, Ceriotti2012, Ceriotti2010 + Schiffmann2015, Bruck2014, Rappe1992, Ceriotti2012, & + Ceriotti2010, Walewski2014 + CONTAINS @@ -2378,6 +2380,31 @@ CONTAINS "ER"),& DOI="10.1103/PhysRevB.87.041108") + CALL add_reference(key=Walewski2014, ISI_record=s2a(& + "PT J",& + "AU Walewski, L",& + " Forbert, H",& + " Marx, D",& + "AF Walewski, Lukasz",& + " Forbert, Harald",& + " Marx, Dominik",& + "TI Reactive path integral quantum simulations of molecules solvated in",& + " superfluid helium",& + "SO COMPUTER PHYSICS COMMUNICATIONS",& + "DE Cryochemistry; Superfluidity; Helium; Solvation; Path integrals",& + "NR 153",& + "SN 0010-4655",& + "PD MAR",& + "PY 2014",& + "VL 185",& + "IS 3",& + "BP 884",& + "EP 899",& + "DI 10.1016/j.cpc.2013.12.011",& + "UT WOS:000331919100022",& + "ER"),& + DOI="10.1016/j.cpc.2013.12.011") + CALL add_reference(key=Delben2013, ISI_record=s2a(& "PT J",& "AU Del Ben, M",& diff --git a/src/helium_common.F b/src/helium_common.F deleted file mode 100644 index e45ef3ac5d..0000000000 --- a/src/helium_common.F +++ /dev/null @@ -1,1581 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 - 2015 CP2K developers group ! -!-----------------------------------------------------------------------------! - -! ***************************************************************************** -!> \brief Independent helium subroutines shared by other modules -!> \author Lukasz Walewski -!> \date 2009-07-14 -!> \note Avoiding circular deps: do not USE any other helium_* modules here. -! ***************************************************************************** -MODULE helium_common - - USE helium_types, ONLY: he_mass,& - helium_solvent_type - USE input_constants, ONLY: helium_cell_shape_cube,& - helium_cell_shape_octahedron - USE kinds, ONLY: default_string_length,& - dp - USE parallel_rng_types, ONLY: next_random_number - USE physcon, ONLY: a_mass,& - angstrom,& - boltzmann,& - h_bar,& - kelvin - USE splines_methods, ONLY: spline_value - USE splines_types, ONLY: spline_data_p_type,& - spline_data_type -#include "./base/base_uses.f90" - - IMPLICIT NONE - - PRIVATE - - LOGICAL, PRIVATE, PARAMETER :: debug_this_module=.TRUE. - CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'helium_common' - - PUBLIC :: helium_pbc - PUBLIC :: helium_boxmean_3d - PUBLIC :: helium_calc_wnumber - PUBLIC :: helium_calc_rdf - PUBLIC :: helium_calc_rho - PUBLIC :: helium_calc_plength - PUBLIC :: helium_rotate - PUBLIC :: helium_eval_expansion - PUBLIC :: helium_update_transition_matrix - PUBLIC :: helium_spline - PUBLIC :: helium_cycle_number - PUBLIC :: helium_path_length - PUBLIC :: helium_is_winding - - CONTAINS - -! ***************************************************************************** -!> \brief General PBC routine for helium. -!> \param helium ... -!> \param r ... -!> \date 2009-09-30 -!> \author Lukasz Walewski -!> \note Check wheather PBC should be applied, if yes call low level -!> routine according to the unit cell shape. -! ***************************************************************************** - SUBROUTINE helium_pbc( helium, r ) - - TYPE(helium_solvent_type), POINTER :: helium - REAL(kind=dp), DIMENSION(3), & - INTENT(INOUT) :: r - - IF ( helium%cell_shape .EQ. helium_cell_shape_cube ) THEN - CALL helium_pbc_cube( helium, r ) - ELSE IF ( helium%cell_shape .EQ. helium_cell_shape_octahedron ) THEN - CALL helium_pbc_trocta_opt( helium, r ) - END IF - - END SUBROUTINE helium_pbc - -! ***************************************************************************** -!> \brief Wrap r back to the helium box (if helium box is periodic) -!> \param helium - helium environment for which to wrap -!> \param r - 3D vector to be wraped back to periodic box -!> \par History -!> 2009-10-02 renamed, originally was helium_box -!> 2009-10-02 redesigned so it is now called as a subroutine [lwalewski] -!> 2009-10-02 redesigned so it now gets/returns a 3D vector [lwalewski] -!> \author hforbert -! ***************************************************************************** - SUBROUTINE helium_pbc_cube( helium, r ) - - TYPE(helium_solvent_type), POINTER :: helium - REAL(kind=dp), DIMENSION(3), & - INTENT(INOUT) :: r - - REAL(kind=dp) :: s - -! x coordinate - - s = helium%cell_size_inv * r(1) - IF ( s > 0.5_dp ) THEN - s = s - INT(s+0.5_dp) - ELSEIF ( s < -0.5_dp ) THEN - s = s - INT(s-0.5_dp) - END IF - r(1) = s * helium%cell_size - - ! y coordinate - s = helium%cell_size_inv * r(2) - IF ( s > 0.5_dp ) THEN - s = s - INT(s+0.5_dp) - ELSEIF ( s < -0.5_dp ) THEN - s = s - INT(s-0.5_dp) - END IF - r(2) = s * helium%cell_size - - ! z coordinate - s = helium%cell_size_inv * r(3) - IF ( s > 0.5_dp ) THEN - s = s - INT(s+0.5_dp) - ELSEIF ( s < -0.5_dp ) THEN - s = s - INT(s-0.5_dp) - END IF - r(3) = s * helium%cell_size - - RETURN - END SUBROUTINE helium_pbc_cube - -! ***************************************************************************** -!> \brief Apply PBC within truncated octahedral unit cell. -!> \param helium ... -!> \param r ... -!> \date 2009-10-02 -!> \author Lukasz Walewski -!> \note Original Allen & Tildesley routine adapted for our helium code. -! ***************************************************************************** - SUBROUTINE helium_pbc_trocta( helium, r ) - - TYPE(helium_solvent_type), POINTER :: helium - REAL(kind=dp), DIMENSION(3), & - INTENT(INOUT) :: r - - REAL(kind=dp) :: corr, r75, rx, ry, rz - -! ** PERIODIC BOUNDARY CONDITIONS FOR A TRUNCATED OCTAHEDRON ** -! ** ** -! ** THE BOX IS CENTRED AT THE ORIGIN. THE AXES PASS THROUGH THE ** -! ** CENTRES OF THE SIX SQUARE FACES OF THE TRUNCATED OCTAHEDRON ** -! ** (SEE F1G. 1.10(A)). THE CONTAINING CUBE IS OF UNIT LENGTH ** - - PARAMETER ( r75 = 4.0_dp / 3.0_dp ) - - rx = r(1) * helium%cell_size_inv - ry = r(2) * helium%cell_size_inv - rz = r(3) * helium%cell_size_inv - - rx = rx - ANINT ( rx ) - ry = ry - ANINT ( ry ) - rz = rz - ANINT ( rz ) - corr = 0.5_dp * AINT ( r75 * ( ABS ( rx ) + ABS ( ry ) + ABS ( rz ) ) ) - rx = rx - SIGN ( corr, rx ) - ry = ry - SIGN ( corr, ry ) - rz = rz - SIGN ( corr, rz ) - - r(1) = rx * helium%cell_size - r(2) = ry * helium%cell_size - r(3) = rz * helium%cell_size - - RETURN - END SUBROUTINE helium_pbc_trocta - -! ***************************************************************************** -!> \brief Apply PBC within truncated octahedral unit cell. -!> \param helium ... -!> \param r ... -!> \date 2009-10-22 -!> \author hforbert -!> \note Version of the original Allen & Tildesley routine optimized for -!> g95 and intel compilers on x86-64. -! ***************************************************************************** - SUBROUTINE helium_pbc_trocta_opt( helium, r ) - - TYPE(helium_solvent_type), POINTER :: helium - REAL(kind=dp), DIMENSION(3), & - INTENT(INOUT) :: r - - REAL(kind=dp) :: cell_size, cell_size_inv, & - corr, rx, ry, rz, sx, sy, sz - - cell_size = helium%cell_size - cell_size_inv = helium%cell_size_inv - - rx = r(1) * cell_size_inv - IF ( rx > 0.5_dp ) THEN - rx = rx - INT(rx+0.5_dp) - ELSEIF ( rx < -0.5_dp ) THEN - rx = rx - INT(rx-0.5_dp) - END IF - - ry = r(2) * cell_size_inv - IF ( ry > 0.5_dp ) THEN - ry = ry - INT(ry+0.5_dp) - ELSEIF ( ry < -0.5_dp ) THEN - ry = ry - INT(ry-0.5_dp) - END IF - - rz = r(3) * cell_size_inv - IF ( rz > 0.5_dp ) THEN - rz = rz - INT(rz+0.5_dp) - ELSEIF ( rz < -0.5_dp ) THEN - rz = rz - INT(rz-0.5_dp) - END IF - - corr = 0.0_dp - IF ( rx > 0.0_dp ) THEN - corr = corr + rx - sx = 0.5_dp - ELSE - corr = corr - rx - sx = -0.5_dp - END IF - IF ( ry > 0.0_dp ) THEN - corr = corr + ry - sy = 0.5_dp - ELSE - corr = corr - ry - sy = -0.5_dp - END IF - IF ( rz > 0.0_dp ) THEN - corr = corr + rz - sz = 0.5_dp - ELSE - corr = corr - rz - sz = -0.5_dp - END IF - IF ( corr > 0.75_dp ) THEN - rx = rx - sx - ry = ry - sy - rz = rz - sz - END IF - - r(1) = rx * cell_size - r(2) = ry * cell_size - r(3) = rz * cell_size - - RETURN - END SUBROUTINE helium_pbc_trocta_opt - -! ***************************************************************************** -!> \brief Calculate the point equidistant from two other points a and b -!> within the helium box - 3D version -!> \param helium - helium environment for which -!> \param a vectors for which to find the mean within the He box -!> \param b vectors for which to find the mean within the He box -!> \param c ... -!> \par History -!> 2009-10-02 renamed, originally was helium_boxmean [lwalewski] -!> 2009-10-02 redesigned so it is now called as a subroutine [lwalewski] -!> 2009-10-02 redesigned so it now gets/returns a 3D vectors [lwalewski] -!> \author hforbert -! ***************************************************************************** - SUBROUTINE helium_boxmean_3d(helium, a, b, c) - - TYPE(helium_solvent_type), POINTER :: helium - REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: a, b - REAL(KIND=dp), DIMENSION(3), INTENT(OUT) :: c - - c(:) = b(:) - a(:) - CALL helium_pbc( helium, c ) - c(:) = a(:) + 0.5_dp * c(:) - CALL helium_pbc( helium, c ) - RETURN - END SUBROUTINE helium_boxmean_3d - -! *************************************************************************** -!> \brief Calculate the winding number for helium -!> \param helium ... -!> \par History -!> 2009-10-19 generalized for trunc. octahedron cell shape [lwalewski] -!> \author hforbert -! ***************************************************************************** - SUBROUTINE helium_calc_wnumber( helium ) - - TYPE(helium_solvent_type), POINTER :: helium - - CHARACTER(len=*), PARAMETER :: routineN = 'helium_calc_wnumber', & - routineP = moduleN//':'//routineN - - INTEGER :: ia, ib - REAL(KIND=dp) :: c, mHe, T - REAL(KIND=dp), DIMENSION(3) :: r, v, w - -!TODO combined with my standalone program - simpify the units -! h_bar - Planck constant over 2 pi in [J*s] -! boltzmann = 1.3806504e-23 - Boltzmann constant in [J/K] -! he_mass - 4He mass in [u] -! a_mass = 1.660538782e-27 - atomic mass unit in [kg] - - mHe = he_mass * a_mass ! 4He mass in [kg] - T = kelvin / helium%tau / helium%beads - c = 1e-20 * mHe / h_bar / h_bar * boltzmann * T / 3.0_dp / helium%atoms - - v(:) = 0.0_dp - ! iterate over all helium atoms - DO ia = 1, helium%atoms - ! contribution comming from the last and the first bead - r(:) = helium%pos(:,ia,helium%beads) - & - helium%pos(:,helium%permutation(ia),1) - CALL helium_pbc( helium, r ) - v(:) = v(:) + r(:) - ! sum of contributions from the rest of bead pairs - DO ib = 2, helium%beads - r(:) = helium%pos(:,ia,ib-1) - helium%pos(:,ia,ib) - CALL helium_pbc( helium, r ) - v(:) = v(:) + r(:) - END DO - END DO - - ! calc winding number (cell_m_inv is in Bohr^-1) - w(1) = & - helium%cell_m_inv(1,1) * v(1) + & - helium%cell_m_inv(1,2) * v(2) + & - helium%cell_m_inv(1,3) * v(3); - w(2) = & - helium%cell_m_inv(2,1) * v(1) + & - helium%cell_m_inv(2,2) * v(2) + & - helium%cell_m_inv(2,3) * v(3); - w(3) = & - helium%cell_m_inv(3,1) * v(1) + & - helium%cell_m_inv(3,2) * v(2) + & - helium%cell_m_inv(3,3) * v(3); - helium%wnumber_inst(:) = w(:) - - ! calc superfluid density - v(:) = angstrom * v(:) - helium%sdensity_inst = c * ( v(1)**2 + v(2)**2 + v(3)**2 ) - - RETURN - END SUBROUTINE helium_calc_wnumber - -! ***************************************************************************** -!> \brief Calculate helium radial distribution function wrt . -!> \param helium ... -!> \date 2009-07-22 -!> \author Lukasz Walewski -!> \note Actually calculate the histogram only, the normalization is -!> postponed to the postprocessing stage. -! ***************************************************************************** - SUBROUTINE helium_calc_rdf( helium) - - TYPE(helium_solvent_type), POINTER :: helium - - CHARACTER(len=*), PARAMETER :: routineN = 'helium_calc_rdf', & - routineP = moduleN//':'//routineN - - INTEGER :: bin, ia, ib - REAL(kind=dp) :: ri - REAL(kind=dp), DIMENSION(3) :: r, r0 - -! CALL timeset(routineN,handle) - - CPASSERT(ASSOCIATED(helium)) - - ! calculate the histogram of distances - helium%rdf_inst(:) = 0.0_dp - r0(:) = helium%origin(:) - DO ia = 1, helium%atoms - DO ib = 1, helium%beads - r(:) = helium%pos(:,ia,ib) - r0(:) - CALL helium_pbc( helium, r ) - ri = SQRT( r(1)*r(1) + r(2)*r(2) + r(3)*r(3) ) - bin = INT(ri/helium%rdf_delr) + 1 - IF (bin .LE. helium%rdf_nbin) THEN - helium%rdf_inst(bin) = helium%rdf_inst(bin) + 1.0_dp - END IF - END DO - END DO - - ! normalize the histogram to get g(r) - ! note: helium%density refers to the number of atoms, not the beads -! norm = 0.0_dp -! const = 4.0_dp * pi * helium%density / 3.0_dp -! rpart = REAL(helium%beads) -! DO bin = 1, helium%rdf_nbin -! rlower = REAL(bin-1) * helium%rdf_delr -! rupper = rlower + helium%rdf_delr -! nideal = const * (rupper**3 - rlower**3) -! helium%rdf_inst(bin) = helium%rdf_inst(bin) / rpart / nideal -! norm = norm + helium%rdf_inst(bin) -! END DO -! norm = norm * helium%rdf_delr - -! CALL timestop(handle) - - RETURN - END SUBROUTINE helium_calc_rdf - - -! ***************************************************************************** -!> \brief Calculate helium density distribution function wrt . -!> \param helium ... -!> \date 2011-06-14 -!> \author Lukasz Walewski -!> \note The calculated density is stored in the helium%rho_inst array. -!> \note This version of helium_calc_rho routine calculates only the total -!> He density but it implements the data structure that is already -!> suitable for the superfluid density estimator calculation -!> (full version still in the development branch) [lwalewski] -! ***************************************************************************** - SUBROUTINE helium_calc_rho( helium) - - TYPE(helium_solvent_type), POINTER :: helium - - CHARACTER(len=*), PARAMETER :: routineN = 'helium_calc_rho', & - routineP = moduleN//':'//routineN - - INTEGER :: bx, by, bz, handle, ia, ib, & - itmp - LOGICAL :: ltmp - REAL(kind=dp) :: c, delrinv - REAL(kind=dp), DIMENSION(3) :: r, r0 - - CALL timeset(routineN,handle) - - CPASSERT(ASSOCIATED(helium)) - - helium%rho_inst(:,:,:,:) = 0.0_dp - r0(:) = helium%origin(:) - delrinv = 1.0_dp / helium%rho_delr - c = 1.0_dp / helium%beads - - DO ia = 1, helium%atoms - - DO ib = 1, helium%beads - - r(:) = helium%pos(:,ia,ib) - r0(:) - CALL helium_pbc( helium, r ) - bx = FLOOR( r(1) * delrinv ) - helium%rho_minb + 1 - by = FLOOR( r(2) * delrinv ) - helium%rho_minb + 1 - bz = FLOOR( r(3) * delrinv ) - helium%rho_minb + 1 - - ! check that bin numbers are within bounds - itmp = helium%rho_nbin - ltmp = (0 .LT. bx) .AND. ( bx .LE. itmp ) - CPASSERT(ltmp) - ltmp = (0 .LT. by) .AND. ( by .LE. itmp ) - CPASSERT(ltmp) - ltmp = (0 .LT. bz) .AND. ( bz .LE. itmp ) - CPASSERT(ltmp) - - helium%rho_inst(1,bx,by,bz) = helium%rho_inst(1,bx,by,bz) + c - - END DO - END DO - - CALL timestop(handle) - - RETURN - END SUBROUTINE helium_calc_rho - - -! *************************************************************************** -!> \brief Calculate probability distribution of the permutation lengths -!> \param helium ... -!> \date 2010-06-07 -!> \author Lukasz Walewski -!> \note Valid permutation path length is an integer (1, NATOMS), number -!> of paths of a given length is calculated here and average over -!> inner loop iterations and helium environments is done in -!> helium_sample. -! ***************************************************************************** - SUBROUTINE helium_calc_plength( helium) - - TYPE(helium_solvent_type), POINTER :: helium - - CHARACTER(len=*), PARAMETER :: routineN = 'helium_calc_plength', & - routineP = moduleN//':'//routineN - - INTEGER :: i, j, k - - helium%plength_inst(:) = 0.0_dp - DO i = 1, helium%atoms - j = helium%permutation(i) - k = 1 - DO - IF (j == i) EXIT - k = k + 1 - j = helium%permutation(j) - END DO - helium%plength_inst(k) = helium%plength_inst(k) + 1 - END DO - helium%plength_inst(:) = helium%plength_inst(:) / helium%atoms - - RETURN - END SUBROUTINE helium_calc_plength - -! *************************************************************************** -!> \brief Rotate helium particles in imaginary time by nslices -!> \param helium ... -!> \param nslices ... -!> \author hforbert -!> \note Positions of helium beads in helium%pos array are reorganized such -!> that the indices are cyclically translated in a permutation-aware -!> manner. helium%relrot is given a new value that represents the new -!> 'angle' of the beads. This is done modulo helium%beads, so relrot -!> should be always within 0 (no rotation) and helium%beads-1 (almost -!> full rotation). [lwalewski] -! ***************************************************************************** - SUBROUTINE helium_rotate(helium, nslices) - TYPE(helium_solvent_type), POINTER :: helium - INTEGER, INTENT(IN) :: nslices - - CHARACTER(len=*), PARAMETER :: routineN = 'helium_rotate', & - routineP = moduleN//':'//routineN - - INTEGER :: b, i, j, k, n - - CPASSERT(ASSOCIATED(helium)) - - b = helium%beads - n = helium%atoms - i = MOD(nslices,b) - IF (i < 0) i = i + b - IF ((i>=b).OR.(i<1)) RETURN - helium%relrot = MOD(helium%relrot+i,b) - DO k = 1, i - helium%work(:,:,k) = helium%pos(:,:,k) - END DO - DO k = i+1, b - helium%pos(:,:,k-i) = helium%pos(:,:,k) - END DO - DO k = 1, i - DO j = 1, n - helium%pos(:,j,b-i+k) = helium%work(:,helium%permutation(j),k) - END DO - END DO - RETURN - END SUBROUTINE helium_rotate - -! ***************************************************************************** -!> \brief Calculate the pair-product action or energy by evaluating the -!> power series expansion according to Eq. 4.46 in Ceperley 1995. -!> \param helium ... -!> \param r ... -!> \param rp ... -!> \param tab ... -!> \param cut ... -!> \retval res ... -!> \author Harald Forbert -! ***************************************************************************** - FUNCTION helium_eval_expansion(helium,r,rp,tab,cut) RESULT(res) - - TYPE(helium_solvent_type), POINTER :: helium - REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: r, rp - TYPE(spline_data_p_type), & - DIMENSION(:, :), POINTER :: tab - INTEGER, INTENT(IN) :: cut - REAL(KIND=dp) :: res - - INTEGER :: i, j - REAL(KIND=dp) :: ar, arp, q, s, v, z - REAL(KIND=dp), DIMENSION(3) :: br, brp - - br(:) = r(:) - brp(:) = rp(:) - CALL helium_pbc(helium,br) - CALL helium_pbc(helium,brp) - - ar = SQRT(br(1)**2+br(2)**2+br(3)**2) - arp= SQRT(brp(1)**2+brp(2)**2+brp(3)**2) - q = 0.5_dp*(ar+arp) - - IF (helium%periodic .AND. ((ar > 0.5_dp*helium%cell_size)& - .OR.(arp > 0.5_dp*helium%cell_size))) THEN - v = 0.0_dp - IF (arp>0.5_dp*helium%cell_size) THEN - v = v + cut*helium_spline(tab(1,1)%spline_data,0.5_dp*helium%cell_size) - ELSE - v = v + helium_spline(tab(1,1)%spline_data,arp) - END IF - IF (ar>0.5_dp*helium%cell_size) THEN - v = v + cut*helium_spline(tab(1,1)%spline_data,0.5_dp*helium%cell_size) - ELSE - v = v + helium_spline(tab(1,1)%spline_data,ar) - END IF - res = 0.5_dp*v - ELSE - ! end-point action (first term): - v = 0.5_dp*(helium_spline(tab(1,1)%spline_data,ar)+helium_spline(tab(1,1)%spline_data,arp)) - DO i = 1, 3 - br(i) = br(i) - brp(i) - END DO - CALL helium_pbc( helium, br ) - s = br(1)**2+br(2)**2+br(3)**2 - z = (ar-arp)**2 - arp = 1.0_dp - ! j=0 terms - DO i = 2, SIZE(tab,1) - arp = arp * s - v = v + arp*helium_spline(tab(i,1)%spline_data,q) - END DO - ar = 1.0_dp - DO j = 2, SIZE(tab,2) - ar = ar * z - arp = ar - DO i = j, SIZE(tab,1) - v = v + arp*helium_spline(tab(i,j)%spline_data,q) - arp = arp * s - END DO - END DO - res = v - END IF - RETURN - END FUNCTION helium_eval_expansion - -! ***************************************************************************** -!> \brief ... -!> \param helium ... -! ***************************************************************************** - SUBROUTINE helium_update_transition_matrix(helium) - - TYPE(helium_solvent_type), POINTER :: helium - - INTEGER :: b, c, i, j, k, m, n, nb - INTEGER, ALLOCATABLE, DIMENSION(:) :: lens, order - INTEGER, DIMENSION(:), POINTER :: perm - INTEGER, DIMENSION(:, :), POINTER :: nmatrix - REAL(KIND=dp) :: f, q, t, v - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: p - REAL(KIND=dp), DIMENSION(3) :: r - REAL(KIND=dp), DIMENSION(:, :), POINTER :: ipmatrix, pmatrix, tmatrix - REAL(KIND=dp), DIMENSION(:, :, :), & - POINTER :: pos - - nb = helium%atoms - !TODO: check allocation status - ALLOCATE(p(2*nb)) - ALLOCATE(order(nb)) - ALLOCATE(lens(2*nb)) - b = helium%beads-helium%bisection+1 - f = -0.5_dp/(helium%hb2m*helium%tau*helium%bisection) - tmatrix => helium%tmatrix - pmatrix => helium%pmatrix - ipmatrix => helium%ipmatrix - nmatrix => helium%nmatrix - perm => helium%permutation - pos => helium%pos - DO i = 1, nb - DO j = 1, nb - v = 0.0_dp - r(:) = pos(:,i,b) - pos(:,j,1) - CALL helium_pbc( helium, r ) - v = v + r(1)*r(1) + r(2)*r(2) + r(3)*r(3) - pmatrix(i,j) = f*v - END DO - t = pmatrix(i,perm(i)) ! just some reference - v = 0.0_dp - DO j = 1, nb - tmatrix(i,j) = EXP(pmatrix(i,j)-t) - v = v + tmatrix(i,j) - END DO - ! normalize - q = t+LOG(v) - t = 1.0_dp/v - DO j = 1, nb - tmatrix(i,j) = tmatrix(i,j)*t - ipmatrix(i,j) = 1.0_dp/tmatrix(i,j) - END DO - - ! at this point we have: - ! tmatrix(i,j) = exp(-f*(r_i^b - r_j^1)**2) normalized such - ! that sum_j tmatrix(i,j) = 1. - ! ( tmatrix(k1,k2) = t_{k1,k2} / h_{k1} of ceperly. ) - ! so tmatrix(i,j) is the probability to try to change a permutation - ! with particle j (assuming particle i is already selected as well) - ! ipmatrix(i,j) = 1.0/tmatrix(i,j) - ! pmatrix(i,j) = log(tmatrix(i,j)) + some_offset(i) - - ! generate optimal search tree so we can select which particle j - ! belongs to a given random_number as fast as possible. - ! (the traditional approach would be to generate a table - ! of cumulative probabilities and to search that table) - ! so for example if we have: - ! tmatrix(i,:) = ( 0.1 , 0.4 , 0.2 , 0.3 ) - ! traditionally we would build the running sum table: - ! ( 0.1 , 0.5 , 0.7 , 1.0 ) and for a random number r - ! would search this table for the lowest index larger than r - ! (which would then be the particle index chosen by this random number) - ! we build an optimal binary search tree instead, so here - ! we would have: - ! if ( r > 0.6 ) then take index 2, - ! else if ( r > 0.3 ) then take index 4, - ! else if ( r > 0.1 ) then take index 3 else index 1. - ! the search tree is generated in tmatrix and nmatrix. - ! tmatrix contains the decision values (0.6,0.3,0.1 in this case) - ! and nmatrix contains the two branches (what to do if lower or higher) - ! negative numbers in nmatrix mean take minus that index - ! positive number means go down the tree to that next node, since we - ! put the root of the tree at the end the arrays in the example would - ! look like this: - ! tmatrix(i,:) = ( 0.1 , 0.3 , 0.6 , arbitrary ) - ! namtrix(i,:) = ( -1 , -3 , 1 , -4 , 2 , -2 , arb. , arb. ) - ! - ! the way to generate this tree may not be the best, but the - ! tree generation itself shouldn't be needed quite that often: - ! - ! first sort values (with some variant of heap sort) - - DO j = 1, nb - order(j)=j - p(j) = tmatrix(i,j) - END DO - IF (nb > 1) THEN ! if nb = 1 it is already sorted. - k = nb/2+1 - c = nb - DO - IF (k > 1) THEN - ! building up the heap: - k = k - 1 - n = order(k) - v = p(k) - ELSE - ! removing the top of the heap - n = order(c) - v = p(c) - order(c)=order(1) - p(c)=p(1) - c = c - 1 - IF (c == 1) THEN - order(1)=n - p(1)=v - EXIT - END IF - END IF - m = k - j = 2*k - ! restoring heap order between k and c - DO - IF (j > c) EXIT - IF (j < c) THEN - IF (p(j)= p(j)) EXIT - order(m) = order(j) - p(m) = p(j) - m = j - j = 2*j - END DO - order(m) = n - p(m) = v - END DO - END IF - - ! now: - ! p(1:nb) : tmatrix(i,1:nb) sorted in ascending order - ! order(1:nb) : corresponding index: p(j) == tmatrix(i,order(j)) - ! for all j - - ! merge sort with elements as we generate new interior search nodes - ! by combining older elements/nodes - - ! first fill unused part of array with guard values: - DO j = nb+1, 2*nb - p(j)=2.0_dp - END DO - - ! j - head of leaf queue - ! c+1 - head of node queue in p (c in lens) - ! m+1 - tail of node queue in p (m in lens) - c = nb+1 - j = 1 - DO m = nb+1, 2*nb-1 - ! get next smallest element - IF (p(j) < p(c+1)) THEN - v = p(j) - lens(j) = m - j = j + 1 - ELSE - v = p(c+1) - lens(c) = m - c = c + 1 - END IF - ! get the second next smallest element - IF (p(j) < p(c+1)) THEN - p(m+1) = v+p(j) - lens(j) = m - j = j + 1 - ELSE - p(m+1) = v+p(c+1) - lens(c) = m - c = c + 1 - END IF - END DO - - ! lens(:) now has the tree with lens(j) pointing to its parent - ! the root of the tree is at 2*nb-1 - ! calculate the depth of each node in the tree now: (root = 0) - - lens(2*nb-1) = 0 - DO m = 2*nb-2, 1, -1 - lens(m) = lens(lens(m))+1 - END DO - - ! lens(:) now has the depths of the nodes/leafs - -#if 0 - ! calculate average search depth (for information only) - v = 0.0_dp - DO j = 1, nb - v = v + p(j)*lens(j) - END DO - PRINT *,"Expected number of comparisons with i=",i,v -#endif - - ! reset the nodes, for the canonical tree we just need the leaf info - DO j = 1, nb - lens(j+nb)=0 - p(j+nb) = 0.0_dp - END DO - - ! build the canonical tree (number of decisions on average are - ! the same to the tree we build above, but it has better caching behavior - - ! c head of leafs - ! m head of interior nodes - c = 1 - m = nb+1 - DO k = 1, 2*nb-2 - j = nb+1+(k-1)/2 - IF (lens(c)>lens(m+1)) THEN - nmatrix(i,k) = -order(c) - lens(j+1) = lens(c)-1 - v = p(c) - c = c + 1 - ELSE - nmatrix(i,k) = m-nb - lens(j+1) = lens(m+1)-1 - v = p(m) - m = m + 1 - END IF - p(j) = p(j) + v - IF (MOD(k,2)==1) tmatrix(i,j-nb)=v - END DO - - ! now: - ! nmatrix(i,2*j+1) left child of node j - ! nmatrix(i,2*j+2) right child of node j - ! children: - ! negative : leaf with particle index == abs(value) - ! positive : child node index - ! p(j) weight of leaf j - ! p(nb+j) weight of node j - ! tmatrix(i,j) weight of left child of node j - - ! fix offsets for decision tree: - - p(nb-1)=0.0_dp - DO m = nb-1,1,-1 - ! if right child is a node, set its offset and - ! change its decision value - IF (nmatrix(i,2*m)>0) THEN - p(nmatrix(i,2*m)) = tmatrix(i,m) - tmatrix(i,nmatrix(i,2*m)) = tmatrix(i,nmatrix(i,2*m))+tmatrix(i,m) - END IF - ! if left child is a node, set its offset and - ! change its decision value - IF (nmatrix(i,2*m-1)>0) THEN - p(nmatrix(i,2*m-1)) = p(m) - tmatrix(i,nmatrix(i,2*m-1)) = tmatrix(i,nmatrix(i,2*m-1)) + p(m) - END IF - END DO - - ! canonical optimal search tree done - -#if 0 - !some test code, to check if it gives the right distribution - DO k = 1, nb - p(k)=1.0/ipmatrix(i,k) - END DO - lens(:)=0 - ! number of random numbers to generate: - c = 1000000000 - DO j=1, c - v = next_random_number(helium%rng_stream_uniform) - ! walk down the search tree: - k = nb-1 - DO - IF (tmatrix(i,k) > v) THEN - k = nmatrix(i,2*k-1) - ELSE - k = nmatrix(i,2*k) - END IF - IF (k<0) EXIT - END DO - k = -k - ! increment the counter for this particle index - lens(k) = lens(k)+1 - END DO - ! search for maximum deviation from expectation value - ! (relative to the expected variance) - v = 0.0_dp - k = -1 - DO j = 1, nb - q = ABS((lens(j)-c*p(j))/SQRT(c*p(j))) - !PRINT *,j,lens(j),c*p(j) - IF (q > v) THEN - v = q - k = j - END IF - !PRINT *,lens(j),c*p(j),(lens(j)-c*p(j))/sqrt(c*p(j)) - END DO - PRINT *,"MAXDEV:",k,lens(k),c*p(k),v - !PRINT *,"TMAT:",tmatrix(i,:) - !PRINT *,"NMAT:",nmatrix(i,:) - !STOP -#endif -#if 0 - !additional test code: - p(:) = -1.0_dp - p(nb-1) = 0.0_dp - p(2*nb-1) = 1.0_dp - DO j = nb-1, 1, -1 - ! right child - IF (nmatrix(i,2*j) > 0) THEN - c = nmatrix(i,2*j) - p(c) = tmatrix(i,j) - p(c+nb) = p(j+nb) - ELSE - c = -nmatrix(i,2*j) - !PRINT *,c,1.0/ipmatrix(i,c),p(j+nb)-tmatrix(i,j) - IF (ABS(1.0/ipmatrix(i,c)-(p(j+nb)-tmatrix(i,j))) > & - 10.0_dp*EPSILON(1.0_dp)) THEN - PRINT *,"Probability mismatch for particle i->j",i,c - PRINT *,"Got",p(j+nb)-tmatrix(i,j),"should be",1.0/ipmatrix(i,c) - CPABORT("") - END IF - END IF - ! left child - IF (nmatrix(i,2*j-1) > 0) THEN - c = nmatrix(i,2*j-1) - p(c+nb) = tmatrix(i,j) - p(c) = p(j) - ELSE - c = -nmatrix(i,2*j-1) - !PRINT *,c,1.0/ipmatrix(i,c),tmatrix(i,j)-p(j) - IF (ABS(1.0/ipmatrix(i,c)-(tmatrix(i,j)-p(j))) > & - 10.0_dp*EPSILON(1.0_dp)) THEN - PRINT *,"Probability mismatch for particle i->j",i,c - PRINT *,"Got",tmatrix(i,j)-p(j),"should be",1.0/ipmatrix(i,c) - CPABORT("") - END IF - END IF - END DO - PRINT *,"Probabilities ok" -#endif - - END DO - - ! initialize trial permutation with some identity permutation - ! (should not be taken, but just in case it does we have something valid) - - helium%pweight = 0.0_dp - t = next_random_number(helium%rng_stream_uniform) - helium%ptable(1) = 1+INT(t*nb) - helium%ptable(2) = -1 - - ! recalculate inverse permutation table (just in case) - DO i = 1, nb - helium%iperm(perm(i))=i - END DO - - ! clean up: - DEALLOCATE(lens) - DEALLOCATE(order) - DEALLOCATE(p) - - RETURN -END SUBROUTINE helium_update_transition_matrix - -! ***************************************************************************** -!> \brief ... -!> \param spl ... -!> \param xx ... -!> \retval res ... -! ***************************************************************************** - FUNCTION helium_spline(spl, xx) RESULT(res) - TYPE(spline_data_type), POINTER :: spl - REAL(KIND=dp), INTENT(IN) :: xx - REAL(KIND=dp) :: res - - REAL(KIND=dp) :: a, b - - IF (xx < spl%x1) THEN - b = spl%invh*(xx-spl%x1) - a = 1.0_dp-b - res = a*spl%y(1)+b*(spl%y(2)-spl%y2(2)*spl%h26) - ELSE IF (xx > spl%xn) THEN - b = spl%invh*(xx-spl%xn)+1.0_dp - a = 1.0_dp-b - res = b*spl%y(spl%n)+a*(spl%y(spl%n-1)-spl%y2(spl%n-1)*spl%h26) - ELSE - res = spline_value(spl,xx) - END IF - RETURN - END FUNCTION helium_spline - -! ***************************************************************************** -!> \brief ... -!> \param spl ... -!> \param xx ... -!> \retval res ... -! ***************************************************************************** - FUNCTION helium_spline_1(spl, xx) RESULT(res) - TYPE(spline_data_type), POINTER :: spl - REAL(KIND=dp), INTENT(IN) :: xx - REAL(KIND=dp) :: res - - REAL(KIND=dp) :: dummy - - IF (xx < spl%x1) THEN - res = spl%invh*(spl%y(2)-spl%y(1)-spl%y2(2)*spl%h26) - ELSE IF (xx > spl%xn) THEN - res = spl%invh*(spl%y(spl%n)-spl%y(spl%n-1)+spl%y2(spl%n-1)*spl%h26) - ELSE - dummy = spline_value(spl,xx,res) - END IF - RETURN - END FUNCTION helium_spline_1 - -! ***************************************************************************** -!> \brief Return the distance between bead of atom -!> and bead of atom . -!> \param helium ... -!> \param ia ... -!> \param ib ... -!> \param ja ... -!> \param jb ... -!> \retval rij ... -!> \date 2009-07-17 -!> \author Lukasz Walewski -! ***************************************************************************** - FUNCTION helium_bead_rij(helium, ia, ib, ja, jb) RESULT(rij) - - TYPE(helium_solvent_type), POINTER :: helium - INTEGER, INTENT(IN) :: ia, ib, ja, jb - REAL(kind=dp) :: rij - - REAL(kind=dp) :: dx, dy, dz - - dx = helium%pos(1,ia,ib) - helium%pos(1,ja,jb) - dy = helium%pos(2,ia,ib) - helium%pos(2,ja,jb) - dz = helium%pos(3,ia,ib) - helium%pos(3,ja,jb) - rij = SQRT(dx*dx+dy*dy+dz*dz) - - RETURN - END FUNCTION helium_bead_rij - -! ***************************************************************************** -!> \brief Given the atom number and permutation state return the cycle -!> number the atom belongs to. -!> \param helium ... -!> \param atom_number ... -!> \param permutation ... -!> \retval cycle_number ... -!> \date 2009-07-21 -!> \author Lukasz Walewski -!> \note Cycles (or paths) are numbered from 1 to , where -!> is in the range of (1, ). -!> if (num_cycles .EQ. 1) then all atoms belong to one cycle -!> if (num_cycles .EQ. helium%atoms) then there are no cycles of -!> length greater than 1 (i.e. no atoms are connected) -! ***************************************************************************** - FUNCTION helium_cycle_number(helium, atom_number, permutation) RESULT(cycle_number) - - TYPE(helium_solvent_type), POINTER :: helium - INTEGER, INTENT(IN) :: atom_number - INTEGER, DIMENSION(:), POINTER :: permutation - INTEGER :: cycle_number - - INTEGER :: atom_idx, cycle_idx, & - cycle_num, ia, ib, ic, & - num_cycles - INTEGER, DIMENSION(:), POINTER :: cycle_index - LOGICAL :: break, new_cycle - - NULLIFY(cycle_index) - cycle_index => helium%itmp_atoms_1d - cycle_index(:) = 0 - - num_cycles = 0 - break = .FALSE. - DO ia = 1, helium%atoms - ! this loop reaches its maximum iteration count when atom in question - ! is the last one (i.e. when atom_number .EQ. helium%atoms) - - ! exit if we have found the cycle number for the atom in question - IF (break) THEN - EXIT - END IF - - ! initialize current cycle index with the current atom - cycle_idx = ia - - atom_idx = ia - DO ib = 1, helium%atoms * helium%beads - ! this loop reaches its maximum iteration count when all He atoms - ! form one cycle (i.e. all beads belong to one path) - - ! proceed along the path - atom_idx = permutation(atom_idx) - - IF (atom_idx .EQ. ia) THEN - ! end of cycle detected (looped back to the first atom) - - ! check if this is a new cycle - new_cycle = .TRUE. - DO ic = 1, num_cycles - IF (cycle_index(ic) .EQ. cycle_idx) THEN - new_cycle = .FALSE. - END IF - END DO - - IF (new_cycle) THEN - ! increase number of cycles and update the current cycle's index - num_cycles = num_cycles + 1 - cycle_index(num_cycles) = cycle_idx - END IF - - ! if this was the atom in question - IF (ia .EQ. atom_number) THEN - ! save the cycle index it belongs to - cycle_num = cycle_idx - - ! exit the loop over atoms, we've found what we've been looking for - break = .TRUE. - END IF - - ! exit the loop over beads, there are no more (new) beads in this cycle - EXIT - END IF - - ! set the cycle index to the lowest atom index in this cycle - IF (atom_idx .LT. cycle_idx) THEN - cycle_idx = atom_idx - END IF - - END DO - - END DO - ! at this point we know the cycle index for atom - ! but it is expressed as the atom number of the first atom in that cycle - - ! renumber cycle indices, so that they form a range (1, ) - ! (don't do it actually - just return the requested ) - cycle_number = 0 - DO ic = 1, num_cycles - IF (cycle_index(ic) .EQ. cycle_num) THEN - cycle_number = ic - EXIT - END IF - END DO - - NULLIFY(cycle_index) - - RETURN - END FUNCTION helium_cycle_number - -! ***************************************************************************** -!> \brief Given the atom number and permutation state return the cycle -!> number the atom belongs to. -!> \param helium ... -!> \param permutation ... -!> \retval num_cycles ... -!> \date 2009-07-21 -!> \author Lukasz Walewski -!> \note Cycles (or paths) are numbered from 1 to , where -!> is in the range of (1, ). -!> if (num_cycles .EQ. 1) then all atoms belong to one cycle -!> if (num_cycles .EQ. helium%atoms) then there are no cycles of -!> length greater than 1 (i.e. no atoms are connected) -! ***************************************************************************** - FUNCTION helium_ncycles(helium, permutation) RESULT(num_cycles) - - TYPE(helium_solvent_type), POINTER :: helium - INTEGER, DIMENSION(:), POINTER :: permutation - INTEGER :: num_cycles - - INTEGER :: clen, curr_idx, cycle_idx, & - ia, ia2, ib, ic, prev_idx - INTEGER, DIMENSION(:), POINTER :: cycle_index, cycle_length - LOGICAL :: new_cycle - REAL(KIND=dp), DIMENSION(128, 3) :: cycle_w - REAL(KIND=dp), DIMENSION(3) :: r, v - - NULLIFY(cycle_index) - cycle_index => helium%itmp_atoms_1d - cycle_index(:) = 0 - - NULLIFY(cycle_length) - cycle_length => helium%itmp_atoms_np_1d - cycle_length(:) = 0 - - num_cycles = 0 - DO ia = 1, helium%atoms - - ! initialize current cycle index with the current atom - cycle_idx = ia - - curr_idx = ia - clen = 0 - v(:) = 0.0_dp - DO ia2 = 1, helium%atoms - - ! calc winding number contribution from the current atom - ! contribution comming from the last and the first bead - r(:) = helium%pos(:,curr_idx,helium%beads) - & - helium%pos(:,helium%permutation(curr_idx),1) - CALL helium_pbc( helium, r ) - v(:) = v(:) + r(:) - ! sum of contributions from the rest of bead pairs - DO ib = 2, helium%beads - r(:) = helium%pos(:,curr_idx,ib-1) - helium%pos(:,curr_idx,ib) - CALL helium_pbc( helium, r ) - v(:) = v(:) + r(:) - END DO - - clen = clen + 1 - - ! proceed along the path - prev_idx = curr_idx - curr_idx = permutation(curr_idx) - - IF (curr_idx .EQ. ia) THEN - ! end of cycle detected (looped back to the first atom) - - ! check if this is a new cycle - new_cycle = .TRUE. - DO ic = 1, num_cycles - IF (cycle_index(ic) .EQ. cycle_idx) THEN - new_cycle = .FALSE. - END IF - END DO - - IF (new_cycle) THEN - ! increase number of cycles and update the current cycle's index - num_cycles = num_cycles + 1 - cycle_index(num_cycles) = cycle_idx - cycle_length(num_cycles) = clen - - ! calc winding number (cell_m_inv is in Bohr^-1) - cycle_w(num_cycles,1) = & - helium%cell_m_inv(1,1) * v(1) + & - helium%cell_m_inv(1,2) * v(2) + & - helium%cell_m_inv(1,3) * v(3); - cycle_w(num_cycles,2) = & - helium%cell_m_inv(2,1) * v(1) + & - helium%cell_m_inv(2,2) * v(2) + & - helium%cell_m_inv(2,3) * v(3); - cycle_w(num_cycles,3) = & - helium%cell_m_inv(3,1) * v(1) + & - helium%cell_m_inv(3,2) * v(2) + & - helium%cell_m_inv(3,3) * v(3); - END IF - - ! exit the loop over beads, there are no more (new) beads in this cycle - EXIT - END IF - - ! set the cycle index to the lowest atom index in this cycle - IF (curr_idx .LT. cycle_idx) THEN - cycle_idx = curr_idx - END IF - - END DO - - END DO - -!do ic = 1, num_cycles -! print *, ic, cycle_index(ic), cycle_length(ic), cycle_w(ic,:) -!end do - - cycle_index(:) = 0 - NULLIFY(cycle_index) - - cycle_length(:) = 0 - NULLIFY(cycle_length) - - RETURN - END FUNCTION helium_ncycles - - -! *************************************************************************** -!> \brief Given the atom number and permutation state return the length of -!> the path this atom belongs to. -!> \param helium ... -!> \param atom_number ... -!> \param permutation ... -!> \retval path_length ... -!> \date 2009-10-07 -!> \author Lukasz Walewski -! ***************************************************************************** - FUNCTION helium_path_length(helium, atom_number, permutation) RESULT(path_length) - - TYPE(helium_solvent_type), POINTER :: helium - INTEGER, INTENT(IN) :: atom_number - INTEGER, DIMENSION(:), POINTER :: permutation - INTEGER :: path_length - - INTEGER :: atom_idx, ia - LOGICAL :: path_end_reached - - atom_idx = atom_number - path_length = 0 - path_end_reached = .FALSE. - DO ia = 1, helium%atoms - path_length = path_length + 1 - atom_idx = permutation(atom_idx) - IF ( atom_idx .EQ. atom_number ) THEN - path_end_reached = .TRUE. - EXIT - END IF - END DO - - IF ( .NOT. path_end_reached ) THEN - path_length = -1 - END IF - - RETURN - END FUNCTION helium_path_length - -! *************************************************************************** -!> \brief Given the atom number and permutation state returns .TRUE. if the -!> atom belongs to the winding path, .FASLE. otherwise. -!> \param helium ... -!> \param atom_number ... -!> \param pos ... -!> \param permutation ... -!> \retval is_winding ... -!> \date 2010-09-21 -!> \author Lukasz Walewski -!> \note The path winds around the periodic box if it's widing number is -!> \note greater than 0. This function calculates the winding number of the -!> \note path the atom in question belongs to by following the permutation -!> \note cycle; it exits from the path if the starting atom number is -!> \note reached again. -! ***************************************************************************** - FUNCTION helium_is_winding(helium, atom_number, pos, permutation) RESULT(is_winding) - - TYPE(helium_solvent_type), POINTER :: helium - INTEGER, INTENT(IN) :: atom_number - REAL(kind=dp), DIMENSION(:, :, :), & - POINTER :: pos - INTEGER, DIMENSION(:), POINTER :: permutation - LOGICAL :: is_winding - - CHARACTER(len=*), PARAMETER :: routineN = 'helium_is_winding', & - routineP = moduleN//':'//routineN - - CHARACTER(len=default_string_length) :: err_str, stmp - INTEGER :: atom_idx, ia, ib, path_length - LOGICAL :: path_end_reached - REAL(KIND=dp), DIMENSION(3) :: r, v, w - - is_winding = .FALSE. - v(:) = 0.0_dp - atom_idx = atom_number - path_length = 0 - path_end_reached = .FALSE. - ! traverse the path the given atom belongs to - DO ia = 1, helium%atoms - ! contribution comming from the last and the first bead - r(:) = pos(:,atom_idx,helium%beads) - & - pos(:,permutation(atom_idx),1) - CALL helium_pbc( helium, r ) - v(:) = v(:) + r(:) - ! sum of contributions from the rest of bead pairs - DO ib = 2, helium%beads - r(:) = pos(:,atom_idx,ib-1) - pos(:,atom_idx,ib) - CALL helium_pbc( helium, r ) - v(:) = v(:) + r(:) - END DO - ! jump to the next atom along the path - path_length = path_length + 1 - atom_idx = permutation(atom_idx) - IF ( atom_idx .EQ. atom_number ) THEN - path_end_reached = .TRUE. - EXIT - END IF - END DO - - stmp = "" - WRITE(stmp,*) atom_number - err_str = "Permutation path of atom " // TRIM(ADJUSTL(stmp)) // & - " is not cyclic." - IF(.NOT.path_end_reached)& - CPABORT(err_str) - - ! calc winding number (cell_m_inv is in Bohr^-1) - w(1) = & - helium%cell_m_inv(1,1) * v(1) + & - helium%cell_m_inv(1,2) * v(2) + & - helium%cell_m_inv(1,3) * v(3); - w(2) = & - helium%cell_m_inv(2,1) * v(1) + & - helium%cell_m_inv(2,2) * v(2) + & - helium%cell_m_inv(2,3) * v(3); - w(3) = & - helium%cell_m_inv(3,1) * v(1) + & - helium%cell_m_inv(3,2) * v(2) + & - helium%cell_m_inv(3,3) * v(3); - - IF ( w(1)*w(1)+w(2)*w(2)+w(3)*w(3) .GT. 0.5_dp ) THEN - is_winding = .TRUE. - END IF - - RETURN - END FUNCTION helium_is_winding - -! *************************************************************************** -!> \brief Given the atom number and permutation state returns the -!> contribution of this atom to the total superfluid density W^2/n. -!> W^2 - squared winding number of the path the atom belongs to -!> n - number of atoms that belong to this path -!> \param helium ... -!> \param atom_number ... -!> \retval res ... -!> \date 2011-06-16 -!> \author Lukasz Walewski -! ***************************************************************************** - FUNCTION helium_sdensity_part(helium, atom_number) RESULT(res) - - TYPE(helium_solvent_type), POINTER :: helium - INTEGER, INTENT(IN) :: atom_number - REAL(KIND=dp) :: res - - CHARACTER(len=*), PARAMETER :: routineN = 'helium_sdensity_part', & - routineP = moduleN//':'//routineN - - CHARACTER(len=default_string_length) :: err_str, stmp - INTEGER :: atom_idx, ia, ib, path_length - LOGICAL :: path_end_reached - REAL(KIND=dp) :: wsq - REAL(KIND=dp), DIMENSION(3) :: r, v, w - - v(:) = 0.0_dp - atom_idx = atom_number - path_length = 0 - path_end_reached = .FALSE. - ! traverse the path given atom belongs to - DO ia = 1, helium%atoms - ! contribution comming from the last and the first bead - r(:) = helium%pos(:,atom_idx,helium%beads) - & - helium%pos(:,helium%permutation(atom_idx),1) - CALL helium_pbc( helium, r ) - v(:) = v(:) + r(:) - ! sum of contributions from the rest of bead pairs - DO ib = 2, helium%beads - r(:) = helium%pos(:,atom_idx,ib-1) - helium%pos(:,atom_idx,ib) - CALL helium_pbc( helium, r ) - v(:) = v(:) + r(:) - END DO - ! jump to the next atom along the path - path_length = path_length + 1 - atom_idx = helium%permutation(atom_idx) - IF ( atom_idx .EQ. atom_number ) THEN - path_end_reached = .TRUE. - EXIT - END IF - END DO - - stmp = "" - WRITE(stmp,*) atom_number - err_str = "Permutation path of atom " // TRIM(ADJUSTL(stmp)) // & - " is not cyclic." - IF(.NOT.path_end_reached)& - CPABORT(err_str) - - ! calc winding number (cell_m_inv is in Bohr^-1) - w(1) = & - helium%cell_m_inv(1,1) * v(1) + & - helium%cell_m_inv(1,2) * v(2) + & - helium%cell_m_inv(1,3) * v(3); - w(2) = & - helium%cell_m_inv(2,1) * v(1) + & - helium%cell_m_inv(2,2) * v(2) + & - helium%cell_m_inv(2,3) * v(3); - w(3) = & - helium%cell_m_inv(3,1) * v(1) + & - helium%cell_m_inv(3,2) * v(2) + & - helium%cell_m_inv(3,3) * v(3); - - wsq = w(1)*w(1)+w(2)*w(2)+w(3)*w(3) - IF ( ABS(wsq) .LT. EPSILON(0.0_dp) ) wsq = 0.0_dp - - res = wsq / path_length - - RETURN - END FUNCTION helium_sdensity_part - - -! *************************************************************************** -!> \brief Given the permutation state assign cycle lengths to all He atoms. -!> \param helium ... -!> \date 2011-07-06 -!> \author Lukasz Walewski -!> \note The helium%atom_plength array is filled with cycle lengths, -!> each atom gets the length of the permutation cycle it belongs to. -! ***************************************************************************** - SUBROUTINE helium_calc_atom_cycle_length( helium) - - TYPE(helium_solvent_type), POINTER :: helium - - CHARACTER(len=*), PARAMETER :: & - routineN = 'helium_calc_atom_cycle_length', & - routineP = moduleN//':'//routineN - - INTEGER :: clen, curr_idx, handle, ia, & - start_idx - INTEGER, DIMENSION(:), POINTER :: atoms_in_cycle - LOGICAL :: atoms_left, path_end_reached - LOGICAL, DIMENSION(:), POINTER :: atom_was_used - - CALL timeset(routineN,handle) - - NULLIFY(atoms_in_cycle) - atoms_in_cycle => helium%itmp_atoms_1d - atoms_in_cycle(:) = 0 - - NULLIFY(atom_was_used) - atom_was_used => helium%ltmp_atoms_1d - atom_was_used(:) = .FALSE. - - helium%atom_plength(:) = 0 - - start_idx = 1 - DO - clen = 0 - path_end_reached = .FALSE. - curr_idx = start_idx - DO ia = 1, helium%atoms - clen = clen + 1 - atoms_in_cycle(clen) = curr_idx - atom_was_used(curr_idx) = .TRUE. - - ! follow to the next atom in the cycle - curr_idx = helium%permutation(curr_idx) - IF ( curr_idx .EQ. start_idx ) THEN - path_end_reached = .TRUE. - EXIT - END IF - END DO - IF(.NOT.path_end_reached)& - CPABORT("Permutation path is not cyclic.") - - ! assign the cycle length to the collected atoms - DO ia = 1, clen - helium%atom_plength(atoms_in_cycle(ia)) = clen - END DO - - ! go to the next "unused" atom - atoms_left = .FALSE. - DO ia = 1, helium%atoms - IF ( .NOT. atom_was_used(ia) ) THEN - start_idx = ia - atoms_left = .TRUE. - EXIT - END IF - END DO - - IF (.NOT. atoms_left) EXIT - END DO - - atoms_in_cycle(:) = 0 - NULLIFY(atoms_in_cycle) - atom_was_used(:) = .FALSE. - NULLIFY(atom_was_used) - - CALL timestop(handle) - - RETURN - END SUBROUTINE helium_calc_atom_cycle_length - - -END MODULE helium_common diff --git a/src/helium_io.F b/src/helium_io.F deleted file mode 100644 index 5978d31ed6..0000000000 --- a/src/helium_io.F +++ /dev/null @@ -1,1200 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 - 2015 CP2K developers group ! -!-----------------------------------------------------------------------------! - -! ***************************************************************************** -!> \brief I/O subroutines for helium -!> \author Lukasz Walewski -!> \date 2009-06-08 -! ***************************************************************************** -MODULE helium_io - - USE cell_types, ONLY: get_cell - USE cp_log_handling, ONLY: cp_get_default_logger,& - cp_logger_get_default_unit_nr,& - cp_logger_type - USE cp_output_handling, ONLY: cp_p_file,& - cp_print_key_finished_output,& - cp_print_key_should_output,& - cp_print_key_unit_nr - USE cp_units, ONLY: cp_unit_from_cp2k - USE helium_common, ONLY: helium_cycle_number,& - helium_is_winding,& - helium_path_length,& - helium_pbc - USE helium_types, ONLY: e_id_interact,& - e_id_kinetic,& - e_id_potential,& - e_id_thermo,& - e_id_total,& - e_id_virial,& - helium_solvent_type - USE input_constants, ONLY: helium_cell_shape_cube,& - helium_cell_shape_octahedron - USE input_section_types, ONLY: section_vals_get_subs_vals,& - section_vals_type - USE kinds, ONLY: default_string_length,& - dp,& - int_8 - USE machine, ONLY: m_flush - USE message_passing, ONLY: mp_gather,& - mp_sum -#include "./base/base_uses.f90" - - IMPLICIT NONE - - PRIVATE - - LOGICAL, PRIVATE, PARAMETER :: debug_this_module = .TRUE. - CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'helium_io' - - PUBLIC :: helium_write_rdf - PUBLIC :: helium_write_rho - PUBLIC :: helium_write_line - PUBLIC :: helium_write_setup - PUBLIC :: helium_write_energy - PUBLIC :: helium_write_sdensity - PUBLIC :: helium_write_wnumber - PUBLIC :: helium_write_plength - PUBLIC :: helium_write_coordinates - PUBLIC :: helium_write_force - PUBLIC :: helium_write_accepts - PUBLIC :: helium_write_perm - - CONTAINS - - -! *************************************************************************** -!> \brief Write helium parameters to the output unit. -!> \param helium ... -!> \date 2009-06-03 -!> \author Lukasz Walewski -! ***************************************************************************** - SUBROUTINE helium_write_setup( helium) - - TYPE(helium_solvent_type), POINTER :: helium - - CHARACTER(len=*), PARAMETER :: routineN = 'helium_write_setup', & - routineP = moduleN//':'//routineN - - CHARACTER(len=default_string_length) :: my_label, stmp, stmp1, stmp2, & - unit_str - INTEGER :: i, itmp, j, unit_nr - INTEGER(kind=int_8) :: i8tmp - LOGICAL :: first - REAL(kind=dp) :: rtmp, v1, v2, v3 - REAL(kind=dp), DIMENSION(3) :: my_abc - TYPE(cp_logger_type), POINTER :: logger - - CPASSERT(ASSOCIATED(helium)) - - NULLIFY(logger) - logger => cp_get_default_logger() - my_label = "HELIUM| " - - IF (logger%para_env%ionode) THEN - unit_nr = cp_logger_get_default_unit_nr(logger) - - WRITE(unit_nr,*) - WRITE(unit_nr,'(T2,A,1X,I0)') TRIM(my_label)//& - " Number of helium environments: ", helium%num_env - - WRITE(unit_nr,'(T2,A,1X,I0)') TRIM(my_label)//& - " Number of solvent atoms: ", helium%atoms - WRITE(unit_nr,'(T2,A,1X,I0)') TRIM(my_label)//& - " Number of solvent beads: ", helium%beads - WRITE(unit_nr,'(T2,A,1X,I0)') TRIM(my_label)//& - " Total number of solvent particles: ", helium%atoms*helium%beads - - unit_str = "angstrom^-3" - rtmp = cp_unit_from_cp2k(helium%density, & - unit_str) - WRITE(unit_nr,'(T2,A,F12.6)') TRIM(my_label)//" Density ["// & - TRIM(unit_str)//"]:", rtmp - - unit_str = "angstrom" - rtmp = cp_unit_from_cp2k(helium%cell_size, & - unit_str) - WRITE(unit_nr,'(T2,A,F12.6)') TRIM(my_label)//" Cell size ["// & - TRIM(unit_str)//"]: ", rtmp - - IF ( helium%periodic ) THEN - IF ( helium%cell_shape .EQ. helium_cell_shape_cube ) THEN - CALL helium_write_line("PBC cell shape: CUBE.") - ELSE IF ( helium%cell_shape .EQ. helium_cell_shape_octahedron ) THEN - CALL helium_write_line("PBC cell shape: TRUNCATED OCTAHEDRON.") - ELSE - CALL helium_write_line("*** Warning: unknown cell shape.") - END IF - ELSE - CALL helium_write_line("PBC turned off.") - END IF - - ! first step gets incremented during first iteration - WRITE(unit_nr,'(T2,A,1X,I0)') TRIM(my_label)//& - " First MC step :", helium%first_step + 1 - WRITE(unit_nr,'(T2,A,1X,I0)') TRIM(my_label)//& - " Last MC step :", helium%last_step - WRITE(unit_nr,'(T2,A,1X,I0)') TRIM(my_label)//& - " Total number of MC steps :", helium%num_steps - WRITE(unit_nr,'(T2,A,1X,I0)') TRIM(my_label)//& - " Number of outer MC trials per step :", helium%iter_rot - WRITE(unit_nr,'(T2,A,1X,I0)') TRIM(my_label)//& - " Number of inner MC trials per step :", helium%iter_norot - i8tmp = helium%iter_rot - i8tmp = i8tmp * helium%iter_norot - stmp = "" - WRITE(stmp, *) i8tmp - WRITE(unit_nr,'(T2,A)') TRIM(my_label)//& - " Total number of MC trials per step : " // TRIM(ADJUSTL(stmp)) - i8tmp = helium%num_steps - i8tmp = i8tmp * helium%iter_rot - i8tmp = i8tmp * helium%iter_norot - stmp = "" - WRITE(stmp, *) i8tmp - WRITE(unit_nr,'(T2,A)') TRIM(my_label) //& - " Total number of MC trials : " // TRIM(ADJUSTL(stmp)) - - ! permutation cycle length sampling - stmp = "" - CALL helium_write_line(stmp) - WRITE(stmp,*) helium%maxcycle - stmp2 = "" - WRITE(stmp2,*) "Using maximum permutation cycle length: " //& - TRIM(ADJUSTL(stmp)) - CALL helium_write_line(stmp2) - stmp = "" - stmp1 = "" - WRITE(stmp1,*) helium%m_ratio - stmp2 = "" - WRITE(stmp2,*) helium%m_value - WRITE(stmp,*) "Using ratio " // TRIM(ADJUSTL(stmp1)) // " for M = " // TRIM(ADJUSTL(stmp2)) - CALL helium_write_line(stmp) - stmp = "" - CALL helium_write_line(stmp) - - IF (helium%solute_present) THEN - WRITE(unit_nr,'(T2,A,1X,I0)') TRIM(my_label)//& - " Number of solute atoms: ", helium%solute_atoms - WRITE(unit_nr,'(T2,A,1X,I0)') TRIM(my_label)//& - " Number of solute beads: ", helium%solute_beads - WRITE(unit_nr,'(T2,A,1X,I0)') TRIM(my_label)//& - " Total number of solute particles: ", helium%solute_atoms*& - helium%solute_beads - DO i = 1, 3 - WRITE(unit_nr,'(T2,A,1X,I0,A,I0,A)', ADVANCE='NO') TRIM(my_label)//& - " Solute atom type: ", i,& - "(",helium%solute_number(i),")" - first = .TRUE. - DO j = 1, helium%solute_number(i) - IF (first) THEN - WRITE(unit_nr,'(A)', ADVANCE='NO')", indices: " - first = .FALSE. - ELSE - WRITE(unit_nr,'(A)', ADVANCE='NO') ", " - END IF - WRITE(unit_nr,'(I0)', ADVANCE='NO') helium%solute_index(i,j) - END DO - WRITE(unit_nr,'(1X)') - END DO - CALL get_cell(helium%solute_cell, abc=my_abc) - unit_str = "angstrom" - v1 = cp_unit_from_cp2k(my_abc(1), unit_str) - v2 = cp_unit_from_cp2k(my_abc(2), unit_str) - v3 = cp_unit_from_cp2k(my_abc(3), unit_str) - WRITE(unit_nr,'(T2,A,F12.6,1X,F12.6,1X,F12.6)') & - TRIM(my_label)//" Solute cell size ["// & - TRIM(unit_str)//"]: ", v1, v2, v3 - ELSE - WRITE(unit_nr,'(T2,A)') TRIM(my_label)//" Solute is NOT present" - END IF - END IF - - ! radial distribution function related settings - rtmp = cp_unit_from_cp2k(helium%rdf_delr, "angstrom") - WRITE(stmp, '(1X,F12.6)') rtmp - CALL helium_write_line("RDF| delr [angstrom]: "//TRIM(stmp)) - rtmp = cp_unit_from_cp2k(helium%rdf_maxr, "angstrom") - WRITE(stmp, '(1X,F12.6)') rtmp - CALL helium_write_line("RDF| maxr [angstrom]: "//TRIM(stmp)) - itmp = helium%rdf_nbin - WRITE(stmp, '(I6)') itmp - CALL helium_write_line("RDF| nbin : "//TRIM(stmp)) - - CALL helium_write_line("") - - ! density related - IF (helium%rho_present) THEN - CALL helium_write_line("RHO| Calculating densities on the grid") - itmp = helium%rho_nbin - stmp = "" - WRITE(stmp, '(I6)') itmp - CALL helium_write_line("RHO| "//TRIM(ADJUSTL(stmp))//"x"//& - TRIM(ADJUSTL(stmp))//"x"//TRIM(ADJUSTL(stmp))) - CALL helium_write_line("") - END IF - - RETURN - END SUBROUTINE helium_write_setup - -! *************************************************************************** -!> \brief Writes out a line of text to the default output unit. -!> \param line ... -!> \date 2009-07-10 -!> \author Lukasz Walewski -! ***************************************************************************** - SUBROUTINE helium_write_line(line) - - CHARACTER(len=*), INTENT(IN) :: line - - CHARACTER(len=*), PARAMETER :: routineN = 'helium_write_line', & - routineP = moduleN//':'//routineN - - CHARACTER(len=default_string_length) :: my_label - INTEGER :: unit_nr - TYPE(cp_logger_type), POINTER :: logger - - NULLIFY(logger) - logger => cp_get_default_logger() - my_label = "HELIUM|" - - IF (logger%para_env%ionode) THEN - unit_nr = cp_logger_get_default_unit_nr(logger) - WRITE(unit_nr,'(T2,A)') TRIM(my_label)//" "//TRIM(line) - END IF - - RETURN - END SUBROUTINE helium_write_line - -! *************************************************************************** -!> \brief Writes out helium energies according to HELIUM%PRINT%ENERGY -!> \param helium ... -!> \date 2009-06-08 -!> \author Lukasz Walewski -! ***************************************************************************** - SUBROUTINE helium_write_energy( helium) - - TYPE(helium_solvent_type), POINTER :: helium - - CHARACTER(len=*), PARAMETER :: routineN = 'helium_write_energy', & - routineP = moduleN//':'//routineN - - INTEGER :: handle, iteration, m, unit_nr - LOGICAL :: file_is_new - REAL(kind=dp) :: naccptd - REAL(kind=dp), DIMENSION(:), POINTER :: my_energy - TYPE(cp_logger_type), POINTER :: logger - TYPE(section_vals_type), POINTER :: print_key - - CALL timeset(routineN,handle) - - CPASSERT(ASSOCIATED(helium)) - CPASSERT(ASSOCIATED(helium%input)) - - my_energy => helium%energy_avrg - - NULLIFY(print_key,logger) - print_key => section_vals_get_subs_vals(helium%input, & - "MOTION%PINT%HELIUM%PRINT%ENERGY") - logger => cp_get_default_logger() - iteration = logger%iter_info%iteration(2) - IF ( BTEST(cp_print_key_should_output(iteration_info=logger%iter_info,& - basis_section=print_key),cp_p_file) ) THEN - unit_nr=cp_print_key_unit_nr(logger,print_key, & - middle_name="helium-energy",extension=".dat",& - is_new_file=file_is_new) - ! cp_print_key_unit_nr returns -1 on nodes other than logger%para_env%ionode - - naccptd = 0.0_dp - DO m = 1, helium%maxcycle - naccptd = naccptd + helium%num_accepted(helium%bisctlog2+2,m) - END DO - CALL mp_sum(naccptd,logger%para_env%group) - naccptd = naccptd / REAL(logger%para_env%num_pe,dp) - - IF (unit_nr>0) THEN - - IF ( file_is_new ) THEN - WRITE(unit_nr,'(A9,1X,A12,6(1X,A20))')& - "# Step",& - " Naccptd",& - " E_pot",& - " E_kin",& - " E_thermo",& - " E_virial",& - " E_inter",& - " E_tot" - END IF - - WRITE (unit_nr,"(I9,1X,F12.1,6(1X,F20.9))") & - iteration, & - naccptd,& - my_energy(e_id_potential), & - my_energy(e_id_kinetic), & - my_energy(e_id_thermo), & - my_energy(e_id_virial), & - my_energy(e_id_interact), & - my_energy(e_id_total) - CALL m_flush(unit_nr) - END IF - CALL cp_print_key_finished_output(unit_nr,logger,print_key) - END IF - - CALL timestop(handle) - RETURN - END SUBROUTINE helium_write_energy - -! *************************************************************************** -!> \brief Writes out helium energies according to HELIUM%PRINT%SDENSITY -!> \param helium ... -!> \date 2010-06-15 -!> \author Lukasz Walewski -! ***************************************************************************** - SUBROUTINE helium_write_sdensity( helium) - - TYPE(helium_solvent_type), POINTER :: helium - - CHARACTER(len=*), PARAMETER :: routineN = 'helium_write_sdensity', & - routineP = moduleN//':'//routineN - - INTEGER :: handle, iteration, unit_nr - TYPE(cp_logger_type), POINTER :: logger - TYPE(section_vals_type), POINTER :: print_key - - CALL timeset(routineN,handle) - - CPASSERT(ASSOCIATED(helium)) - CPASSERT(ASSOCIATED(helium%input)) - - NULLIFY(print_key,logger) - print_key => section_vals_get_subs_vals(helium%input, & - "MOTION%PINT%HELIUM%PRINT%SDENSITY") - logger => cp_get_default_logger() - iteration = logger%iter_info%iteration(2) - IF ( BTEST(cp_print_key_should_output(iteration_info=logger%iter_info,& - basis_section=print_key),cp_p_file) ) THEN - unit_nr=cp_print_key_unit_nr(logger,print_key, & - middle_name="helium-sdensity",extension=".dat") - IF (unit_nr>0) THEN - WRITE (unit_nr,"(F20.9)") helium%sdensity_avrg - CALL m_flush(unit_nr) - END IF - CALL cp_print_key_finished_output(unit_nr,logger,print_key) - END IF - - CALL timestop(handle) - RETURN - END SUBROUTINE helium_write_sdensity - -! *************************************************************************** -!> \brief Writes out helium winding number according to HELIUM%PRINT%WNUMBER -!> \param helium ... -!> \date 2009-10-19 -!> \par History -!> 2010-06-15 output W for each He environment/processor [lwalewski] -!> \author Lukasz Walewski -! ***************************************************************************** - SUBROUTINE helium_write_wnumber( helium) - - TYPE(helium_solvent_type), POINTER :: helium - - CHARACTER(len=*), PARAMETER :: routineN = 'helium_write_wnumber', & - routineP = moduleN//':'//routineN - - INTEGER :: handle, i, unit_nr - TYPE(cp_logger_type), POINTER :: logger - TYPE(section_vals_type), POINTER :: print_key - - CALL timeset(routineN,handle) - - CPASSERT(ASSOCIATED(helium)) - CPASSERT(ASSOCIATED(helium%input)) - - NULLIFY(print_key,logger) - print_key => section_vals_get_subs_vals(helium%input, & - "MOTION%PINT%HELIUM%PRINT%WNUMBER") - logger => cp_get_default_logger() - IF ( BTEST(cp_print_key_should_output(iteration_info=logger%iter_info,& - basis_section=print_key),cp_p_file) ) THEN - unit_nr=cp_print_key_unit_nr(logger,print_key, & - middle_name="helium-wnumber",extension=".dat") - - ! gather winding number from all processors to logger%para_env%source - helium%rtmp_3_np_1d(:) = 0 - CALL mp_gather( helium%wnumber_avrg, & - helium%rtmp_3_np_1d, & - logger%para_env%source, logger%para_env%group ) - - IF (unit_nr>0) THEN - - DO i = 1, 3 * helium%num_env - WRITE(unit_nr,'(F20.9)',ADVANCE='NO') helium%rtmp_3_np_1d(i) - IF ( i .LT. 3 * helium%num_env ) THEN - WRITE(unit_nr,'(1X)',ADVANCE='NO') - END IF - END DO - WRITE(unit_nr, '(A)') "" - - CALL m_flush(unit_nr) - END IF - CALL cp_print_key_finished_output(unit_nr,logger,print_key) - END IF - - CALL timestop(handle) - RETURN - END SUBROUTINE helium_write_wnumber - -! *************************************************************************** -!> \brief Writes out acceptance counts according to HELIUM%PRINT%ACCEPTS -!> \param helium ... -!> \date 2010-05-27 -!> \author Lukasz Walewski -! ***************************************************************************** - SUBROUTINE helium_write_accepts( helium) - - TYPE(helium_solvent_type), POINTER :: helium - - CHARACTER(len=*), PARAMETER :: routineN = 'helium_write_accepts', & - routineP = moduleN//':'//routineN - - INTEGER :: handle, i, iteration, j, & - unit_nr - LOGICAL :: file_is_new - TYPE(cp_logger_type), POINTER :: logger - TYPE(section_vals_type), POINTER :: print_key - - CALL timeset(routineN,handle) - - CPASSERT(ASSOCIATED(helium)) - CPASSERT(ASSOCIATED(helium%input)) - - NULLIFY(print_key,logger) - print_key => section_vals_get_subs_vals(helium%input, & - "MOTION%PINT%HELIUM%PRINT%ACCEPTS") - logger => cp_get_default_logger() - iteration = logger%iter_info%iteration(2) - IF ( BTEST(cp_print_key_should_output(iteration_info=logger%iter_info,& - basis_section=print_key),cp_p_file) ) THEN - unit_nr=cp_print_key_unit_nr(logger,print_key, & - middle_name="helium-accepts",extension=".dat",& - is_new_file=file_is_new) - IF (unit_nr>0) THEN - - IF ( file_is_new ) THEN - WRITE(unit_nr,'(A8,1X,A15,1X,A20)',ADVANCE='NO')& - "# Length",& - " Trials",& - " Selected" - DO j = 1, helium%bisctlog2 - WRITE(unit_nr,'(A17,1X,I3)',ADVANCE='NO') " Level", j - END DO - WRITE(unit_nr, '(A)') "" - END IF - - DO i = 1, helium%maxcycle - WRITE(unit_nr, '(I3)',ADVANCE='NO') i - DO j = 1, helium%bisctlog2 + 2 - WRITE(unit_nr,'(1X,F20.2)',ADVANCE='NO') helium%num_accepted(j,i) - END DO - WRITE(unit_nr, '(A)') "" - END DO - WRITE(unit_nr, '(A)') "&" - - CALL m_flush(unit_nr) - END IF - CALL cp_print_key_finished_output(unit_nr,logger,print_key) - END IF - - CALL timestop(handle) - RETURN - END SUBROUTINE helium_write_accepts - -! *************************************************************************** -!> \brief Writes out permutation state according to HELIUM%PRINT%PERM -!> \param helium ... -!> \date 2010-06-07 -!> \author Lukasz Walewski -! ***************************************************************************** - SUBROUTINE helium_write_perm( helium) - - TYPE(helium_solvent_type), POINTER :: helium - - CHARACTER(len=*), PARAMETER :: routineN = 'helium_write_perm', & - routineP = moduleN//':'//routineN - - INTEGER :: handle, i, iteration, j, & - offset, unit_nr - LOGICAL :: file_is_new - TYPE(cp_logger_type), POINTER :: logger - TYPE(section_vals_type), POINTER :: print_key - - CALL timeset(routineN,handle) - - CPASSERT(ASSOCIATED(helium)) - CPASSERT(ASSOCIATED(helium%input)) - - NULLIFY(print_key,logger) - print_key => section_vals_get_subs_vals(helium%input, & - "MOTION%PINT%HELIUM%PRINT%PERM") - logger => cp_get_default_logger() - iteration = logger%iter_info%iteration(2) - IF ( BTEST(cp_print_key_should_output(iteration_info=logger%iter_info,& - basis_section=print_key),cp_p_file) ) THEN - unit_nr=cp_print_key_unit_nr(logger,print_key, & - middle_name="helium-perm",extension=".dat",& - is_new_file=file_is_new) - - ! gather permutation state from all processors to logger%para_env%source - helium%itmp_atoms_np_1d(:) = 0 - CALL mp_gather( helium%permutation, & - helium%itmp_atoms_np_1d, & - logger%para_env%source, logger%para_env%group ) - - IF (unit_nr>0) THEN - - DO i = 1, helium%atoms - DO j = 1, helium%num_env - offset = (j-1) * helium%atoms - WRITE(unit_nr,'(I6)',ADVANCE='NO') helium%itmp_atoms_np_1d(offset+i) - IF ( j .LT. helium%num_env ) THEN - WRITE(unit_nr,'(1X)',ADVANCE='NO') - END IF - END DO - WRITE(unit_nr, '(A)') "" - END DO - WRITE(unit_nr, '(A)') "&" - - CALL m_flush(unit_nr) - END IF - CALL cp_print_key_finished_output(unit_nr,logger,print_key) - END IF - - CALL timestop(handle) - RETURN - END SUBROUTINE helium_write_perm - -! *************************************************************************** -!> \brief Writes helium configuration according to HELIUM%PRINT%COORDINATES -!> \param helium ... -!> \date 2009-07-16 -!> \par History -!> 2010-02-15 output from all processors added [lwalewski] -!> \author Lukasz Walewski -!> \note particle_types->write_particle_coordinates is of no use here, -!> since it does not support atom connectivity information needed -!> for helium paths -! ***************************************************************************** - SUBROUTINE helium_write_coordinates( helium) - - TYPE(helium_solvent_type), POINTER :: helium - - CHARACTER(len=*), PARAMETER :: routineN = 'helium_write_coordinates', & - routineP = moduleN//':'//routineN - - CHARACTER(3) :: resName - CHARACTER(len=default_string_length) :: fmt_string, my_middle_name, & - stmp - INTEGER :: handle, ia, ib, ib1, ib2, ic, & - icycle, irank, msglen, & - offset, tmp1, tmp2, unit_nr - INTEGER, DIMENSION(:), POINTER :: my_perm - LOGICAL :: are_connected, is_winding, & - ltmp, should_output - REAL(kind=dp) :: xtmp, ytmp, ztmp - REAL(kind=dp), DIMENSION(3) :: r0, r1, r2 - TYPE(cp_logger_type), POINTER :: logger - TYPE(section_vals_type), POINTER :: print_key - - CALL timeset(routineN,handle) - - CPASSERT(ASSOCIATED(helium)) - - NULLIFY(logger,print_key) - logger => cp_get_default_logger() - - ! decide whether to write anything or not - print_key => section_vals_get_subs_vals(helium%input, & - "MOTION%PINT%HELIUM%PRINT%COORDINATES") - should_output = BTEST(cp_print_key_should_output( & - iteration_info=logger%iter_info,& - basis_section=print_key),cp_p_file) - IF ( .NOT. should_output ) THEN - CALL timestop(handle) - RETURN - END IF - - ! prepare the coordinates for output (print one image of the periodic - ! space that is centered around r0) - r0(:) = helium%origin(:) - DO ia = 1, helium%atoms - DO ib = 1, helium%beads - r1(:) = helium%pos(:,ia,ib) - r0(:) - r2(:) = helium%pos(:,ia,ib) - r0(:) - CALL helium_pbc( helium, r2 ) - ltmp = .FALSE. - DO ic = 1, 3 - IF ( ABS(r1(ic)-r2(ic)) .GT. 100.0_dp*EPSILON(0.0_dp) ) THEN - ltmp = .TRUE. - CYCLE - END IF - END DO - IF ( ltmp ) THEN - helium%work(:,ia,ib) = r0(:) + r2(:) - ELSE - helium%work(:,ia,ib) = helium%pos(:,ia,ib) - END IF - END DO - END DO - - ! gather positions from all processors to logger%para_env%source - helium%rtmp_3_atoms_beads_1d(:) = PACK( helium%work, .TRUE. ) - CALL mp_gather( helium%rtmp_3_atoms_beads_1d, & - helium%rtmp_3_atoms_beads_np_1d, & - logger%para_env%source, logger%para_env%group ) - - ! gather permutation state from all processors to logger%para_env%source - CALL mp_gather( helium%permutation, & - helium%itmp_atoms_np_1d, & - logger%para_env%source, logger%para_env%group ) - - ! set logical mask for unpacking coordinates gathered from other ranks - helium%ltmp_3_atoms_beads_3d(:,:,:) = .TRUE. - - ! I/O only on the ionode - IF (logger%para_env%ionode) THEN - - ! iterate over processors/helium environments - DO irank = 1, helium%num_env - - ! generate one file per processor - stmp = "" - WRITE(stmp,*) irank - my_middle_name = "helium-pos-" // TRIM(ADJUSTL(stmp)) - unit_nr=cp_print_key_unit_nr( logger, print_key, & - middle_name=TRIM(my_middle_name), extension=".pdb") - - ! write out the unit cell parameters - fmt_string = "(A6,3F9.3,3F7.2,1X,A11,1X,I3)" - xtmp = helium%cell_size - xtmp = cp_unit_from_cp2k(xtmp, "angstrom") - IF ( helium%cell_shape .EQ. helium_cell_shape_octahedron ) THEN - stmp = "O " - ELSE - stmp = "C " - END IF - WRITE(unit_nr,fmt_string) "CRYST1", & - xtmp, xtmp, xtmp, & - 90.0_dp, 90.0_dp, 90.0_dp, & - stmp, helium%beads - - ! unpack coordinates - msglen = SIZE(helium%rtmp_3_atoms_beads_1d) - offset = (irank-1) * msglen - helium%work(:,:,:) = & - UNPACK(helium%rtmp_3_atoms_beads_np_1d(offset+1:offset+msglen), & - MASK=helium%ltmp_3_atoms_beads_3d, FIELD=0.0_dp ) - - ! unpack permutation state (actually point to the right section only) - msglen = SIZE(helium%permutation) - offset = (irank-1) * msglen - my_perm => helium%itmp_atoms_np_1d(offset+1:offset+msglen) - - ! write out coordinates - fmt_string = & - "(A6,I5,1X,A4,A1,A3,1X,A1,I4,A1,3X,3F8.3,2F6.2,10X,A2,A2)" - DO ia = 1, helium%atoms - icycle = helium_cycle_number(helium, ia, my_perm) - is_winding = helium_is_winding(helium,ia,helium%work,my_perm) - IF ( is_winding ) THEN - resName = "SPR" - ELSE - resName = "NRM" - END IF - DO ib = 1, helium%beads - xtmp = helium%work(1,ia,ib) - xtmp = cp_unit_from_cp2k(xtmp, "angstrom") - ytmp = helium%work(2,ia,ib) - ytmp = cp_unit_from_cp2k(ytmp, "angstrom") - ztmp = helium%work(3,ia,ib) - ztmp = cp_unit_from_cp2k(ztmp, "angstrom") - WRITE(unit_nr,fmt_string) "ATOM ", & - (ia-1)*helium%beads+ib, & - " He ", " ", resName, "X", & - icycle, & - " ", & - xtmp, ytmp, ztmp, & - 1.0_dp, 0.0_dp, "HE", " " - END DO - END DO - - ! write out the bead connectivity information - DO ia = 1, helium%atoms - - ! write connectivity records for this atom only if the path - ! it belongs to is longer than 1. - IF ( helium_path_length(helium, ia, my_perm) .LE. 1 ) THEN - CYCLE - END IF - - DO ib = 1, helium%beads-1 - ! check wheather the consecutive beads belong to the same box - r1(:) = helium%work(:,ia,ib) - helium%work(:,ia,ib+1) - r2(:) = r1(:) - CALL helium_pbc( helium, r2 ) - are_connected = .TRUE. - DO ic = 1, 3 - IF ( ABS(r1(ic)-r2(ic)) .GT. 100.0_dp*EPSILON(0.0_dp) ) THEN - ! if the distance betw ib and ib+1 changes upon applying - ! PBC do not connect them - are_connected = .FALSE. - CYCLE - END IF - END DO - IF ( are_connected ) THEN - tmp1 = (ia-1)*helium%beads+ib - tmp2 = (ia-1)*helium%beads+ib+1 - ! smaller value has to go first - IF (tmp1 .LT. tmp2) THEN - ib1 = tmp1 - ib2 = tmp2 - ELSE - ib1 = tmp2 - ib2 = tmp1 - END IF - WRITE(unit_nr,'(A6,2I5)') "CONECT", ib1, ib2 - END IF - END DO - - ! last bead of atom connects to the first bead - ! of the next atom in the permutation cycle - r1(:) = helium%work(:,ia,helium%beads) - helium%work(:,my_perm(ia),1) - r2(:) = r1(:) - CALL helium_pbc( helium, r2 ) - are_connected = .TRUE. - DO ic = 1, 3 - IF ( ABS(r1(ic)-r2(ic)) .GT. 100.0_dp*EPSILON(0.0_dp) ) THEN - ! if the distance betw ib and ib+1 changes upon applying - ! PBC do not connect them - are_connected = .FALSE. - CYCLE - END IF - END DO - IF ( are_connected ) THEN - tmp1 = ia*helium%beads - tmp2 = (my_perm(ia)-1)*helium%beads+1 - IF (tmp1 .LT. tmp2) THEN - ib1 = tmp1 - ib2 = tmp2 - ELSE - ib1 = tmp2 - ib2 = tmp1 - END IF - WRITE(unit_nr,'(A6,2I5)') "CONECT", ib1, ib2 - END IF - END DO - WRITE(unit_nr,'(A)') "END" - - CALL m_flush(unit_nr) - CALL cp_print_key_finished_output(unit_nr,logger,print_key) - - END DO - - END IF - - CALL timestop(handle) - RETURN - END SUBROUTINE helium_write_coordinates - -! *************************************************************************** -!> \brief Write helium RDF according to HELIUM%PRINT%RDF -!> \param helium ... -!> \date 2009-07-23 -!> \author Lukasz Walewski -! ***************************************************************************** - SUBROUTINE helium_write_rdf( helium) - - TYPE(helium_solvent_type), POINTER :: helium - - CHARACTER(len=*), PARAMETER :: routineN = 'helium_write_rdf', & - routineP = moduleN//':'//routineN - - INTEGER :: handle, i, unit_nr - LOGICAL :: is_new, should_output - REAL(kind=dp) :: rtmp - TYPE(cp_logger_type), POINTER :: logger - TYPE(section_vals_type), POINTER :: print_key - - CALL timeset(routineN,handle) - - CPASSERT(ASSOCIATED(helium)) - CPASSERT(ASSOCIATED(helium%input)) - - NULLIFY(logger,print_key) - logger => cp_get_default_logger() - print_key => section_vals_get_subs_vals(helium%input, & - "MOTION%PINT%HELIUM%PRINT%RDF") - should_output = BTEST(cp_print_key_should_output( & - iteration_info=logger%iter_info,& - basis_section=print_key),cp_p_file) - IF (should_output) THEN - IF (logger%para_env%ionode) THEN - unit_nr=cp_print_key_unit_nr(logger,print_key, & - middle_name="helium-hst",extension=".dat",& - is_new_file=is_new) - IF (.NOT. is_new) THEN - WRITE(unit_nr,'(A1)') "&" - END IF - DO i = 1, helium%rdf_nbin - rtmp = ( REAL(i) - 0.5_dp ) * helium%rdf_delr - rtmp = cp_unit_from_cp2k(rtmp, "angstrom") - WRITE(unit_nr,'(2F20.10)') rtmp,& - helium%rdf_avrg(i) - END DO - CALL m_flush(unit_nr) - CALL cp_print_key_finished_output(unit_nr,logger,print_key) - END IF - END IF - - CALL timestop(handle) - RETURN - END SUBROUTINE helium_write_rdf - - -! *************************************************************************** -!> \brief Write helium densities according to HELIUM%PRINT%RHO -!> \param helium ... -!> \date 2011-06-21 -!> \par History -!> 2011-11-11 output of any number of density estimators to different -!> files according to helium%rho_num -!> \author Lukasz Walewski -! ***************************************************************************** - SUBROUTINE helium_write_rho( helium) - - TYPE(helium_solvent_type), POINTER :: helium - - CHARACTER(len=*), PARAMETER :: routineN = 'helium_write_rho', & - routineP = moduleN//':'//routineN - - CHARACTER(len=default_string_length) :: stmp - INTEGER :: handle, i, itmp, iweight, ix, & - iy, iz, N, nsteps, unit_nr - LOGICAL :: should_output - REAL(kind=dp) :: inv_norm, rtmp, rx, ry, rz - REAL(kind=dp), DIMENSION(3) :: r0 - REAL(kind=dp), DIMENSION(:, :, :), & - POINTER :: message - TYPE(cp_logger_type), POINTER :: logger - TYPE(section_vals_type), POINTER :: print_key - - CALL timeset(routineN,handle) - - CPASSERT(ASSOCIATED(helium)) - CPASSERT(ASSOCIATED(helium%input)) - - NULLIFY(logger,print_key) - logger => cp_get_default_logger() - print_key => section_vals_get_subs_vals(helium%input, & - "MOTION%PINT%HELIUM%PRINT%RHO") - should_output = BTEST(cp_print_key_should_output( & - iteration_info=logger%iter_info,& - basis_section=print_key),cp_p_file) - IF (should_output) THEN - - ! work on the temporary array so that accumulated data remains intact - helium%rho_inst(:,:,:,:) = helium%rho_avrg(:,:,:,:) - - ! average over helium environments - DO i = 1, helium%rho_num - NULLIFY(message) - message => helium%rho_inst(i,1::1,1::1,1::1) - CALL mp_sum(message,logger%para_env%group) - END DO - itmp = logger%para_env%num_pe - CPASSERT(itmp>0) - inv_norm = 1.0_dp / REAL(itmp,dp) - helium%rho_inst(:,:,:,:) = helium%rho_inst(:,:,:,:) * inv_norm - - ! average over steps performed so far in this run - nsteps = helium%current_step-helium%first_step - CPASSERT(nsteps>0) - inv_norm = 1.0_dp / REAL(nsteps,dp) - helium%rho_inst(:,:,:,:) = helium%rho_inst(:,:,:,:) * inv_norm - - iweight = helium%rho_iweight - IF ( helium%rho_restart ) THEN - ! average over the old and the current density (observe the weights!) - helium%rho_inst(:,:,:,:) = nsteps * helium%rho_inst(:,:,:,:) + & - iweight * helium%rho_rstr(:,:,:,:) - helium%rho_inst(:,:,:,:) = helium%rho_inst(:,:,:,:) / ( nsteps + iweight ) - END IF - - IF (logger%para_env%ionode) THEN - - N = helium%rho_nbin - rtmp = cp_unit_from_cp2k(helium%rho_delr, "bohr") - r0(:) = helium%origin(:) - rx = r0(1) - helium%rho_maxr / 2.0_dp - ry = r0(2) - helium%rho_maxr / 2.0_dp - rz = r0(3) - helium%rho_maxr / 2.0_dp - - DO i = 1, helium%rho_num - stmp = "" - WRITE(stmp,*) i - unit_nr=cp_print_key_unit_nr(logger,print_key, & - middle_name="helium-rho-"//TRIM(ADJUSTL(stmp)), & - extension=".cube", & - file_position="REWIND", do_backup=.FALSE.) - - WRITE(unit_nr,'(A)') "Helium density " // TRIM(ADJUSTL(stmp)) - WRITE(unit_nr,'(A)') "CP2K" - WRITE(unit_nr,'(I5,3F12.8)') 1, rx, ry, rz - WRITE(unit_nr,'(I5,3F12.8)') N, rtmp, 0.0_dp, 0.0_dp - WRITE(unit_nr,'(I5,3F12.8)') N, 0.0_dp, rtmp, 0.0_dp - WRITE(unit_nr,'(I5,3F12.8)') N, 0.0_dp, 0.0_dp, rtmp - WRITE(unit_nr,'(I5,4F12.8)') 1, 0.0_dp, r0(1), r0(2), r0(3) - DO ix = 1, N - DO iy = 1, N - DO iz = 1, N - WRITE(unit_nr,'(E13.5,1X)', ADVANCE='NO') helium%rho_inst(i,ix,iy,iz) - IF ( MOD(iz,6) .EQ. 5 ) THEN - WRITE(unit_nr,*) - END IF - END DO - WRITE(unit_nr,*) - END DO - END DO - - CALL m_flush(unit_nr) - CALL cp_print_key_finished_output(unit_nr,logger,print_key) - - END DO - - END IF - END IF - - CALL timestop(handle) - END SUBROUTINE helium_write_rho - - -! *************************************************************************** -!> \brief Write helium permutation length according to HELIUM%PRINT%PLENGTH -!> \param helium ... -!> \date 2010-06-07 -!> \author Lukasz Walewski -! ***************************************************************************** - SUBROUTINE helium_write_plength( helium) - - TYPE(helium_solvent_type), POINTER :: helium - - CHARACTER(len=*), PARAMETER :: routineN = 'helium_write_plength', & - routineP = moduleN//':'//routineN - - INTEGER :: handle, i, unit_nr - LOGICAL :: is_new, should_output - TYPE(cp_logger_type), POINTER :: logger - TYPE(section_vals_type), POINTER :: print_key - - CALL timeset(routineN,handle) - - CPASSERT(ASSOCIATED(helium)) - CPASSERT(ASSOCIATED(helium%input)) - - NULLIFY(logger,print_key) - logger => cp_get_default_logger() - print_key => section_vals_get_subs_vals(helium%input, & - "MOTION%PINT%HELIUM%PRINT%PLENGTH") - should_output = BTEST(cp_print_key_should_output( & - iteration_info=logger%iter_info,& - basis_section=print_key),cp_p_file) - IF (should_output) THEN - IF (logger%para_env%ionode) THEN - unit_nr=cp_print_key_unit_nr(logger,print_key, & - middle_name="helium-plength",extension=".dat",& - is_new_file=is_new) - - DO i = 1, helium%atoms - WRITE(unit_nr,'(F20.10)',ADVANCE='NO') helium%plength_avrg(i) - IF ( i .LT. helium%atoms ) THEN - WRITE(unit_nr,'(1X)',ADVANCE='NO') - END IF - END DO - WRITE(unit_nr, '(A)') "" - - CALL m_flush(unit_nr) - CALL cp_print_key_finished_output(unit_nr,logger,print_key) - END IF - END IF - - CALL timestop(handle) - RETURN - END SUBROUTINE helium_write_plength - -! *************************************************************************** -!> \brief Write helium force according to HELIUM%PRINT%FORCE -!> \param helium ... -!> \date 2010-01-27 -!> \author Lukasz Walewski -! ***************************************************************************** - SUBROUTINE helium_write_force( helium) - - TYPE(helium_solvent_type), POINTER :: helium - - CHARACTER(len=*), PARAMETER :: routineN = 'helium_write_force', & - routineP = moduleN//':'//routineN - - CHARACTER(len=default_string_length) :: msgstr - INTEGER :: handle, ia, ib, ic, idim, & - unit_nr - TYPE(cp_logger_type), POINTER :: logger - TYPE(section_vals_type), POINTER :: print_key - - CALL timeset(routineN,handle) - - CPASSERT(ASSOCIATED(helium)) - - NULLIFY(logger) - logger => cp_get_default_logger() - - ! decide whether to write anything or not - NULLIFY(print_key) - print_key => section_vals_get_subs_vals( helium%input, & - "MOTION%PINT%HELIUM%PRINT%FORCES") - IF ( .NOT. BTEST(cp_print_key_should_output(logger%iter_info, & - basis_section=print_key),cp_p_file) ) THEN - CALL timestop(handle) - RETURN - END IF - - ! check if there is anything to be printed out - IF ( .NOT. helium%solute_present ) THEN - msgstr = "Warning: force printout requested but there is no solute!" - CALL helium_write_line( msgstr) - CALL timestop(handle) - RETURN - END IF - - ! I/O only on the ionode - IF (logger%para_env%ionode) THEN - - unit_nr=cp_print_key_unit_nr(logger, print_key, & - middle_name="helium-force",extension=".dat") - - ! print all force components in one line - DO ib = 1, helium%solute_beads - idim = 0 - DO ia = 1, helium%solute_atoms - DO ic = 1, 3 - idim = idim + 1 - WRITE(unit_nr,'(F20.10)',ADVANCE='NO') helium%force_avrg(ib,idim) - END DO - END DO - END DO - WRITE(unit_nr,*) - - ! finalize the printout - CALL m_flush(unit_nr) - CALL cp_print_key_finished_output(unit_nr,logger,print_key) - - END IF - - CALL timestop(handle) - RETURN - END SUBROUTINE helium_write_force - -! *************************************************************************** -!> \brief Write instantaneous helium forces -!> \param helium ... -!> \date 2010-01-29 -!> \author Lukasz Walewski -!> \note Collects instantaneous helium forces from all processors on -!> logger%para_env%source and writes them to files - one file per processor. -!> This subroutine does message passing, frequent calls can slow down your -!> code significantly. -! ***************************************************************************** - SUBROUTINE helium_write_force_inst( helium) - - TYPE(helium_solvent_type), POINTER :: helium - - CHARACTER(len=*), PARAMETER :: routineN = 'helium_write_force_inst', & - routineP = moduleN//':'//routineN - - CHARACTER(len=default_string_length) :: my_middle_name, stmp - INTEGER :: handle, ia, ib, ic, idim, & - irank, offset, unit_nr - TYPE(cp_logger_type), POINTER :: logger - TYPE(section_vals_type), POINTER :: print_key - - CALL timeset(routineN,handle) - - CPASSERT(ASSOCIATED(helium)) - - NULLIFY(logger) - logger => cp_get_default_logger() - - ! decide whether to write anything or not - NULLIFY(print_key) - print_key => section_vals_get_subs_vals( helium%input, & - "MOTION%PINT%HELIUM%PRINT%FORCES_INST") - IF ( .NOT. BTEST(cp_print_key_should_output(logger%iter_info, & - basis_section=print_key),cp_p_file) ) THEN - CALL timestop(handle) - RETURN - END IF - - ! check if there is anything to be printed out - IF ( .NOT. helium%solute_present ) THEN - stmp = "Warning: force printout requested but there is no solute!" - CALL helium_write_line( stmp) - CALL timestop(handle) - RETURN - END IF - - ! fill the tmp buffer with instantaneous helium forces at each proc - helium%rtmp_p_ndim_1d(:) = PACK( helium%force_inst, .TRUE. ) - - ! pass the message from all processors to logger%para_env%source - helium%rtmp_p_ndim_np_1d(:) = 0.0_dp - CALL mp_gather( helium%rtmp_p_ndim_1d, helium%rtmp_p_ndim_np_1d, & - logger%para_env%source, logger%para_env%group ) - - ! I/O only on the ionode - IF (logger%para_env%ionode) THEN - - ! iterate over processors/helium environments - DO irank = 1, helium%num_env - - ! generate one file per processor - stmp = "" - WRITE(stmp,*) irank - my_middle_name = "helium-force-inst-" // TRIM(ADJUSTL(stmp)) - unit_nr=cp_print_key_unit_nr( logger, print_key, & - middle_name=TRIM(my_middle_name), extension=".dat") - - ! unpack and actually print the forces - all components in one line - offset = (irank-1) * SIZE(helium%rtmp_p_ndim_1d) - idim = 0 - DO ib = 1, helium%solute_beads - DO ia = 1, helium%solute_atoms - DO ic = 1, 3 - idim = idim + 1 - WRITE(unit_nr,'(F20.10)',ADVANCE='NO') helium%rtmp_p_ndim_np_1d(offset+idim) - END DO - END DO - END DO - WRITE(unit_nr,*) - - ! finalize the printout - CALL m_flush(unit_nr) - CALL cp_print_key_finished_output(unit_nr,logger,print_key) - - END DO - - END IF - - CALL timestop(handle) - RETURN - END SUBROUTINE helium_write_force_inst - -END MODULE helium_io diff --git a/src/helium_types.F b/src/helium_types.F deleted file mode 100644 index c3e1dff354..0000000000 --- a/src/helium_types.F +++ /dev/null @@ -1,187 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 - 2015 CP2K developers group ! -!-----------------------------------------------------------------------------! - -! ***************************************************************************** -!> \brief Data types representing superfluid helium -!> \author hforbert -!> \date 2009-01-01 -!> \par History -!> extracted helium_solvent_type from pint_types.F [lwalewski] -! ***************************************************************************** -MODULE helium_types - - USE cell_types, ONLY: cell_type - USE cp_log_handling, ONLY: cp_logger_type - USE input_section_types, ONLY: section_vals_type - USE kinds, ONLY: dp,& - int_8 - USE parallel_rng_types, ONLY: rng_stream_type - USE splines_types, ONLY: spline_data_p_type -#include "./base/base_uses.f90" - - IMPLICIT NONE - - PRIVATE - - REAL(kind=dp), PARAMETER, PUBLIC :: he_mass = 4.00263037059764_dp ! 4He mass in [u] - - ! Energy contributions - symbolic names for indexing energy arrays - INTEGER, PARAMETER, PUBLIC :: e_id_total = 1, & - e_id_potential = 2, & - e_id_kinetic = 3, & - e_id_interact = 4, & - e_id_thermo = 5, & - e_id_virial = 6 - - ! Number of energy contributions for static array allocation - INTEGER, PARAMETER, PUBLIC :: e_num_ids = 10 - - PUBLIC :: helium_solvent_type - -! ***************************************************************************** -!> \brief data of solvent helium -!> \note -!> ref_count - reference count of this data structure -!> id_nr - identification number of this data structure -!> input - input data structure (the whole tree) -!> num_env - number of independent He environments -!> num_env_restart - number of He environments present in the restart file -!> periodic - true if bulk liquid helium in periodic box -!> cell_shape - unit cell shape for PBC calculations -!> cell_size - size of the periodic box for helium only -!> cell_size_inv - 1 / cell_size (inverse) -!> cell_m_inv - invrse of the unit cell vectors' matrix -!> tau - 1/(k_B T p) with T being the He temperature, p - number of beads -!> density - helium density for free bulk in box -!> e_corr - potential correction energy due to finite box -!> hb2m - hbar squared over m for helium -!> atoms - number of helium atoms -!> beads - number of helium beads per atom (needs to be an integer -!> multiple of the solvated molecule bead number) -!> pdx - pair density expansion max exponent -!> maxcycle - maximum cyclic permutation change to attempt -!> m_value - cycle length sampled with different probability than other lengths -!> m_ratio - probability ratio betw m_value and other possible values of m -!> bisection - power of 2 number for bisection algorithm -!> bisctlog2 - log2(bisection) -!> relrot - relative rotation in imaginary time with -!> respect to the normal system/starting configuration -!> iter_norot - number of iterations to try for a given -!> imaginary time slice rotation -!> iter_rot - number of rotations to try -!> total number of iterations is iter_norot*iter_rot -!> iter - number of iterations tried so far -!> first_step - first step, restarted from MOTION%PINT%ITERATION (def val =0) -!> current_step - first_step + number of steps performed so far -!> accepts - number of accepted new configurations -!> num_accepted - average number of accepted permutations of a given length -!> on a given Levy level, plus one additional level which -!> counts # of trials, REAL(BISCTLOG2+2, MAX_PERM_CYCLE) -!> num_accepted(1,l) - # of trials for perm length l -!> num_accepted(2,l) - # of selected perms of length l -!> num_accepted(3,l) - # of perms of length l accepted at level 1 -!> average over He environments/processors -!> wnumber_inst - winding number (instantaneous) REAL(3) -!> wnumber_avrg - winding number (averaged) REAL(3) -!> sdensity_inst - superfluid density (instantaneous) REAL -!> sdensity_avrg - superfluid density (averaged) REAL -!> pos - position of the helium atoms REAL(3,ATOMS,BEADS) -!> work - same dimensions as pos -!> tmatrix - ? permutation probability related -!> pmatrix - ? permutation probability related -!> [use might change/new ones added/etc] -!> pweight - ? permutation probability related -!> ptable - proposed cyclic permutation -!> (dimension max_cycle) -!> permutation - current permutation state INTEGER(ATOMS) -!> iperm - inverse of the current permutation state INTEGER(ATOMS) -!> plength_avrg - permutation length probability distribution REAL(ATOMS) -!> plength_inst - instantaneous permutation length probability REAL(ATOMS) -!> atom_plength - length of the permutation cycle the atom belongs to INTEGER(ATOMS) -!> uij - pair density matrix coefficients (action) -!> eij - pair density matrix coefficients (energy) -!> bead_ratio - ratio of helium beads to system beads -!> rng_stream_uniform - random numbers from uniform distribution -!> rng_stream_gaussian - random numbers from gaussian distribution -!> rdf_delr - delta r for RDF -!> rdf_maxr - maximum r for RDF -!> solute_present- switch the interactions with the solute on or off -!> solute_atoms - number of solute atoms (=pint_env%ndim/3) -!> solute_beads - number of solute beads (=pint_env%p) -!> solute_element- element names of solute atoms (NDIM/3) -!> solute_number - number of solute atoms of different atomic kinds -!> solute_index - indices of solute atoms sorted by atomic kinds -!> solute_cell - dimensions of the solvated system cell (a,b,c) -!> (not needed now and should be removed at some point) -!> force_avrg - averaged forces exerted by He solvent on the solute (P,NDIM) -!> force_inst - instantaneous forces exerted by He on the solute (P, NDIM) -!> General purpose temporary arrays -!> (performance measure: no allocation in frequently called subroutines) -!> rtmp_3_np_1d - real, 1D temp array (3 * NUM_ENV) -!> rtmp_p_ndim_1d - real, 1D temp array (P * NDIM) -!> rtmp_p_ndim_np_1d - real, 1D temp array (P * NDIM * NUM_ENV) -!> rtmp_p_ndim_2d - real, 2D temp array (P, NDIM) -!> rtmp_3_atoms_beads_1d - real, 1D temp array (3 * ATOMS * BEADS) -!> ltmp_3_atoms_beads_3d - logical, 3D temp array (3,ATOMS,BEADS) - same as pos -!> itmp_atoms_1d - integer, 1D temp array (ATOMS) - same as permutation -!> itmp_atoms_np_1d - integer, 1D temp array (ATOMS*NUM_ENV) -!> ltmp_atoms_1d - logical, 1D temp array (ATOMS) - for unpacking permutation -!> \author hforbert -! ***************************************************************************** - TYPE helium_solvent_type - INTEGER :: id_nr,ref_count - TYPE(section_vals_type), POINTER :: input - TYPE(cp_logger_type), POINTER :: logger - LOGICAL :: periodic - INTEGER :: cell_shape, num_env, num_env_restart, m_value - REAL(kind=dp) :: cell_size, cell_size_inv, m_ratio - REAL(kind=dp), DIMENSION(3,3) :: cell_m_inv - REAL(kind=dp) :: tau, density, e_corr, hb2m, pweight - INTEGER :: atoms, beads, pdx, maxcycle, relrot, iter_norot, iter_rot - INTEGER :: bisection, bisctlog2 - INTEGER :: bead_ratio, num_steps, first_step, last_step, current_step - INTEGER(kind=int_8) :: accepts - INTEGER, DIMENSION(:), POINTER :: ptable - INTEGER, DIMENSION(:), POINTER :: permutation - INTEGER, DIMENSION(:), POINTER :: iperm - REAL(kind=dp), DIMENSION(:,:,:), POINTER :: pos - REAL(kind=dp), DIMENSION(:,:,:), POINTER :: work - REAL(kind=dp), DIMENSION(:,:), POINTER :: tmatrix - REAL(kind=dp), DIMENSION(:,:), POINTER :: pmatrix - REAL(kind=dp), DIMENSION(:,:), POINTER :: ipmatrix - INTEGER, DIMENSION(:,:), POINTER :: nmatrix - TYPE (spline_data_p_type), DIMENSION(:,:), POINTER :: uij - TYPE (spline_data_p_type), DIMENSION(:,:), POINTER :: eij - REAL(kind=dp), DIMENSION(e_num_ids) :: energy_inst, energy_avrg - REAL(kind=dp), DIMENSION(3) :: wnumber_inst, wnumber_avrg, origin - REAL(kind=dp) :: sdensity_inst, sdensity_avrg - REAL(kind=dp), DIMENSION(:,:), POINTER :: num_accepted - REAL(kind=dp), DIMENSION(:), POINTER :: plength_avrg, plength_inst - INTEGER, DIMENSION(:), POINTER :: atom_plength - INTEGER :: rdf_nbin - REAL(kind=dp) :: rdf_delr, rdf_maxr - REAL(kind=dp), DIMENSION(:), POINTER :: rdf_inst, rdf_avrg - INTEGER :: rho_nbin, rho_minb, rho_iweight, rho_num - REAL(kind=dp) :: rho_delr, rho_maxr - REAL(kind=dp), DIMENSION(:,:,:,:), POINTER :: rho_inst, rho_avrg, rho_rstr - LOGICAL :: rho_restart, rho_present - TYPE(rng_stream_type), POINTER :: rng_stream_gaussian, rng_stream_uniform - ! variables that describe the solvated molecular system - LOGICAL :: solute_present - INTEGER :: solute_atoms, solute_beads - CHARACTER(LEN=2), DIMENSION(:), POINTER :: solute_element - INTEGER, DIMENSION(:), POINTER :: solute_number - INTEGER, DIMENSION(:,:), POINTER :: solute_index - TYPE(cell_type), POINTER :: solute_cell - REAL(KIND=dp), DIMENSION(:,:), POINTER :: force_avrg, force_inst - INTEGER, DIMENSION(:), POINTER :: itmp_atoms_1d, itmp_atoms_np_1d - REAL(KIND=dp), DIMENSION(:), POINTER :: rtmp_3_np_1d, rtmp_p_ndim_1d, rtmp_p_ndim_np_1d - REAL(KIND=dp), DIMENSION(:), POINTER :: rtmp_3_atoms_beads_1d, rtmp_3_atoms_beads_np_1d - REAL(KIND=dp), DIMENSION(:,:), POINTER :: rtmp_p_ndim_2d - LOGICAL, DIMENSION(:,:,:), POINTER :: ltmp_3_atoms_beads_3d - LOGICAL, DIMENSION(:), POINTER :: ltmp_atoms_1d - END TYPE helium_solvent_type - -END MODULE helium_types diff --git a/src/input_constants.F b/src/input_constants.F index b15fd11658..76f86ac97a 100644 --- a/src/input_constants.F +++ b/src/input_constants.F @@ -288,6 +288,41 @@ MODULE input_constants helium_cell_shape_cube=1,& helium_cell_shape_octahedron=2 + ! helium-solute interaction potentials + INTEGER, PARAMETER, PUBLIC :: helium_solute_intpot_none=0,& + helium_solute_intpot_mwater=1 + + ! helium force selection + INTEGER, PARAMETER, PUBLIC :: helium_forces_average = 0, & + helium_forces_last = 1 + ! superfluid density, estimators + INTEGER, PARAMETER, PUBLIC :: estimator_none=1,& + estimator_parea=2,& + estimator_wnumber=3, & + estimator_pcycle=4, & + estimator_weighted=5, & + estimator_normalization=6 + + ! superfluid density, denominator selector + INTEGER, PARAMETER, PUBLIC :: denominator_unity=1,& + denominator_natoms=2,& + denominator_inertia=3,& + denominator_rperp2=4 + + ! helium-sampling algorithms + INTEGER, PARAMETER, PUBLIC :: helium_sampling_ceperley=0 + + ! distribution types for sampling path lengths + INTEGER, PARAMETER, PUBLIC :: helium_mdist_singlev=1,& + helium_mdist_uniform=2,& + helium_mdist_linear=3,& + helium_mdist_quadratic=4,& + helium_mdist_exponential=5,& + helium_mdist_gaussian=6 + + INTEGER, PARAMETER, PUBLIC :: perm_plain=1,& + perm_cycle=2 + ! Free Energy methods INTEGER, PARAMETER, PUBLIC :: do_fe_meta=0,& do_fe_ui=1,& diff --git a/src/motion/helium_common.F b/src/motion/helium_common.F new file mode 100644 index 0000000000..d9cae1848e --- /dev/null +++ b/src/motion/helium_common.F @@ -0,0 +1,2620 @@ +!-----------------------------------------------------------------------------! +! CP2K: A general program to perform molecular dynamics simulations ! +! Copyright (C) 2000 - 2015 CP2K developers group ! +!-----------------------------------------------------------------------------! + +! ***************************************************************************** +!> \brief Independent helium subroutines shared with other modules +!> \author Lukasz Walewski +!> \date 2009-07-14 +!> \note Avoiding circular deps: do not USE any other helium_* modules here. +! ***************************************************************************** +MODULE helium_common + + USE helium_types, ONLY: helium_solvent_type,& + int_arr_ptr,& + rho_atom_number,& + rho_moment_of_inertia,& + rho_num,& + rho_projected_area,& + rho_winding_cycle,& + rho_winding_number + USE input_constants, ONLY: denominator_inertia,& + denominator_natoms,& + denominator_rperp2,& + helium_cell_shape_cube,& + helium_cell_shape_octahedron + USE kinds, ONLY: default_string_length,& + dp + USE memory_utilities, ONLY: reallocate + USE parallel_rng_types, ONLY: next_random_number + USE physcon, ONLY: angstrom,& + bohr + USE pint_public, ONLY: pint_calc_centroid,& + pint_com_pos + USE pint_types, ONLY: pint_env_type + USE splines_methods, ONLY: spline_value + USE splines_types, ONLY: spline_data_p_type,& + spline_data_type +#include "../base/base_uses.f90" + + IMPLICIT NONE + + PRIVATE + + LOGICAL, PRIVATE, PARAMETER :: debug_this_module=.TRUE. + CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'helium_common' + + PUBLIC :: helium_pbc + PUBLIC :: helium_boxmean_3d + PUBLIC :: helium_calc_rdf + PUBLIC :: helium_calc_rho + PUBLIC :: helium_calc_plength + PUBLIC :: helium_rotate + PUBLIC :: helium_eval_expansion + PUBLIC :: helium_update_transition_matrix + PUBLIC :: helium_spline + PUBLIC :: helium_cycle_number + PUBLIC :: helium_path_length + PUBLIC :: helium_is_winding + PUBLIC :: helium_cycle_of + PUBLIC :: helium_total_winding_number + PUBLIC :: helium_total_projected_area + PUBLIC :: helium_link_projected_area + PUBLIC :: helium_cycle_projected_area + PUBLIC :: helium_cycle_projected_area_pbc + PUBLIC :: helium_total_moment_of_inertia + PUBLIC :: helium_total_moment_of_inertia_linkwise + PUBLIC :: helium_com + PUBLIC :: helium_total_projected_area_linkwise + PUBLIC :: helium_link_vector + PUBLIC :: helium_calc_cycles + PUBLIC :: helium_update_coord_system + PUBLIC :: helium_set_rdf_coord_system + + CONTAINS + + +! *************************************************************************** +!> \brief General PBC routine for helium. +!> \param helium ... +!> \param r ... +!> \param enforce ... +!> \date 2009-09-30 +!> \author Lukasz Walewski +!> \note Check wheather PBC should be applied, if yes call low level +!> routine according to the unit cell shape. +! ***************************************************************************** + SUBROUTINE helium_pbc( helium, r, enforce ) + + TYPE(helium_solvent_type), POINTER :: helium + REAL(KIND=dp), DIMENSION(3), & + INTENT(INOUT) :: r + LOGICAL, OPTIONAL :: enforce + + IF (.NOT. helium%periodic) THEN + IF (.NOT. PRESENT(enforce)) THEN + RETURN + END IF + END IF + + SELECT CASE (helium%cell_shape) + CASE (helium_cell_shape_cube) + CALL helium_pbc_cube( helium, r ) + CASE (helium_cell_shape_octahedron) + CALL helium_pbc_trocta_opt( helium, r ) + CASE DEFAULT + ! we should never get here + END SELECT + + RETURN + END SUBROUTINE helium_pbc + + +! *************************************************************************** +!> \brief Wrap r back to the helium box (if helium box is periodic) +!> \param helium - helium environment for which to wrap +!> \param r - 3D vector to be wraped back to periodic box +!> \par History +!> 2009-10-02 renamed, originally was helium_box +!> 2009-10-02 redesigned so it is now called as a subroutine [lwalewski] +!> 2009-10-02 redesigned so it now gets/returns a 3D vector [lwalewski] +!> \author hforbert +! ***************************************************************************** + SUBROUTINE helium_pbc_cube( helium, r ) + + TYPE(helium_solvent_type), POINTER :: helium + REAL(KIND=dp), DIMENSION(3), & + INTENT(INOUT) :: r + + REAL(KIND=dp) :: s + +! x coordinate + + s = helium%cell_size_inv * r(1) + IF ( s > 0.5_dp ) THEN + s = s - REAL(INT(s+0.5_dp),dp) + ELSEIF ( s < -0.5_dp ) THEN + s = s - REAL(INT(s-0.5_dp),dp) + END IF + r(1) = s * helium%cell_size + + ! y coordinate + s = helium%cell_size_inv * r(2) + IF ( s > 0.5_dp ) THEN + s = s - REAL(INT(s+0.5_dp),dp) + ELSEIF ( s < -0.5_dp ) THEN + s = s - REAL(INT(s-0.5_dp),dp) + END IF + r(2) = s * helium%cell_size + + ! z coordinate + s = helium%cell_size_inv * r(3) + IF ( s > 0.5_dp ) THEN + s = s - REAL(INT(s+0.5_dp),dp) + ELSEIF ( s < -0.5_dp ) THEN + s = s - REAL(INT(s-0.5_dp),dp) + END IF + r(3) = s * helium%cell_size + + RETURN + END SUBROUTINE helium_pbc_cube + + +#if 0 + +! *************************************************************************** +!> \brief Apply PBC within truncated octahedral unit cell. +!> \param helium ... +!> \param r ... +!> \date 2009-10-02 +!> \author Lukasz Walewski +!> \note Original Allen & Tildesley routine adapted for our helium code. +! ***************************************************************************** + SUBROUTINE helium_pbc_trocta( helium, r ) + + TYPE(helium_solvent_type), POINTER :: helium + REAL(KIND=dp), DIMENSION(3), & + INTENT(INOUT) :: r + + REAL(KIND=dp) :: corr, r75, rx, ry, rz + +! ** PERIODIC BOUNDARY CONDITIONS FOR A TRUNCATED OCTAHEDRON ** +! ** ** +! ** THE BOX IS CENTRED AT THE ORIGIN. THE AXES PASS THROUGH THE ** +! ** CENTRES OF THE SIX SQUARE FACES OF THE TRUNCATED OCTAHEDRON ** +! ** (SEE F1G. 1.10(A)). THE CONTAINING CUBE IS OF UNIT LENGTH ** + + PARAMETER ( r75 = 4.0_dp / 3.0_dp ) + + rx = r(1) * helium%cell_size_inv + ry = r(2) * helium%cell_size_inv + rz = r(3) * helium%cell_size_inv + + rx = rx - ANINT ( rx ) + ry = ry - ANINT ( ry ) + rz = rz - ANINT ( rz ) + corr = 0.5_dp * AINT ( r75 * ( ABS ( rx ) + ABS ( ry ) + ABS ( rz ) ) ) + rx = rx - SIGN ( corr, rx ) + ry = ry - SIGN ( corr, ry ) + rz = rz - SIGN ( corr, rz ) + + r(1) = rx * helium%cell_size + r(2) = ry * helium%cell_size + r(3) = rz * helium%cell_size + + RETURN + END SUBROUTINE helium_pbc_trocta + +#endif + + +! *************************************************************************** +!> \brief Apply PBC within truncated octahedral unit cell. +!> \param helium ... +!> \param r ... +!> \date 2009-10-22 +!> \author hforbert +!> \note Version of the original Allen & Tildesley routine optimized for +!> g95 and intel compilers on x86-64. +! ***************************************************************************** + SUBROUTINE helium_pbc_trocta_opt( helium, r ) + + TYPE(helium_solvent_type), POINTER :: helium + REAL(KIND=dp), DIMENSION(3), & + INTENT(INOUT) :: r + + REAL(KIND=dp) :: cell_size, cell_size_inv, & + corr, rx, ry, rz, sx, sy, sz + + cell_size = helium%cell_size + cell_size_inv = helium%cell_size_inv + + rx = r(1) * cell_size_inv + IF ( rx > 0.5_dp ) THEN + rx = rx - REAL(INT(rx+0.5_dp),dp) + ELSEIF ( rx < -0.5_dp ) THEN + rx = rx - REAL(INT(rx-0.5_dp),dp) + END IF + + ry = r(2) * cell_size_inv + IF ( ry > 0.5_dp ) THEN + ry = ry - REAL(INT(ry+0.5_dp),dp) + ELSEIF ( ry < -0.5_dp ) THEN + ry = ry - REAL(INT(ry-0.5_dp),dp) + END IF + + rz = r(3) * cell_size_inv + IF ( rz > 0.5_dp ) THEN + rz = rz - REAL(INT(rz+0.5_dp),dp) + ELSEIF ( rz < -0.5_dp ) THEN + rz = rz - REAL(INT(rz-0.5_dp),dp) + END IF + + corr = 0.0_dp + IF ( rx > 0.0_dp ) THEN + corr = corr + rx + sx = 0.5_dp + ELSE + corr = corr - rx + sx = -0.5_dp + END IF + IF ( ry > 0.0_dp ) THEN + corr = corr + ry + sy = 0.5_dp + ELSE + corr = corr - ry + sy = -0.5_dp + END IF + IF ( rz > 0.0_dp ) THEN + corr = corr + rz + sz = 0.5_dp + ELSE + corr = corr - rz + sz = -0.5_dp + END IF + IF ( corr > 0.75_dp ) THEN + rx = rx - sx + ry = ry - sy + rz = rz - sz + END IF + + r(1) = rx * cell_size + r(2) = ry * cell_size + r(3) = rz * cell_size + + RETURN + END SUBROUTINE helium_pbc_trocta_opt + + +! *************************************************************************** +!> \brief Calculate the point equidistant from two other points a and b +!> within the helium box - 3D version +!> \param helium - helium environment for which +!> \param a vectors for which to find the mean within the He box +!> \param b vectors for which to find the mean within the He box +!> \param c ... +!> \par History +!> 2009-10-02 renamed, originally was helium_boxmean [lwalewski] +!> 2009-10-02 redesigned so it is now called as a subroutine [lwalewski] +!> 2009-10-02 redesigned so it now gets/returns a 3D vectors [lwalewski] +!> \author hforbert +! ***************************************************************************** + SUBROUTINE helium_boxmean_3d(helium, a, b, c) + + TYPE(helium_solvent_type), POINTER :: helium + REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: a, b + REAL(KIND=dp), DIMENSION(3), INTENT(OUT) :: c + + c(:) = b(:) - a(:) + CALL helium_pbc( helium, c ) + c(:) = a(:) + 0.5_dp * c(:) + CALL helium_pbc( helium, c ) + RETURN + END SUBROUTINE helium_boxmean_3d + + +! *************************************************************************** +!> \brief Given the permutation state assign cycle lengths to all He atoms. +!> \param helium ... +!> \date 2011-07-06 +!> \author Lukasz Walewski +!> \note The helium%atom_plength array is filled with cycle lengths, +!> each atom gets the length of the permutation cycle it belongs to. +! ***************************************************************************** + SUBROUTINE helium_calc_atom_cycle_length( helium ) + + TYPE(helium_solvent_type), POINTER :: helium + + CHARACTER(len=*), PARAMETER :: & + routineN = 'helium_calc_atom_cycle_length', & + routineP = moduleN//':'//routineN + + CHARACTER(len=default_string_length) :: err_str + INTEGER :: clen, curr_idx, handle, ia, & + start_idx + INTEGER, DIMENSION(:), POINTER :: atoms_in_cycle + LOGICAL :: atoms_left, path_end_reached + LOGICAL, DIMENSION(:), POINTER :: atom_was_used + + CALL timeset(routineN,handle) + + NULLIFY(atoms_in_cycle) + atoms_in_cycle => helium%itmp_atoms_1d + atoms_in_cycle(:) = 0 + + NULLIFY(atom_was_used) + atom_was_used => helium%ltmp_atoms_1d + atom_was_used(:) = .FALSE. + + helium%atom_plength(:) = 0 + + start_idx = 1 + DO + clen = 0 + path_end_reached = .FALSE. + curr_idx = start_idx + DO ia = 1, helium%atoms + clen = clen + 1 + atoms_in_cycle(clen) = curr_idx + atom_was_used(curr_idx) = .TRUE. + + ! follow to the next atom in the cycle + curr_idx = helium%permutation(curr_idx) + IF ( curr_idx .EQ. start_idx ) THEN + path_end_reached = .TRUE. + EXIT + END IF + END DO + err_str = "Permutation path is not cyclic." + IF (.NOT.path_end_reached) THEN + CPABORT(err_str) + END IF + + ! assign the cycle length to the collected atoms + DO ia = 1, clen + helium%atom_plength(atoms_in_cycle(ia)) = clen + END DO + + ! go to the next "unused" atom + atoms_left = .FALSE. + DO ia = 1, helium%atoms + IF ( .NOT. atom_was_used(ia) ) THEN + start_idx = ia + atoms_left = .TRUE. + EXIT + END IF + END DO + + IF (.NOT. atoms_left) EXIT + END DO + + atoms_in_cycle(:) = 0 + NULLIFY(atoms_in_cycle) + atom_was_used(:) = .FALSE. + NULLIFY(atom_was_used) + + CALL timestop(handle) + + RETURN + END SUBROUTINE helium_calc_atom_cycle_length + + +! *************************************************************************** +!> \brief Decompose a permutation into cycles +!> \param permutation ... +!> \retval cycles ... +!> \date 2013-12-11 +!> \author Lukasz Walewski +!> \note Given a permutation return a pointer to an array of pointers, +!> with each element pointing to a cycle of this permutation. +!> \note This function allocates memory and returns a pointer to it, +!> do not forget to deallocate once finished with the results. +! ***************************************************************************** + FUNCTION helium_calc_cycles(permutation) RESULT(cycles) + + INTEGER, DIMENSION(:), POINTER :: permutation + TYPE(int_arr_ptr), DIMENSION(:), POINTER :: cycles + + CHARACTER(len=*), PARAMETER :: routineN = 'helium_calc_cycles', & + routineP = moduleN//':'//routineN + + INTEGER :: curat, ncycl, nsize, nused + INTEGER, DIMENSION(:), POINTER :: cur_cycle, used_indices + TYPE(int_arr_ptr), DIMENSION(:), POINTER :: my_cycles + + nsize = SIZE(permutation) + + ! most pesimistic scenario: no cycles longer than 1 + ALLOCATE(my_cycles(nsize)) + + ! go over the permutation and identify cycles + curat = 1 + nused = 0 + ncycl = 0 + DO WHILE (curat .LE. nsize) + + ! get the permutation cycle the current atom belongs to + cur_cycle => helium_cycle_of(curat, permutation) + + ! include the current cycle in the pool of "used" indices + nused = nused + SIZE(cur_cycle) + CALL reallocate(used_indices,1,nused) + used_indices(nused-SIZE(cur_cycle)+1:nused) = cur_cycle(1:SIZE(cur_cycle)) + + ! store the pointer to the current cycle + ncycl = ncycl + 1 + my_cycles(ncycl)%iap => cur_cycle + + ! free the local pointer + NULLIFY(cur_cycle) + + ! try to increment the current atom index + DO WHILE (ANY(used_indices .EQ. curat)) + curat = curat + 1 + END DO + + END DO + + DEALLOCATE(used_indices) + NULLIFY(used_indices) + + ! assign the result + ALLOCATE(cycles(ncycl)) + cycles(1:ncycl) = my_cycles(1:ncycl) + + DEALLOCATE(my_cycles) + NULLIFY(my_cycles) + + RETURN + END FUNCTION helium_calc_cycles + + +! *************************************************************************** +!> \brief Calculate helium density distribution functions and store them +!> in helium%rho_inst +!> \param helium ... +!> \date 2011-06-14 +!> \author Lukasz Walewski +! ***************************************************************************** + SUBROUTINE helium_calc_rho(helium) + + TYPE(helium_solvent_type), POINTER :: helium + + CHARACTER(len=*), PARAMETER :: routineN = 'helium_calc_rho', & + routineP = moduleN//':'//routineN + + CHARACTER(len=default_string_length) :: msgstr + INTEGER :: aa, bx, by, bz, handle, ia, & + ib, ic, id, ii, ir, & + n_out_of_range, nbin + INTEGER, DIMENSION(3) :: nw + INTEGER, DIMENSION(:), POINTER :: cycl_len + LOGICAL :: ltmp1, ltmp2, ltmp3 + REAL(KIND=dp) :: invd3r, invdr, invp, rtmp + REAL(KIND=dp), DIMENSION(3) :: maxr_half, r, vlink, vtotal, & + wn + TYPE(int_arr_ptr), DIMENSION(:), POINTER :: cycles + + CALL timeset(routineN,handle) + + maxr_half(:) = helium%rho_maxr / 2.0_dp + invdr = 1.0_dp / helium%rho_delr + invd3r = invdr * invdr * invdr + invp = 1.0_dp / REAL(helium%beads,dp) + nbin = helium%rho_nbin + ! assign the cycle lengths to all the atoms + CALL helium_calc_atom_cycle_length( helium ) + NULLIFY(cycl_len) + cycl_len => helium%atom_plength + DO ir = 1, rho_num ! loop over densities --- + + IF (.NOT.helium%rho_property(ir)%is_calculated) THEN + ! skip densities that are not requested by the user + CYCLE + END IF + + SELECT CASE (ir) + + CASE (rho_atom_number) + ii = helium%rho_property(ir)%component_index(1) + helium%rho_incr(ii,:,:) = invp + + CASE (rho_projected_area) + vtotal(:) = helium_total_projected_area(helium) + DO ia = 1, helium%atoms + DO ib = 1, helium%beads + vlink(:) = helium_link_projected_area(helium,ia,ib) + DO ic = 1, 3 + ii = helium%rho_property(ir)%component_index(ic) + helium%rho_incr(ii,ia,ib) = vtotal(ic)*vlink(ic)*angstrom*angstrom*angstrom*angstrom + END DO + END DO + END DO + +! CASE (rho_winding_number) +! vtotal(:) = helium_total_winding_number(helium) +! DO ia = 1, helium%atoms +! DO ib = 1, helium%beads +! vlink(:) = helium_link_winding_number(helium,ia,ib) +! DO ic = 1, 3 +! ii = helium%rho_property(ir)%component_index(ic) +! helium%rho_incr(ii,ia,ib) = vtotal(ic)*vlink(ic)*angstrom*angstrom +! END DO +! END DO +! END DO + + CASE (rho_winding_number) + vtotal(:) = helium_total_winding_number(helium) + DO id = 1, 3 + ii = helium%rho_property(ir)%component_index(id) + helium%rho_incr(ii,:,:) = 0.0_dp + END DO + NULLIFY(cycles) + cycles => helium_calc_cycles(helium%permutation) + DO ic = 1, SIZE(cycles) + wn = helium_cycle_winding_number(helium,cycles(ic)%iap,helium%pos) + DO ia = 1, SIZE(cycles(ic)%iap) + aa = cycles(ic)%iap(ia) + DO ib = 1, helium%beads + vlink(:) = helium_link_winding_number(helium,aa,ib) + DO id = 1, 3 + IF (ABS(wn(id)) .GT. 100.0_dp*EPSILON(0.0_dp)) THEN + ii = helium%rho_property(ir)%component_index(id) + helium%rho_incr(ii,aa,ib) = vtotal(id)*vlink(id)*angstrom*angstrom + END IF + END DO + END DO + END DO + END DO + DEALLOCATE(cycles) + + CASE (rho_winding_cycle) + vtotal(:) = helium_total_winding_number(helium) + DO id = 1, 3 + ii = helium%rho_property(ir)%component_index(id) + helium%rho_incr(ii,:,:) = 0.0_dp + END DO + NULLIFY(cycles) + cycles => helium_calc_cycles(helium%permutation) + ! compute number of atoms in all winding cycles + nw(:) = 0 + DO ic = 1, SIZE(cycles) + wn = helium_cycle_winding_number(helium,cycles(ic)%iap,helium%pos) + DO id = 1, 3 + IF (ABS(wn(id)) .GT. 100.0_dp*EPSILON(0.0_dp)) THEN + nw(id) = nw(id) + SIZE(cycles(ic)%iap) + END IF + END DO + END DO + ! assign contributions to all beads of winding cycles only + DO ic = 1, SIZE(cycles) + wn = helium_cycle_winding_number(helium,cycles(ic)%iap,helium%pos) + DO id = 1, 3 + IF (ABS(wn(id)) .GT. 100.0_dp*EPSILON(0.0_dp)) THEN + DO ia = 1, SIZE(cycles(ic)%iap) + aa = cycles(ic)%iap(ia) + DO ib = 1, helium%beads + IF (nw(id) .GT. 0) THEN ! this test should always get passed + ii = helium%rho_property(ir)%component_index(id) + rtmp = invp / REAL(nw(id),dp) + helium%rho_incr(ii,aa,ib) = rtmp*vtotal(id)*vtotal(id)*angstrom*angstrom + END IF + END DO + END DO + END IF + END DO + END DO + DEALLOCATE(cycles) + + CASE (rho_moment_of_inertia) + vtotal(:) = helium_total_moment_of_inertia(helium) + DO ia = 1, helium%atoms + DO ib = 1, helium%beads + vlink(:) = helium_link_moment_of_inertia(helium,ia,ib) + DO ic = 1, 3 + ii = helium%rho_property(ir)%component_index(ic) + helium%rho_incr(ii,ia,ib) = vlink(ic)*angstrom*angstrom + END DO + END DO + END DO + + CASE DEFAULT + ! do nothing + + END SELECT + + END DO ! loop over densities --- + + n_out_of_range = 0 + helium%rho_inst(:,:,:,:) = 0.0_dp + DO ia = 1, helium%atoms + ! bin the bead positions of the current atom using the increments set above + DO ib = 1, helium%beads + ! map the current bead position to the corresponding voxel + r(:) = helium%pos(:,ia,ib) - helium%center(:) + ! enforce PBC even if this is a non-periodic calc to avoid density leakage + CALL helium_pbc( helium, r, enforce=.TRUE. ) + ! set up bin indices (translate by L/2 to avoid non-positive array indices) + bx = INT((r(1) + maxr_half(1)) * invdr) + 1 + by = INT((r(2) + maxr_half(2)) * invdr) + 1 + bz = INT((r(3) + maxr_half(3)) * invdr) + 1 + ! check that the resulting bin numbers are within array bounds + ltmp1 = (0 .LT. bx) .AND. ( bx .LE. nbin ) + ltmp2 = (0 .LT. by) .AND. ( by .LE. nbin ) + ltmp3 = (0 .LT. bz) .AND. ( bz .LE. nbin ) + IF (ltmp1 .AND. ltmp2 .AND. ltmp3) THEN + ! increment all the estimators (those that the current atom does not + ! contribute to have increment incr(ic)==0) + DO ic = 1, helium%rho_num_act + helium%rho_inst(ic,bx,by,bz) = helium%rho_inst(ic,bx,by,bz) + helium%rho_incr(ic,ia,ib) + END DO + ELSE + n_out_of_range = n_out_of_range + 1 + END IF + END DO + END DO + ! scale by volume element + helium%rho_inst(:,:,:,:) = helium%rho_inst(:,:,:,:) * invd3r + + ! stop if any bead fell out of the range + ! since enforced PBC should have taken care of such leaks + WRITE(msgstr,*) n_out_of_range + msgstr = "Number of bead positions out of range: "//TRIM(ADJUSTL(msgstr)) + IF (n_out_of_range .GT. 0) THEN + CPABORT(msgstr) + END IF + + CALL timestop(handle) + + RETURN + END SUBROUTINE helium_calc_rho + + +#if 0 +! *************************************************************************** +!> \brief Normalize superfluid densities according to the input keyword +!> HELIUM%SUPERFLUID_ESTIMATOR%DENOMINATOR +!> \param helium ... +!> \param rho ... +!> \date 2014-06-24 +!> \author Lukasz Walewski +! ***************************************************************************** + SUBROUTINE helium_norm_rho(helium,rho) + + TYPE(helium_solvent_type), POINTER :: helium + REAL(KIND=dp), DIMENSION(:, :, :, :), & + POINTER :: rho + + CHARACTER(len=*), PARAMETER :: routineN = 'helium_norm_rho', & + routineP = moduleN//':'//routineN + + INTEGER :: ix, iy, iz, ndim + REAL(KIND=dp) :: invatoms, rx, ry, rz + REAL(KIND=dp), DIMENSION(3) :: invmoit, invrperp, ro + + SELECT CASE(helium%supest_denominator) + + CASE (denominator_natoms) + invatoms = 1.0_dp / REAL(helium%atoms,dp) + rho(2,:,:,:) = rho(2,:,:,:) * invatoms + rho(3,:,:,:) = rho(3,:,:,:) * invatoms + rho(4,:,:,:) = rho(4,:,:,:) * invatoms + + CASE (denominator_inertia) + invmoit(:) = REAL(helium%atoms,dp) / helium%mominer%ravr(:) + rho(2,:,:,:) = rho(2,:,:,:) * invmoit(1) + rho(3,:,:,:) = rho(3,:,:,:) * invmoit(2) + rho(4,:,:,:) = rho(4,:,:,:) * invmoit(3) + + CASE (denominator_rperp2) + ndim = helium%rho_nbin + ro(:) = helium%center(:) - 0.5_dp*(helium%rho_maxr-helium%rho_delr) + DO ix = 1, ndim + DO iy = 1, ndim + DO iz = 1, ndim + rx = ro(1) + REAL(ix-1,dp) * helium%rho_delr + ry = ro(2) + REAL(iy-1,dp) * helium%rho_delr + rz = ro(3) + REAL(iz-1,dp) * helium%rho_delr + invrperp(1) = 1.0_dp / (ry*ry+rz*rz) + invrperp(2) = 1.0_dp / (rz*rz+rx*rx) + invrperp(3) = 1.0_dp / (rx*rx+ry*ry) + rho(2,ix,iy,iz) = rho(2,ix,iy,iz) * invrperp(1) + rho(3,ix,iy,iz) = rho(3,ix,iy,iz) * invrperp(2) + rho(4,ix,iy,iz) = rho(4,ix,iy,iz) * invrperp(3) + END DO + END DO + END DO + + CASE DEFAULT + ! do nothing + + END SELECT + + RETURN + END SUBROUTINE helium_norm_rho +#endif + + +! *************************************************************************** +!> \brief Calculate helium radial distribution functions wrt positions given +!> by using the atomic weights given by . +!> \param helium ... +!> \param centers ... +!> \date 2009-07-22 +!> \author Lukasz Walewski +! ***************************************************************************** + SUBROUTINE helium_calc_rdf (helium,centers) + + TYPE(helium_solvent_type), POINTER :: helium + REAL(KIND=dp), DIMENSION(:), POINTER :: centers + + CHARACTER(len=*), PARAMETER :: routineN = 'helium_calc_rdf', & + routineP = moduleN//':'//routineN + + CHARACTER(len=default_string_length) :: msgstr + INTEGER :: bin, handle, ia, ib, ic, id, & + n_out_of_range, nbin + REAL(KIND=dp) :: const, invdr, invp, nideal, & + pi, ri, rlower, rupper, sdens + REAL(KIND=dp), DIMENSION(3) :: r, r0 + REAL(KIND=dp), DIMENSION(:), POINTER :: incr + + CALL timeset(routineN,handle) + + pi = 4.0_dp * ATAN(1.0_dp) + invdr = 1.0_dp / helium%rdf_delr + invp = 1.0_dp / helium%beads + nbin = helium%rdf_nbin + sdens = helium%wpref * invp * helium%atoms + ALLOCATE(incr(helium%rdf_num)) + incr(:) = 0.0d0 + + ! calculate the histogram of distances + n_out_of_range = 0 + helium%rdf_inst(:,:,:) = 0.0_dp + DO ic = 1, SIZE(centers) / 3 + + r0(1) = centers(3*(ic-1)+1) + r0(2) = centers(3*(ic-1)+2) + r0(3) = centers(3*(ic-1)+3) + DO ia = 1, helium%atoms + + ! set the increments for this atom + incr(1) = invp + + DO ib = 1, helium%beads + r(:) = helium%pos(:,ia,ib) - r0(:) + CALL helium_pbc( helium, r ) + ri = SQRT( r(1)*r(1) + r(2)*r(2) + r(3)*r(3) ) + bin = INT(ri * invdr) + 1 + IF ((0 .LT. bin) .AND. ( bin .LE. nbin )) THEN + ! increment the RDF value for He atoms inside the r_6 sphere + DO id = 1, helium%rdf_num + helium%rdf_inst(id,bin,ic) = helium%rdf_inst(id,bin,ic) + incr(id) + END DO + ELSE + !WRITE(msgstr,*) helium%center * angstrom + !msgstr = "center = "//TRIM(ADJUSTL(msgstr)) + !CALL cp_error_message(cp_warning_level, routineP, msgstr, error) + !WRITE(msgstr,*) r0 * angstrom + !msgstr = "r0 = "//TRIM(ADJUSTL(msgstr)) + !CALL cp_error_message(cp_warning_level, routineP, msgstr, error) + !WRITE(msgstr,*) helium%pos(:,ia,ib) * angstrom + !msgstr = "pos = "//TRIM(ADJUSTL(msgstr)) + !CALL cp_error_message(cp_warning_level, routineP, msgstr, error) + !WRITE(msgstr,*) ri * angstrom + !msgstr = "ri = "//TRIM(ADJUSTL(msgstr)) + !CALL cp_error_message(cp_warning_level, routineP, msgstr, error) + !WRITE(msgstr,*) ri * invdr + !msgstr = "ri/dr = "//TRIM(ADJUSTL(msgstr)) + !CALL cp_error_message(cp_warning_level, routineP, msgstr, error) + !WRITE(msgstr,*) helium%current_step + !msgstr = "step = "//TRIM(ADJUSTL(msgstr)) + !CALL cp_error_message(cp_warning_level, routineP, msgstr, error) + n_out_of_range = n_out_of_range + 1 + END IF + END DO + END DO + END DO + + IF (.NOT. helium%periodic) THEN + IF (n_out_of_range .GT. 0) THEN + WRITE(msgstr,*) n_out_of_range + msgstr = "Number of bead positions out of range: "//TRIM(ADJUSTL(msgstr)) + CPABORT(msgstr) + END IF + END IF + ! for periodic case we intentionally truncate RDFs to spherical volume + ! so we skip atoms in the corners + + ! normalize the histogram to get g(r) + ! note: helium%density refers to the number of atoms, not the beads + const = 4.0_dp * pi * helium%density / 3.0_dp + DO bin = 1, helium%rdf_nbin + rlower = REAL(bin-1,dp) * helium%rdf_delr + rupper = rlower + helium%rdf_delr + nideal = const * (rupper**3 - rlower**3) + DO id = 1, helium%rdf_num + helium%rdf_inst(id,bin,:) = helium%rdf_inst(id,bin,:) / nideal + END DO + END DO + + DEALLOCATE(incr) + NULLIFY(incr) + + CALL timestop(handle) + + RETURN + END SUBROUTINE helium_calc_rdf + + +! *************************************************************************** +!> \brief Calculate probability distribution of the permutation lengths +!> \param helium ... +!> \date 2010-06-07 +!> \author Lukasz Walewski +!> \note Valid permutation path length is an integer (1, NATOMS), number +!> of paths of a given length is calculated here and average over +!> inner loop iterations and helium environments is done in +!> helium_sample. +! ***************************************************************************** + SUBROUTINE helium_calc_plength( helium ) + + TYPE(helium_solvent_type), POINTER :: helium + + CHARACTER(len=*), PARAMETER :: routineN = 'helium_calc_plength', & + routineP = moduleN//':'//routineN + + INTEGER :: i, j, k + + helium%plength_inst(:) = 0.0_dp + DO i = 1, helium%atoms + j = helium%permutation(i) + k = 1 + DO + IF (j == i) EXIT + k = k + 1 + j = helium%permutation(j) + END DO + helium%plength_inst(k) = helium%plength_inst(k) + 1 + END DO + helium%plength_inst(:) = helium%plength_inst(:) / helium%atoms + + RETURN + END SUBROUTINE helium_calc_plength + + +! *************************************************************************** +!> \brief Rotate helium particles in imaginary time by nslices +!> \param helium ... +!> \param nslices ... +!> \author hforbert +!> \note Positions of helium beads in helium%pos array are reorganized such +!> that the indices are cyclically translated in a permutation-aware +!> manner. helium%relrot is given a new value that represents the new +!> 'angle' of the beads. This is done modulo helium%beads, so relrot +!> should be always within 0 (no rotation) and helium%beads-1 (almost +!> full rotation). [lwalewski] +! ***************************************************************************** + SUBROUTINE helium_rotate(helium, nslices) + TYPE(helium_solvent_type), POINTER :: helium + INTEGER, INTENT(IN) :: nslices + + CHARACTER(len=*), PARAMETER :: routineN = 'helium_rotate', & + routineP = moduleN//':'//routineN + + INTEGER :: b, i, j, k, n + + b = helium%beads + n = helium%atoms + i = MOD(nslices,b) + IF (i < 0) i = i + b + IF ((i>=b).OR.(i<1)) RETURN + helium%relrot = MOD(helium%relrot+i,b) + DO k = 1, i + helium%work(:,:,k) = helium%pos(:,:,k) + END DO + DO k = i+1, b + helium%pos(:,:,k-i) = helium%pos(:,:,k) + END DO + DO k = 1, i + DO j = 1, n + helium%pos(:,j,b-i+k) = helium%work(:,helium%permutation(j),k) + END DO + END DO + RETURN + END SUBROUTINE helium_rotate + + +! *************************************************************************** +!> \brief Calculate the pair-product action or energy by evaluating the +!> power series expansion according to Eq. 4.46 in Ceperley 1995. +!> \param helium ... +!> \param r ... +!> \param rp ... +!> \param tab ... +!> \param cut ... +!> \retval res ... +!> \author Harald Forbert +! ***************************************************************************** + FUNCTION helium_eval_expansion(helium,r,rp,tab,cut) RESULT(res) + + TYPE(helium_solvent_type), POINTER :: helium + REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: r, rp + TYPE(spline_data_p_type), & + DIMENSION(:, :), POINTER :: tab + INTEGER, INTENT(IN) :: cut + REAL(KIND=dp) :: res + + INTEGER :: i, j + REAL(KIND=dp) :: ar, arp, q, s, v, z + REAL(KIND=dp), DIMENSION(3) :: br, brp + + br(:) = r(:) + brp(:) = rp(:) + CALL helium_pbc(helium,br) + CALL helium_pbc(helium,brp) + + ar = SQRT(br(1)**2+br(2)**2+br(3)**2) + arp= SQRT(brp(1)**2+brp(2)**2+brp(3)**2) + q = 0.5_dp*(ar+arp) + + IF (helium%periodic .AND. ((ar > 0.5_dp*helium%cell_size)& + .OR.(arp > 0.5_dp*helium%cell_size))) THEN + v = 0.0_dp + IF (arp>0.5_dp*helium%cell_size) THEN + v = v + REAL(cut,dp)*helium_spline(tab(1,1)%spline_data,0.5_dp*helium%cell_size) + ELSE + v = v + helium_spline(tab(1,1)%spline_data,arp) + END IF + IF (ar>0.5_dp*helium%cell_size) THEN + v = v + REAL(cut,dp)*helium_spline(tab(1,1)%spline_data,0.5_dp*helium%cell_size) + ELSE + v = v + helium_spline(tab(1,1)%spline_data,ar) + END IF + res = 0.5_dp*v + ELSE + ! end-point action (first term): + v = 0.5_dp*(helium_spline(tab(1,1)%spline_data,ar)+helium_spline(tab(1,1)%spline_data,arp)) + DO i = 1, 3 + br(i) = br(i) - brp(i) + END DO + CALL helium_pbc( helium, br ) + s = br(1)**2+br(2)**2+br(3)**2 + z = (ar-arp)**2 + arp = 1.0_dp + ! j=0 terms + DO i = 2, SIZE(tab,1) + arp = arp * s + v = v + arp*helium_spline(tab(i,1)%spline_data,q) + END DO + ar = 1.0_dp + DO j = 2, SIZE(tab,2) + ar = ar * z + arp = ar + DO i = j, SIZE(tab,1) + v = v + arp*helium_spline(tab(i,j)%spline_data,q) + arp = arp * s + END DO + END DO + res = v + END IF + RETURN + END FUNCTION helium_eval_expansion + + +! ***************************************************************************** +!> \brief ... +!> \param helium ... +!> \author Harald Forbert +! ***************************************************************************** + SUBROUTINE helium_update_transition_matrix(helium) + + TYPE(helium_solvent_type), POINTER :: helium + + INTEGER :: b, c, i, j, k, m, n, nb + INTEGER, ALLOCATABLE, DIMENSION(:) :: lens, order + INTEGER, DIMENSION(:), POINTER :: perm + INTEGER, DIMENSION(:, :), POINTER :: nmatrix + REAL(KIND=dp) :: f, q, t, v + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: p + REAL(KIND=dp), DIMENSION(3) :: r + REAL(KIND=dp), DIMENSION(:, :), POINTER :: ipmatrix, pmatrix, tmatrix + REAL(KIND=dp), DIMENSION(:, :, :), & + POINTER :: pos + + nb = helium%atoms + !TODO: check allocation status + ALLOCATE(p(2*nb)) + ALLOCATE(order(nb)) + ALLOCATE(lens(2*nb)) + b = helium%beads-helium%bisection+1 + f = -0.5_dp/(helium%hb2m*helium%tau*helium%bisection) + tmatrix => helium%tmatrix + pmatrix => helium%pmatrix + ipmatrix => helium%ipmatrix + nmatrix => helium%nmatrix + perm => helium%permutation + pos => helium%pos + DO i = 1, nb + DO j = 1, nb + v = 0.0_dp + r(:) = pos(:,i,b) - pos(:,j,1) + CALL helium_pbc( helium, r ) + v = v + r(1)*r(1) + r(2)*r(2) + r(3)*r(3) + pmatrix(i,j) = f*v + END DO + t = pmatrix(i,perm(i)) ! just some reference + v = 0.0_dp + DO j = 1, nb + tmatrix(i,j) = EXP(pmatrix(i,j)-t) + v = v + tmatrix(i,j) + END DO + ! normalize + q = t+LOG(v) + t = 1.0_dp/v + DO j = 1, nb + tmatrix(i,j) = tmatrix(i,j)*t + ipmatrix(i,j) = 1.0_dp/tmatrix(i,j) + END DO + + ! at this point we have: + ! tmatrix(i,j) = exp(-f*(r_i^b - r_j^1)**2) normalized such + ! that sum_j tmatrix(i,j) = 1. + ! ( tmatrix(k1,k2) = t_{k1,k2} / h_{k1} of ceperly. ) + ! so tmatrix(i,j) is the probability to try to change a permutation + ! with particle j (assuming particle i is already selected as well) + ! ipmatrix(i,j) = 1.0/tmatrix(i,j) + ! pmatrix(i,j) = log(tmatrix(i,j)) + some_offset(i) + + ! generate optimal search tree so we can select which particle j + ! belongs to a given random_number as fast as possible. + ! (the traditional approach would be to generate a table + ! of cumulative probabilities and to search that table) + ! so for example if we have: + ! tmatrix(i,:) = ( 0.1 , 0.4 , 0.2 , 0.3 ) + ! traditionally we would build the running sum table: + ! ( 0.1 , 0.5 , 0.7 , 1.0 ) and for a random number r + ! would search this table for the lowest index larger than r + ! (which would then be the particle index chosen by this random number) + ! we build an optimal binary search tree instead, so here + ! we would have: + ! if ( r > 0.6 ) then take index 2, + ! else if ( r > 0.3 ) then take index 4, + ! else if ( r > 0.1 ) then take index 3 else index 1. + ! the search tree is generated in tmatrix and nmatrix. + ! tmatrix contains the decision values (0.6,0.3,0.1 in this case) + ! and nmatrix contains the two branches (what to do if lower or higher) + ! negative numbers in nmatrix mean take minus that index + ! positive number means go down the tree to that next node, since we + ! put the root of the tree at the end the arrays in the example would + ! look like this: + ! tmatrix(i,:) = ( 0.1 , 0.3 , 0.6 , arbitrary ) + ! namtrix(i,:) = ( -1 , -3 , 1 , -4 , 2 , -2 , arb. , arb. ) + ! + ! the way to generate this tree may not be the best, but the + ! tree generation itself shouldn't be needed quite that often: + ! + ! first sort values (with some variant of heap sort) + + DO j = 1, nb + order(j)=j + p(j) = tmatrix(i,j) + END DO + IF (nb > 1) THEN ! if nb = 1 it is already sorted. + k = nb/2+1 + c = nb + DO + IF (k > 1) THEN + ! building up the heap: + k = k - 1 + n = order(k) + v = p(k) + ELSE + ! removing the top of the heap + n = order(c) + v = p(c) + order(c)=order(1) + p(c)=p(1) + c = c - 1 + IF (c == 1) THEN + order(1)=n + p(1)=v + EXIT + END IF + END IF + m = k + j = 2*k + ! restoring heap order between k and c + DO + IF (j > c) EXIT + IF (j < c) THEN + IF (p(j)= p(j)) EXIT + order(m) = order(j) + p(m) = p(j) + m = j + j = 2*j + END DO + order(m) = n + p(m) = v + END DO + END IF + + ! now: + ! p(1:nb) : tmatrix(i,1:nb) sorted in ascending order + ! order(1:nb) : corresponding index: p(j) == tmatrix(i,order(j)) + ! for all j + + ! merge sort with elements as we generate new interior search nodes + ! by combining older elements/nodes + + ! first fill unused part of array with guard values: + DO j = nb+1, 2*nb + p(j)=2.0_dp + END DO + + ! j - head of leaf queue + ! c+1 - head of node queue in p (c in lens) + ! m+1 - tail of node queue in p (m in lens) + c = nb+1 + j = 1 + DO m = nb+1, 2*nb-1 + ! get next smallest element + IF (p(j) < p(c+1)) THEN + v = p(j) + lens(j) = m + j = j + 1 + ELSE + v = p(c+1) + lens(c) = m + c = c + 1 + END IF + ! get the second next smallest element + IF (p(j) < p(c+1)) THEN + p(m+1) = v+p(j) + lens(j) = m + j = j + 1 + ELSE + p(m+1) = v+p(c+1) + lens(c) = m + c = c + 1 + END IF + END DO + + ! lens(:) now has the tree with lens(j) pointing to its parent + ! the root of the tree is at 2*nb-1 + ! calculate the depth of each node in the tree now: (root = 0) + + lens(2*nb-1) = 0 + DO m = 2*nb-2, 1, -1 + lens(m) = lens(lens(m))+1 + END DO + + ! lens(:) now has the depths of the nodes/leafs + +#if 0 + ! calculate average search depth (for information only) + v = 0.0_dp + DO j = 1, nb + v = v + p(j)*lens(j) + END DO + PRINT *,"Expected number of comparisons with i=",i,v +#endif + + ! reset the nodes, for the canonical tree we just need the leaf info + DO j = 1, nb + lens(j+nb)=0 + p(j+nb) = 0.0_dp + END DO + + ! build the canonical tree (number of decisions on average are + ! the same to the tree we build above, but it has better caching behavior + + ! c head of leafs + ! m head of interior nodes + c = 1 + m = nb+1 + DO k = 1, 2*nb-2 + j = nb+1+(k-1)/2 + IF (lens(c)>lens(m+1)) THEN + nmatrix(i,k) = -order(c) + lens(j+1) = lens(c)-1 + v = p(c) + c = c + 1 + ELSE + nmatrix(i,k) = m-nb + lens(j+1) = lens(m+1)-1 + v = p(m) + m = m + 1 + END IF + p(j) = p(j) + v + IF (MOD(k,2)==1) tmatrix(i,j-nb)=v + END DO + + ! now: + ! nmatrix(i,2*j+1) left child of node j + ! nmatrix(i,2*j+2) right child of node j + ! children: + ! negative : leaf with particle index == abs(value) + ! positive : child node index + ! p(j) weight of leaf j + ! p(nb+j) weight of node j + ! tmatrix(i,j) weight of left child of node j + + ! fix offsets for decision tree: + + p(nb-1)=0.0_dp + DO m = nb-1,1,-1 + ! if right child is a node, set its offset and + ! change its decision value + IF (nmatrix(i,2*m)>0) THEN + p(nmatrix(i,2*m)) = tmatrix(i,m) + tmatrix(i,nmatrix(i,2*m)) = tmatrix(i,nmatrix(i,2*m))+tmatrix(i,m) + END IF + ! if left child is a node, set its offset and + ! change its decision value + IF (nmatrix(i,2*m-1)>0) THEN + p(nmatrix(i,2*m-1)) = p(m) + tmatrix(i,nmatrix(i,2*m-1)) = tmatrix(i,nmatrix(i,2*m-1)) + p(m) + END IF + END DO + + ! canonical optimal search tree done + +#if 0 + !some test code, to check if it gives the right distribution + DO k = 1, nb + p(k)=1.0/ipmatrix(i,k) + END DO + lens(:)=0 + ! number of random numbers to generate: + c = 1000000000 + DO j=1, c + v = next_random_number(helium%rng_stream_uniform) + ! walk down the search tree: + k = nb-1 + DO + IF (tmatrix(i,k) > v) THEN + k = nmatrix(i,2*k-1) + ELSE + k = nmatrix(i,2*k) + END IF + IF (k<0) EXIT + END DO + k = -k + ! increment the counter for this particle index + lens(k) = lens(k)+1 + END DO + ! search for maximum deviation from expectation value + ! (relative to the expected variance) + v = 0.0_dp + k = -1 + DO j = 1, nb + q = ABS((lens(j)-c*p(j))/SQRT(c*p(j))) + !PRINT *,j,lens(j),c*p(j) + IF (q > v) THEN + v = q + k = j + END IF + !PRINT *,lens(j),c*p(j),(lens(j)-c*p(j))/sqrt(c*p(j)) + END DO + PRINT *,"MAXDEV:",k,lens(k),c*p(k),v + !PRINT *,"TMAT:",tmatrix(i,:) + !PRINT *,"NMAT:",nmatrix(i,:) + !STOP +#endif +#if 0 + !additional test code: + p(:) = -1.0_dp + p(nb-1) = 0.0_dp + p(2*nb-1) = 1.0_dp + DO j = nb-1, 1, -1 + ! right child + IF (nmatrix(i,2*j) > 0) THEN + c = nmatrix(i,2*j) + p(c) = tmatrix(i,j) + p(c+nb) = p(j+nb) + ELSE + c = -nmatrix(i,2*j) + !PRINT *,c,1.0/ipmatrix(i,c),p(j+nb)-tmatrix(i,j) + IF (ABS(1.0/ipmatrix(i,c)-(p(j+nb)-tmatrix(i,j))) > & + 10.0_dp*EPSILON(1.0_dp)) THEN + PRINT *,"Probability mismatch for particle i->j",i,c + PRINT *,"Got",p(j+nb)-tmatrix(i,j),"should be",1.0/ipmatrix(i,c) + STOP + END IF + END IF + ! left child + IF (nmatrix(i,2*j-1) > 0) THEN + c = nmatrix(i,2*j-1) + p(c+nb) = tmatrix(i,j) + p(c) = p(j) + ELSE + c = -nmatrix(i,2*j-1) + !PRINT *,c,1.0/ipmatrix(i,c),tmatrix(i,j)-p(j) + IF (ABS(1.0/ipmatrix(i,c)-(tmatrix(i,j)-p(j))) > & + 10.0_dp*EPSILON(1.0_dp)) THEN + PRINT *,"Probability mismatch for particle i->j",i,c + PRINT *,"Got",tmatrix(i,j)-p(j),"should be",1.0/ipmatrix(i,c) + STOP + END IF + END IF + END DO + PRINT *,"Probabilities ok" +#endif + + END DO + + ! initialize trial permutation with some identity permutation + ! (should not be taken, but just in case it does we have something valid) + + helium%pweight = 0.0_dp + t = next_random_number(helium%rng_stream_uniform) + helium%ptable(1) = 1+INT(t*nb) + helium%ptable(2) = -1 + + ! recalculate inverse permutation table (just in case) + DO i = 1, nb + helium%iperm(perm(i))=i + END DO + + ! clean up: + DEALLOCATE(lens) + DEALLOCATE(order) + DEALLOCATE(p) + + RETURN + END SUBROUTINE helium_update_transition_matrix + + +! ***************************************************************************** +!> \brief ... +!> \param spl ... +!> \param xx ... +!> \retval res ... +!> \author Harald Forbert +! ***************************************************************************** + FUNCTION helium_spline(spl, xx) RESULT(res) + TYPE(spline_data_type), POINTER :: spl + REAL(KIND=dp), INTENT(IN) :: xx + REAL(KIND=dp) :: res + + REAL(KIND=dp) :: a, b + + IF (xx < spl%x1) THEN + b = spl%invh*(xx-spl%x1) + a = 1.0_dp-b + res = a*spl%y(1)+b*(spl%y(2)-spl%y2(2)*spl%h26) + ELSE IF (xx > spl%xn) THEN + b = spl%invh*(xx-spl%xn)+1.0_dp + a = 1.0_dp-b + res = b*spl%y(spl%n)+a*(spl%y(spl%n-1)-spl%y2(spl%n-1)*spl%h26) + ELSE + res = spline_value(spl,xx) + END IF + RETURN + END FUNCTION helium_spline + + +! *************************************************************************** +!> \brief Return the distance between bead of atom +!> and bead of atom . +!> \param helium ... +!> \param ia ... +!> \param ib ... +!> \param ja ... +!> \param jb ... +!> \retval rij ... +!> \date 2009-07-17 +!> \author Lukasz Walewski +! ***************************************************************************** + FUNCTION helium_bead_rij(helium, ia, ib, ja, jb) RESULT(rij) + + TYPE(helium_solvent_type), POINTER :: helium + INTEGER, INTENT(IN) :: ia, ib, ja, jb + REAL(KIND=dp) :: rij + + REAL(KIND=dp) :: dx, dy, dz + + dx = helium%pos(1,ia,ib) - helium%pos(1,ja,jb) + dy = helium%pos(2,ia,ib) - helium%pos(2,ja,jb) + dz = helium%pos(3,ia,ib) - helium%pos(3,ja,jb) + rij = SQRT(dx*dx+dy*dy+dz*dz) + + RETURN + END FUNCTION helium_bead_rij + + +! *************************************************************************** +!> \brief Given the atom number and permutation state return the cycle +!> number the atom belongs to. +!> \param helium ... +!> \param atom_number ... +!> \param permutation ... +!> \retval cycle_number ... +!> \date 2009-07-21 +!> \author Lukasz Walewski +!> \note Cycles (or paths) are numbered from 1 to , where +!> is in the range of (1, ). +!> if (num_cycles .EQ. 1) then all atoms belong to one cycle +!> if (num_cycles .EQ. helium%atoms) then there are no cycles of +!> length greater than 1 (i.e. no atoms are connected) +! ***************************************************************************** + FUNCTION helium_cycle_number(helium, atom_number, permutation) RESULT(cycle_number) + + TYPE(helium_solvent_type), POINTER :: helium + INTEGER, INTENT(IN) :: atom_number + INTEGER, DIMENSION(:), POINTER :: permutation + INTEGER :: cycle_number + + INTEGER :: atom_idx, cycle_idx, & + cycle_num, ia, ib, ic, & + num_cycles + INTEGER, DIMENSION(:), POINTER :: cycle_index + LOGICAL :: found, new_cycle + + NULLIFY(cycle_index) + cycle_index => helium%itmp_atoms_1d + cycle_index(:) = 0 + + num_cycles = 0 + found = .FALSE. + cycle_num = -1 + DO ia = 1, helium%atoms + ! this loop reaches its maximum iteration count when atom in question + ! is the last one (i.e. when atom_number .EQ. helium%atoms) + + ! exit if we have found the cycle number for the atom in question + IF (found) THEN + EXIT + END IF + + ! initialize current cycle index with the current atom + cycle_idx = ia + + atom_idx = ia + DO ib = 1, helium%atoms * helium%beads + ! this loop reaches its maximum iteration count when all He atoms + ! form one cycle (i.e. all beads belong to one path) + + ! proceed along the path + atom_idx = permutation(atom_idx) + + IF (atom_idx .EQ. ia) THEN + ! end of cycle detected (looped back to the first atom) + + ! check if this is a new cycle + new_cycle = .TRUE. + DO ic = 1, num_cycles + IF (cycle_index(ic) .EQ. cycle_idx) THEN + new_cycle = .FALSE. + END IF + END DO + + IF (new_cycle) THEN + ! increase number of cycles and update the current cycle's index + num_cycles = num_cycles + 1 + cycle_index(num_cycles) = cycle_idx + END IF + + ! if this was the atom in question + IF (ia .EQ. atom_number) THEN + ! save the cycle index it belongs to + cycle_num = cycle_idx + + ! exit the loop over atoms, we've found what we've been looking for + found = .TRUE. + END IF + + ! exit the loop over beads, there are no more (new) beads in this cycle + EXIT + END IF + + ! set the cycle index to the lowest atom index in this cycle + IF (atom_idx .LT. cycle_idx) THEN + cycle_idx = atom_idx + END IF + + END DO + + END DO + +!TODO make it cp2k way + IF (.NOT. found) THEN + CPWARN("helium_cycle_number: we are going to return -1, problems ahead!") + END IF + + ! at this point we know the cycle index for atom + ! but it is expressed as the atom number of the first atom in that cycle + + ! renumber cycle indices, so that they form a range (1, ) + ! (don't do it actually - just return the requested ) + cycle_number = 0 + DO ic = 1, num_cycles + IF (cycle_index(ic) .EQ. cycle_num) THEN + cycle_number = ic + EXIT + END IF + END DO + + NULLIFY(cycle_index) + + RETURN + END FUNCTION helium_cycle_number + + +! *************************************************************************** +!> \brief Given the atom number and permutation state return the length of +!> the path this atom belongs to. +!> \param helium ... +!> \param atom_number ... +!> \param permutation ... +!> \retval path_length ... +!> \date 2009-10-07 +!> \author Lukasz Walewski +! ***************************************************************************** + FUNCTION helium_path_length(helium, atom_number, permutation) RESULT(path_length) + + TYPE(helium_solvent_type), POINTER :: helium + INTEGER, INTENT(IN) :: atom_number + INTEGER, DIMENSION(:), POINTER :: permutation + INTEGER :: path_length + + INTEGER :: atom_idx, ia + LOGICAL :: path_end_reached + + atom_idx = atom_number + path_length = 0 + path_end_reached = .FALSE. + DO ia = 1, helium%atoms + path_length = path_length + 1 + atom_idx = permutation(atom_idx) + IF ( atom_idx .EQ. atom_number ) THEN + path_end_reached = .TRUE. + EXIT + END IF + END DO + + IF ( .NOT. path_end_reached ) THEN + path_length = -1 + END IF + + RETURN + END FUNCTION helium_path_length + + +! *************************************************************************** +!> \brief Given an element of a permutation return the cycle it belongs to. +!> \param element ... +!> \param permutation ... +!> \retval CYCLE ... +!> \date 2013-12-10 +!> \author Lukasz Walewski +!> \note This function allocates memory and returns a pointer to it, +!> do not forget to deallocate once finished with the results. +! ***************************************************************************** + FUNCTION helium_cycle_of(element, permutation) RESULT(CYCLE) + + INTEGER, INTENT(IN) :: element + INTEGER, DIMENSION(:), INTENT(IN), & + POINTER :: permutation + INTEGER, DIMENSION(:), POINTER :: CYCLE + + INTEGER :: ia, icur, len, nsize + CHARACTER(len=*), PARAMETER :: routineN = 'helium_cycle_of', & + routineP = moduleN//':'//routineN + + INTEGER, DIMENSION(:), POINTER :: my_cycle + LOGICAL :: cycle_end_reached + + nsize = SIZE(permutation) + + ! maximum possible cycle length is the number of atoms + NULLIFY(my_cycle) + ALLOCATE(my_cycle(nsize)) + + ! traverse the permutation table + len = 0 + icur = element + cycle_end_reached = .FALSE. + DO ia = 1, nsize + len = len + 1 + my_cycle(len) = icur + icur = permutation(icur) + IF ( icur .EQ. element ) THEN + cycle_end_reached = .TRUE. + EXIT + END IF + END DO + + IF (.NOT. cycle_end_reached) THEN + ! return null + NULLIFY(CYCLE) + ELSE + ! assign the result + ALLOCATE(CYCLE(len)) + CYCLE(1:len) = my_cycle(1:len) + END IF + + ! clean up + DEALLOCATE(my_cycle) + NULLIFY(my_cycle) + + RETURN + END FUNCTION helium_cycle_of + + +! *************************************************************************** +!> \brief Return total winding number +!> \param helium ... +!> \retval wnum ... +!> \date 2014-04-24 +!> \author Lukasz Walewski +! ***************************************************************************** + FUNCTION helium_total_winding_number(helium) RESULT(wnum) + + TYPE(helium_solvent_type), POINTER :: helium + REAL(KIND=dp), DIMENSION(3) :: wnum + + CHARACTER(len=*), PARAMETER :: routineN = 'helium_total_winding_number', & + routineP = moduleN//':'//routineN + + INTEGER :: ia, ib + REAL(KIND=dp), DIMENSION(3) :: rcur + REAL(KIND=dp), DIMENSION(:), POINTER :: ri, rj + + wnum(:) = 0.0_dp + DO ia = 1, helium%atoms + ! sum of contributions from the rest of bead pairs + DO ib = 1, helium%beads-1 + ri => helium%pos(:,ia,ib) + rj => helium%pos(:,ia,ib+1) + rcur(:) = ri(:) - rj(:) + CALL helium_pbc(helium,rcur) + wnum(:) = wnum(:) + rcur(:) + END DO + ! contribution from the last and the first bead + ri => helium%pos(:,ia,helium%beads) + rj => helium%pos(:,helium%permutation(ia),1) + rcur(:) = ri(:) - rj(:) + CALL helium_pbc(helium,rcur) + wnum(:) = wnum(:) + rcur(:) + END DO + + END FUNCTION helium_total_winding_number + + +! *************************************************************************** +!> \brief Return link winding number +!> \param helium ... +!> \param ia ... +!> \param ib ... +!> \retval wnum ... +!> \date 2014-04-24 +!> \author Lukasz Walewski +! ***************************************************************************** + FUNCTION helium_link_winding_number(helium,ia,ib) RESULT(wnum) + + TYPE(helium_solvent_type), POINTER :: helium + INTEGER :: ia, ib + REAL(KIND=dp), DIMENSION(3) :: wnum + + CHARACTER(len=*), PARAMETER :: routineN = 'helium_link_winding_number', & + routineP = moduleN//':'//routineN + + INTEGER :: ja1, ja2, jb1, jb2 + REAL(KIND=dp), DIMENSION(:), POINTER :: r1, r2 + + IF (ib .EQ. helium%beads) THEN + ja1 = ia + ja2 = helium%permutation(ia) + jb1 = ib + jb2 = 1 + ELSE + ja1 = ia + ja2 = ia + jb1 = ib + jb2 = ib+1 + END IF + r1 => helium%pos(:,ja1,jb1) + r2 => helium%pos(:,ja2,jb2) + wnum(:) = r1(:) - r2(:) + CALL helium_pbc(helium,wnum) + + RETURN + END FUNCTION helium_link_winding_number + + +! *************************************************************************** +!> \brief Return total winding number (sum over all links) +!> \param helium ... +!> \retval wnum ... +!> \date 2014-04-24 +!> \author Lukasz Walewski +!> \note mostly for sanity checks +! ***************************************************************************** + FUNCTION helium_total_winding_number_linkwise(helium) RESULT(wnum) + + TYPE(helium_solvent_type), POINTER :: helium + REAL(KIND=dp), DIMENSION(3) :: wnum + + CHARACTER(len=*), PARAMETER :: & + routineN = 'helium_total_winding_number_linkwise', & + routineP = moduleN//':'//routineN + + INTEGER :: ia, ib + + wnum(:) = 0.0_dp + DO ia = 1, helium%atoms + DO ib = 1, helium%beads + wnum(:) = wnum(:) + helium_link_winding_number(helium,ia,ib) + END DO + END DO + + RETURN + END FUNCTION helium_total_winding_number_linkwise + + +! *************************************************************************** +!> \brief Return cycle winding number +!> \param helium ... +!> \param CYCLE ... +!> \param pos ... +!> \retval wnum ... +!> \date 2014-04-24 +!> \author Lukasz Walewski +! ***************************************************************************** + FUNCTION helium_cycle_winding_number(helium,CYCLE,pos) RESULT(wnum) + + TYPE(helium_solvent_type), POINTER :: helium + INTEGER, DIMENSION(:), POINTER :: CYCLE + REAL(KIND=dp), DIMENSION(:, :, :), & + POINTER :: pos + REAL(KIND=dp), DIMENSION(3) :: wnum + + CHARACTER(len=*), PARAMETER :: routineN = 'helium_cycle_winding_number', & + routineP = moduleN//':'//routineN + + INTEGER :: i1, i2, ia, ib, nsize + REAL(KIND=dp), DIMENSION(3) :: rcur + REAL(KIND=dp), DIMENSION(:), POINTER :: ri, rj + + nsize = SIZE(CYCLE) + + ! traverse the path + wnum(:) = 0.0_dp + DO ia = 1, nsize + ! contributions from all bead pairs of the current atom + DO ib = 1, helium%beads-1 + ri => pos(:,CYCLE(ia),ib) + rj => pos(:,CYCLE(ia),ib+1) + rcur(:) = ri(:) - rj(:) + CALL helium_pbc( helium, rcur ) + wnum(:) = wnum(:) + rcur(:) + END DO + ! contribution from the last bead of the current atom + ! and the first bead of the next atom + i1 = CYCLE(ia) + IF (ia .EQ. nsize) THEN + i2 = CYCLE(1) + ELSE + i2 = CYCLE(ia+1) + END IF + ri => pos(:,i1,helium%beads) + rj => pos(:,i2,1) + rcur(:) = ri(:) - rj(:) + CALL helium_pbc( helium, rcur ) + wnum(:) = wnum(:) + rcur(:) + END DO + + RETURN + END FUNCTION helium_cycle_winding_number + + +! *************************************************************************** +!> \brief Return total winding number (sum over all cycles) +!> \param helium ... +!> \retval wnum ... +!> \date 2014-04-24 +!> \author Lukasz Walewski +!> \note mostly for sanity checks +! ***************************************************************************** + FUNCTION helium_total_winding_number_cyclewise(helium) RESULT(wnum) + + TYPE(helium_solvent_type), POINTER :: helium + REAL(KIND=dp), DIMENSION(3) :: wnum + + CHARACTER(len=*), PARAMETER :: & + routineN = 'helium_total_winding_number_cyclewise', & + routineP = moduleN//':'//routineN + + INTEGER :: ic + REAL(KIND=dp), DIMENSION(3) :: wn + TYPE(int_arr_ptr), DIMENSION(:), POINTER :: cycles + +! decompose the current permutation state into permutation cycles + + NULLIFY(cycles) + cycles => helium_calc_cycles(helium%permutation) + + wnum(:) = 0.0_dp + DO ic = 1, SIZE(cycles) + wn = helium_cycle_winding_number(helium,cycles(ic)%iap,helium%pos) + wnum(:) = wnum(:) + wn(:) + END DO + + DEALLOCATE(cycles) + + RETURN + END FUNCTION helium_total_winding_number_cyclewise + + +! *************************************************************************** +!> \brief Return total projected area +!> \param helium ... +!> \retval area ... +!> \date 2014-04-24 +!> \author Lukasz Walewski +! ***************************************************************************** + FUNCTION helium_total_projected_area(helium) RESULT(area) + + TYPE(helium_solvent_type), POINTER :: helium + REAL(KIND=dp), DIMENSION(3) :: area + + CHARACTER(len=*), PARAMETER :: routineN = 'helium_total_projected_area', & + routineP = moduleN//':'//routineN + + INTEGER :: ia, ib + REAL(KIND=dp), DIMENSION(3) :: r1, r12, r2, rcur + + area(:) = 0.0_dp + DO ia = 1, helium%atoms + ! contributions from all links of the current atom + DO ib = 1, helium%beads-1 + r1(:) = helium%pos(:,ia,ib) + r2(:) = helium%pos(:,ia,ib+1) + ! comment out for non-PBC version --> + r12(:) = r2(:) - r1(:) + CALL helium_pbc(helium,r1) + CALL helium_pbc(helium,r12) + r2(:) = r1(:) + r12(:) + ! comment out for non-PBC version <-- + rcur(1) = r1(2)*r2(3)-r1(3)*r2(2) + rcur(2) = r1(3)*r2(1)-r1(1)*r2(3) + rcur(3) = r1(1)*r2(2)-r1(2)*r2(1) + area(:) = area(:) + rcur(:) + END DO + ! contribution from the last bead of the current atom + ! and the first bead of the next atom + r1(:) = helium%pos(:,ia,helium%beads) + r2(:) = helium%pos(:,helium%permutation(ia),1) + ! comment out for non-PBC version --> + r12(:) = r2(:) - r1(:) + CALL helium_pbc(helium,r1) + CALL helium_pbc(helium,r12) + r2(:) = r1(:) + r12(:) + ! comment out for non-PBC version <-- + rcur(1) = r1(2)*r2(3)-r1(3)*r2(2) + rcur(2) = r1(3)*r2(1)-r1(1)*r2(3) + rcur(3) = r1(1)*r2(2)-r1(2)*r2(1) + area(:) = area(:) + rcur(:) + END DO + area(:) = 0.5_dp * area(:) + + RETURN + END FUNCTION helium_total_projected_area + + +! *************************************************************************** +!> \brief Return link projected area +!> \param helium ... +!> \param ia ... +!> \param ib ... +!> \retval area ... +!> \date 2014-04-24 +!> \author Lukasz Walewski +! ***************************************************************************** + FUNCTION helium_link_projected_area(helium,ia,ib) RESULT(area) + + TYPE(helium_solvent_type), POINTER :: helium + INTEGER :: ia, ib + REAL(KIND=dp), DIMENSION(3) :: area + + CHARACTER(len=*), PARAMETER :: routineN = 'helium_link_projected_area', & + routineP = moduleN//':'//routineN + + INTEGER :: ja1, ja2, jb1, jb2 + REAL(KIND=dp), DIMENSION(3) :: r1, r12, r2 + + IF (ib .EQ. helium%beads) THEN + ja1 = ia + ja2 = helium%permutation(ia) + jb1 = ib + jb2 = 1 + ELSE + ja1 = ia + ja2 = ia + jb1 = ib + jb2 = ib+1 + END IF + r1(:) = helium%pos(:,ja1,jb1) + r2(:) = helium%pos(:,ja2,jb2) + ! comment out for non-PBC version --> + r12(:) = r2(:) - r1(:) + CALL helium_pbc(helium,r1) + CALL helium_pbc(helium,r12) + r2(:) = r1(:) + r12(:) + ! comment out for non-PBC version <-- + area(1) = r1(2)*r2(3)-r1(3)*r2(2) + area(2) = r1(3)*r2(1)-r1(1)*r2(3) + area(3) = r1(1)*r2(2)-r1(2)*r2(1) + area(:) = 0.5_dp * area(:) + + RETURN + END FUNCTION helium_link_projected_area + + +! *************************************************************************** +!> \brief Return total projected area (sum over all links) +!> \param helium ... +!> \retval area ... +!> \date 2014-04-24 +!> \author Lukasz Walewski +!> \note mostly for sanity checks +! ***************************************************************************** + FUNCTION helium_total_projected_area_linkwise(helium) RESULT(area) + + TYPE(helium_solvent_type), POINTER :: helium + REAL(KIND=dp), DIMENSION(3) :: area + + CHARACTER(len=*), PARAMETER :: & + routineN = 'helium_total_projected_area_linkwise', & + routineP = moduleN//':'//routineN + + INTEGER :: ia, ib + + area(:) = 0.0_dp + DO ia = 1, helium%atoms + DO ib = 1, helium%beads + area(:) = area(:) + helium_link_projected_area(helium,ia,ib) + END DO + END DO + + END FUNCTION helium_total_projected_area_linkwise + + +! *************************************************************************** +!> \brief Return cycle projected area +!> \param helium ... +!> \param CYCLE ... +!> \retval area ... +!> \date 2014-04-24 +!> \author Lukasz Walewski +! ***************************************************************************** + FUNCTION helium_cycle_projected_area(helium,CYCLE) RESULT(area) + + TYPE(helium_solvent_type), POINTER :: helium + INTEGER, DIMENSION(:), POINTER :: CYCLE + REAL(KIND=dp), DIMENSION(3) :: area + + CHARACTER(len=*), PARAMETER :: routineN = 'helium_cycle_projected_area', & + routineP = moduleN//':'//routineN + + INTEGER :: i1, i2, ia, ib, nsize + REAL(KIND=dp), DIMENSION(3) :: rcur, rsum + REAL(KIND=dp), DIMENSION(:), POINTER :: ri, rj + + nsize = SIZE(CYCLE) + + ! traverse the path + rsum(:) = 0.0_dp + DO ia = 1, nsize + ! contributions from all bead pairs of the current atom + DO ib = 1, helium%beads-1 + ri => helium%pos(:,CYCLE(ia),ib) + rj => helium%pos(:,CYCLE(ia),ib+1) + rcur(1) = ri(2)*rj(3)-ri(3)*rj(2) + rcur(2) = ri(3)*rj(1)-ri(1)*rj(3) + rcur(3) = ri(1)*rj(2)-ri(2)*rj(1) + rsum(:) = rsum(:) + rcur(:) + END DO + ! contribution from the last bead of the current atom + ! and the first bead of the next atom + i1 = CYCLE(ia) + IF (ia .EQ. nsize) THEN + i2 = CYCLE(1) + ELSE + i2 = CYCLE(ia+1) + END IF + ri => helium%pos(:,i1,helium%beads) + rj => helium%pos(:,i2,1) + rcur(1) = ri(2)*rj(3)-ri(3)*rj(2) + rcur(2) = ri(3)*rj(1)-ri(1)*rj(3) + rcur(3) = ri(1)*rj(2)-ri(2)*rj(1) + rsum(:) = rsum(:) + rcur(:) + END DO + area(:) = 0.5_dp * rsum(:) + + RETURN + END FUNCTION helium_cycle_projected_area + + +! *************************************************************************** +!> \brief Return cycle projected area (sum over all links) +!> \param helium ... +!> \param CYCLE ... +!> \retval area ... +!> \date 2014-04-24 +!> \author Lukasz Walewski +!> \note mostly for sanity checks +! ***************************************************************************** + FUNCTION helium_cycle_projected_area_pbc(helium,CYCLE) RESULT(area) + + TYPE(helium_solvent_type), POINTER :: helium + INTEGER, DIMENSION(:), POINTER :: CYCLE + REAL(KIND=dp), DIMENSION(3) :: area + + CHARACTER(len=*), PARAMETER :: & + routineN = 'helium_cycle_projected_area_pbc', & + routineP = moduleN//':'//routineN + + INTEGER :: i1, i2, ia, ib, nsize + REAL(KIND=dp), DIMENSION(3) :: r1, r12, r2, rcur + + nsize = SIZE(CYCLE) + + ! traverse the path + area(:) = 0.0_dp + DO ia = 1, nsize + ! contributions from all bead pairs of the current atom + DO ib = 1, helium%beads-1 + r1(:) = helium%pos(:,CYCLE(ia),ib) + r2(:) = helium%pos(:,CYCLE(ia),ib+1) + r12(:) = r2(:) - r1(:) + CALL helium_pbc(helium,r1) + CALL helium_pbc(helium,r12) + r2(:) = r1(:) + r12(:) + rcur(1) = r1(2)*r2(3)-r1(3)*r2(2) + rcur(2) = r1(3)*r2(1)-r1(1)*r2(3) + rcur(3) = r1(1)*r2(2)-r1(2)*r2(1) + area(:) = area(:) + rcur(:) + END DO + ! contribution from the last bead of the current atom + ! and the first bead of the next atom + i1 = CYCLE(ia) + IF (ia .EQ. nsize) THEN + i2 = CYCLE(1) + ELSE + i2 = CYCLE(ia+1) + END IF + r1(:) = helium%pos(:,i1,helium%beads) + r2(:) = helium%pos(:,i2,1) + r12(:) = r2(:) - r1(:) + CALL helium_pbc(helium,r1) + CALL helium_pbc(helium,r12) + r2(:) = r1(:) + r12(:) + rcur(1) = r1(2)*r2(3)-r1(3)*r2(2) + rcur(2) = r1(3)*r2(1)-r1(1)*r2(3) + rcur(3) = r1(1)*r2(2)-r1(2)*r2(1) + area(:) = area(:) + rcur(:) + END DO + area(:) = 0.5_dp * area(:) + + RETURN + END FUNCTION helium_cycle_projected_area_pbc + + +! *************************************************************************** +!> \brief Return total projected area (sum over all cycles) +!> \param helium ... +!> \retval area ... +!> \date 2014-04-24 +!> \author Lukasz Walewski +!> \note mostly for sanity checks +! ***************************************************************************** + FUNCTION helium_total_projected_area_cyclewise(helium) RESULT(area) + + TYPE(helium_solvent_type), POINTER :: helium + REAL(KIND=dp), DIMENSION(3) :: area + + CHARACTER(len=*), PARAMETER :: & + routineN = 'helium_total_projected_area_cyclewise', & + routineP = moduleN//':'//routineN + + INTEGER :: ic + REAL(KIND=dp), DIMENSION(3) :: pa + TYPE(int_arr_ptr), DIMENSION(:), POINTER :: cycles + +! decompose the current permutation state into permutation cycles + + NULLIFY(cycles) + cycles => helium_calc_cycles(helium%permutation) + + area(:) = 0.0_dp + DO ic = 1, SIZE(cycles) + pa = helium_cycle_projected_area(helium,cycles(ic)%iap) + area(:) = area(:) + pa(:) + END DO + + RETURN + END FUNCTION helium_total_projected_area_cyclewise + + +! *************************************************************************** +!> \brief Return total moment of inertia divided by m_He +!> \param helium ... +!> \retval moit ... +!> \date 2014-04-24 +!> \author Lukasz Walewski +! ***************************************************************************** + FUNCTION helium_total_moment_of_inertia(helium) RESULT(moit) + + TYPE(helium_solvent_type), POINTER :: helium + REAL(KIND=dp), DIMENSION(3) :: moit + + CHARACTER(len=*), PARAMETER :: & + routineN = 'helium_total_moment_of_inertia', & + routineP = moduleN//':'//routineN + + INTEGER :: ia, ib + REAL(KIND=dp), DIMENSION(3) :: com, r1, r12, r2, rcur + + com(:) = helium%center(:) + + moit(:) = 0.0_dp + DO ia = 1, helium%atoms + ! contributions from all the links of the current atom + DO ib = 1, helium%beads-1 + r1(:) = helium%pos(:,ia,ib) - com(:) + r2(:) = helium%pos(:,ia,ib+1) - com(:) + ! comment out for non-PBC version --> + r12(:) = r2(:) - r1(:) + CALL helium_pbc(helium,r1) + CALL helium_pbc(helium,r12) + r2(:) = r1(:) + r12(:) + ! comment out for non-PBC version <-- + rcur(1) = r1(2)*r2(2)+r1(3)*r2(3) + rcur(2) = r1(3)*r2(3)+r1(1)*r2(1) + rcur(3) = r1(1)*r2(1)+r1(2)*r2(2) + moit(:) = moit(:) + rcur(:) + END DO + ! contribution from the last bead of the current atom + ! and the first bead of the next atom + r1(:) = helium%pos(:,ia,helium%beads) - com(:) + r2(:) = helium%pos(:,helium%permutation(ia),1) - com(:) + ! comment out for non-PBC version --> + r12(:) = r2(:) - r1(:) + CALL helium_pbc(helium,r1) + CALL helium_pbc(helium,r12) + r2(:) = r1(:) + r12(:) + ! comment out for non-PBC version <-- + rcur(1) = r1(2)*r2(2)+r1(3)*r2(3) + rcur(2) = r1(3)*r2(3)+r1(1)*r2(1) + rcur(3) = r1(1)*r2(1)+r1(2)*r2(2) + moit(:) = moit(:) + rcur(:) + END DO + moit(:) = moit(:) / helium%beads + + RETURN + END FUNCTION helium_total_moment_of_inertia + + +! *************************************************************************** +!> \brief Return link moment of inertia divided by m_He +!> \param helium ... +!> \param ia ... +!> \param ib ... +!> \retval moit ... +!> \date 2014-04-24 +!> \author Lukasz Walewski +! ***************************************************************************** + FUNCTION helium_link_moment_of_inertia(helium,ia,ib) RESULT(moit) + + TYPE(helium_solvent_type), POINTER :: helium + INTEGER :: ia, ib + REAL(KIND=dp), DIMENSION(3) :: moit + + CHARACTER(len=*), PARAMETER :: & + routineN = 'helium_link_moment_of_inertia', & + routineP = moduleN//':'//routineN + + INTEGER :: ja1, ja2, jb1, jb2 + REAL(KIND=dp), DIMENSION(3) :: com, r1, r12, r2 + + com(:) = helium%center(:) + + IF (ib .EQ. helium%beads) THEN + ja1 = ia + ja2 = helium%permutation(ia) + jb1 = ib + jb2 = 1 + ELSE + ja1 = ia + ja2 = ia + jb1 = ib + jb2 = ib+1 + END IF + r1(:) = helium%pos(:,ja1,jb1) - com(:) + r2(:) = helium%pos(:,ja2,jb2) - com(:) + ! comment out for non-PBC version --> + r12(:) = r2(:) - r1(:) + CALL helium_pbc(helium,r1) + CALL helium_pbc(helium,r12) + r2(:) = r1(:) + r12(:) + ! comment out for non-PBC version <-- + moit(1) = r1(2)*r2(2)+r1(3)*r2(3) + moit(2) = r1(3)*r2(3)+r1(1)*r2(1) + moit(3) = r1(1)*r2(1)+r1(2)*r2(2) + moit(:) = moit(:) / helium%beads + + RETURN + END FUNCTION helium_link_moment_of_inertia + + +! *************************************************************************** +!> \brief Return total moment of inertia (sum over all links) +!> \param helium ... +!> \retval moit ... +!> \date 2014-04-24 +!> \author Lukasz Walewski +!> \note mostly for sanity checks +! ***************************************************************************** + FUNCTION helium_total_moment_of_inertia_linkwise(helium) RESULT(moit) + + TYPE(helium_solvent_type), POINTER :: helium + REAL(KIND=dp), DIMENSION(3) :: moit + + CHARACTER(len=*), PARAMETER :: & + routineN = 'helium_total_moment_of_inertia_linkwise', & + routineP = moduleN//':'//routineN + + INTEGER :: ia, ib + + moit(:) = 0.0_dp + DO ia = 1, helium%atoms + DO ib = 1, helium%beads + moit(:) = moit(:) + helium_link_moment_of_inertia(helium,ia,ib) + END DO + END DO + + END FUNCTION helium_total_moment_of_inertia_linkwise + + +! *************************************************************************** +!> \brief Return moment of inertia of a cycle divided by m_He +!> \param helium ... +!> \param CYCLE ... +!> \param pos ... +!> \retval moit ... +!> \date 2014-04-24 +!> \author Lukasz Walewski +! ***************************************************************************** + FUNCTION helium_cycle_moment_of_inertia(helium,CYCLE,pos) RESULT(moit) + + TYPE(helium_solvent_type), POINTER :: helium + INTEGER, DIMENSION(:), POINTER :: CYCLE + REAL(KIND=dp), DIMENSION(:, :, :), & + POINTER :: pos + REAL(KIND=dp), DIMENSION(3) :: moit + + CHARACTER(len=*), PARAMETER :: & + routineN = 'helium_cycle_moment_of_inertia', & + routineP = moduleN//':'//routineN + + INTEGER :: i1, i2, ia, ib, nsize + REAL(KIND=dp), DIMENSION(3) :: com, rcur, ri, rj + + nsize = SIZE(CYCLE) + + ! traverse the path + moit(:) = 0.0_dp + com(:) = helium_com(helium) + DO ia = 1, nsize + ! contributions from all bead pairs of the current atom + DO ib = 1, helium%beads-1 + ri = pos(:,CYCLE(ia),ib) - com(:) + rj = pos(:,CYCLE(ia),ib+1) - com(:) + rcur(1) = ri(2)*rj(2)+ri(3)*rj(3) + rcur(2) = ri(3)*rj(3)+ri(1)*rj(1) + rcur(3) = ri(1)*rj(1)+ri(2)*rj(2) + moit(:) = moit(:) + rcur(:) + END DO + ! contribution from the last bead of the current atom + ! and the first bead of the next atom + i1 = CYCLE(ia) + IF (ia .EQ. nsize) THEN + i2 = CYCLE(1) + ELSE + i2 = CYCLE(ia+1) + END IF + ! rotation invariant bead index + ri = pos(:,i1,helium%beads) - com(:) + rj = pos(:,i2,1) - com(:) + rcur(1) = ri(2)*rj(2)+ri(3)*rj(3) + rcur(2) = ri(3)*rj(3)+ri(1)*rj(1) + rcur(3) = ri(1)*rj(1)+ri(2)*rj(2) + moit(:) = moit(:) + rcur(:) + END DO + moit(:) = moit(:) / helium%beads + + RETURN + END FUNCTION helium_cycle_moment_of_inertia + + +! *************************************************************************** +!> \brief Return total moment of inertia (sum over all cycles) +!> \param helium ... +!> \retval moit ... +!> \date 2014-04-24 +!> \author Lukasz Walewski +!> \note mostly for sanity checks +! ***************************************************************************** + FUNCTION helium_total_moment_of_inertia_cyclewise(helium) RESULT(moit) + + TYPE(helium_solvent_type), POINTER :: helium + REAL(KIND=dp), DIMENSION(3) :: moit + + CHARACTER(len=*), PARAMETER :: & + routineN = 'helium_total_moment_of_inertia_cyclewise', & + routineP = moduleN//':'//routineN + + INTEGER :: ic + REAL(KIND=dp), DIMENSION(3) :: pa + TYPE(int_arr_ptr), DIMENSION(:), POINTER :: cycles + +! decompose the current permutation state into permutation cycles + + NULLIFY(cycles) + cycles => helium_calc_cycles(helium%permutation) + + moit(:) = 0.0_dp + DO ic = 1, SIZE(cycles) + pa = helium_cycle_moment_of_inertia(helium,cycles(ic)%iap,helium%pos) + moit(:) = moit(:) + pa(:) + END DO + + DEALLOCATE(cycles) + + RETURN + END FUNCTION helium_total_moment_of_inertia_cyclewise + + +! *************************************************************************** +!> \brief Set coordinate system, e.g. for RHO calculations +!> \param helium ... +!> \param pint_env ... +!> \date 2014-04-25 +!> \author Lukasz Walewski +!> \note Sets the origin (center of the coordinate system) wrt which +!> spatial distribution functions are calculated. +!> \note It can be extended later to set the axes of the coordinate system +!> as well, e.g. for dynamic analysis with moving solute. +! ***************************************************************************** + SUBROUTINE helium_update_coord_system(helium,pint_env) + + TYPE(helium_solvent_type), POINTER :: helium + TYPE(pint_env_type), POINTER :: pint_env + + CHARACTER(len=*), PARAMETER :: routineN = 'helium_update_coord_system', & + routineP = moduleN//':'//routineN + + IF (helium%solute_present) THEN + helium%center(:) = pint_com_pos(pint_env) + ELSE + IF (helium%periodic) THEN + helium%center(:) = (/0.0_dp, 0.0_dp, 0.0_dp/) + ELSE + helium%center(:) = helium_com(helium) + END IF + END IF + + RETURN + END SUBROUTINE helium_update_coord_system + + +! *************************************************************************** +!> \brief Set coordinate system for RDF calculations +!> \param helium ... +!> \param pint_env ... +!> \date 2014-04-25 +!> \author Lukasz Walewski +!> \note Sets the centers wrt which radial distribution functions are +!> calculated. +! ***************************************************************************** + SUBROUTINE helium_set_rdf_coord_system(helium,pint_env) + + TYPE(helium_solvent_type), POINTER :: helium + TYPE(pint_env_type), POINTER :: pint_env + + CHARACTER(len=*), PARAMETER :: routineN = 'helium_set_rdf_coord_system', & + routineP = moduleN//':'//routineN + + INTEGER :: i + + IF (helium%solute_present) THEN + CALL pint_calc_centroid(pint_env) + i = 3*helium%solute_atoms + helium%rdf_centers(1:i) = pint_env%centroid(:) + ELSE + helium%rdf_centers(:) = helium%center(:) + END IF + + RETURN + END SUBROUTINE helium_set_rdf_coord_system + + +! *************************************************************************** +!> \brief Calculate center of mass +!> \param helium ... +!> \retval com ... +!> \date 2014-04-09 +!> \author Lukasz Walewski +! ***************************************************************************** + FUNCTION helium_com(helium) RESULT(com) + + TYPE(helium_solvent_type), POINTER :: helium + REAL(KIND=dp), DIMENSION(3) :: com + + CHARACTER(len=*), PARAMETER :: routineN = 'helium_com', & + routineP = moduleN//':'//routineN + + INTEGER :: ia, ib + + com(:) = 0.0_dp + DO ia = 1, helium%atoms + DO ib = 1, helium%beads + com(:) = com(:) + helium%pos(:,ia,ib) + END DO + END DO + com(:) = com(:) / helium%atoms / helium%beads + + END FUNCTION helium_com + + +! *************************************************************************** +!> \brief Return link vector, i.e. displacement vector of two consecutive +!> beads along the path starting at bead ib of atom ia +!> \param helium ... +!> \param ia ... +!> \param ib ... +!> \retval lvec ... +!> \author Lukasz Walewski +! ***************************************************************************** + FUNCTION helium_link_vector(helium,ia,ib) RESULT(lvec) + + TYPE(helium_solvent_type), POINTER :: helium + INTEGER :: ia, ib + REAL(KIND=dp), DIMENSION(3) :: lvec + + CHARACTER(len=*), PARAMETER :: routineN = 'helium_link_vector', & + routineP = moduleN//':'//routineN + + INTEGER :: ia1, ia2, ib1, ib2 + REAL(KIND=dp), DIMENSION(:), POINTER :: r1, r2 + + IF (ib .EQ. helium%beads) THEN + ia1 = ia + ia2 = helium%permutation(ia) + ib1 = ib + ib2 = 1 + ELSE + ia1 = ia + ia2 = ia + ib1 = ib + ib2 = ib+1 + END IF + r1 => helium%pos(:,ia1,ib1) + r2 => helium%pos(:,ia2,ib2) + lvec(:) = r2(:) - r1(:) + CALL helium_pbc(helium,lvec) + + END FUNCTION helium_link_vector + + +! ***************************************************************************** +!> \brief ... +!> \param helium ... +!> \param ia ... +!> \param ib ... +!> \retval rperp ... +! ***************************************************************************** + FUNCTION helium_rperpendicular(helium,ia,ib) RESULT(rperp) + + TYPE(helium_solvent_type), POINTER :: helium + INTEGER :: ia, ib + REAL(KIND=dp), DIMENSION(3) :: rperp + + CHARACTER(len=*), PARAMETER :: routineN = 'helium_rperpendicular', & + routineP = moduleN//':'//routineN + + REAL(KIND=dp), DIMENSION(:), POINTER :: ri + + ri => helium%pos(:,ia,ib) + rperp(1) = SQRT(ri(2)*ri(2)+ri(3)*ri(3)) + rperp(2) = SQRT(ri(3)*ri(3)+ri(1)*ri(1)) + rperp(3) = SQRT(ri(1)*ri(1)+ri(2)*ri(2)) + + RETURN + END FUNCTION helium_rperpendicular + + +! *************************************************************************** +!> \brief Convert a winding number vector from real number representation +!> (in internal units) to integer number representation (in cell +!> vector units) +!> \param helium ... +!> \param wnum ... +!> \retval inum ... +!> \author Lukasz Walewski +! ***************************************************************************** + FUNCTION helium_wnumber_to_integer(helium,wnum) RESULT(inum) + + TYPE(helium_solvent_type), POINTER :: helium + REAL(KIND=dp), DIMENSION(3) :: wnum + INTEGER, DIMENSION(3) :: inum + + CHARACTER(len=*), PARAMETER :: routineN = 'helium_wnumber_to_integer', & + routineP = moduleN//':'//routineN + + REAL(KIND=dp), DIMENSION(3) :: wcur + REAL(KIND=dp), DIMENSION(:, :), POINTER :: invcell + + invcell => helium%cell_m_inv + CALL DGEMV('N',3,3,1.0_dp,invcell,SIZE(invcell,1),wnum,1,0.0_dp,wcur,1) + inum(:) = NINT(wcur(:)) + + RETURN + END FUNCTION helium_wnumber_to_integer + + +! *************************************************************************** +!> \brief Given the atom index and permutation state returns .TRUE. if the +!> atom belongs to a winding path, .FASLE. otherwise. +!> \param helium ... +!> \param atmidx ... +!> \param pos ... +!> \param permutation ... +!> \retval is_winding ... +!> \date 2010-09-21 +!> \author Lukasz Walewski +!> \note The path winds around the periodic box if any component of its +!> widing number vector differs from 0. +! ***************************************************************************** + FUNCTION helium_is_winding(helium, atmidx, pos, permutation) RESULT(is_winding) + + TYPE(helium_solvent_type), POINTER :: helium + INTEGER, INTENT(IN) :: atmidx + REAL(KIND=dp), DIMENSION(:, :, :), & + POINTER :: pos + INTEGER, DIMENSION(:), POINTER :: permutation + LOGICAL :: is_winding + + CHARACTER(len=*), PARAMETER :: routineN = 'helium_is_winding', & + routineP = moduleN//':'//routineN + + INTEGER :: ic + INTEGER, DIMENSION(3) :: inum + INTEGER, DIMENSION(:), POINTER :: CYCLE + REAL(KIND=dp), DIMENSION(3) :: wnum + + is_winding = .FALSE. + NULLIFY(CYCLE) + CYCLE => helium_cycle_of(atmidx, permutation) + wnum(:) = bohr * helium_cycle_winding_number(helium,CYCLE,pos) + inum(:) = helium_wnumber_to_integer(helium,wnum) + DO ic = 1, 3 + IF (ABS(inum(ic)) .GT. 0) THEN + is_winding = .TRUE. + EXIT + END IF + END DO + DEALLOCATE(CYCLE) + + RETURN + END FUNCTION helium_is_winding + + +END MODULE helium_common diff --git a/src/motion/helium_interactions.F b/src/motion/helium_interactions.F index ffe3f3bdb7..ab19972a31 100644 --- a/src/motion/helium_interactions.F +++ b/src/motion/helium_interactions.F @@ -12,13 +12,12 @@ MODULE helium_interactions USE helium_common, ONLY: helium_eval_expansion,& helium_pbc - USE helium_types, ONLY: e_id_interact,& - e_id_kinetic,& - e_id_potential,& - e_id_thermo,& - e_id_total,& - e_id_virial,& - helium_solvent_type + USE helium_types, ONLY: & + e_id_interact, e_id_kinetic, e_id_potential, e_id_thermo, e_id_total, & + e_id_virial, helium_solvent_type, hid_chlorine, hid_hydrogen, & + hid_oxygen, int_arr_ptr + USE input_constants, ONLY: helium_solute_intpot_mwater,& + helium_solute_intpot_none USE kinds, ONLY: dp USE physcon, ONLY: angstrom,& kelvin @@ -35,7 +34,8 @@ MODULE helium_interactions PUBLIC :: helium_calc_energy PUBLIC :: helium_solute_e_f - PUBLIC :: helium_bead_solute_e + PUBLIC :: helium_bead_solute_e_f + PUBLIC :: helium_intpot_scan CONTAINS @@ -161,21 +161,18 @@ vkin = 0.0_dp RETURN END SUBROUTINE helium_calc_energy + ! *************************************************************************** -!> \brief Calculate helium-solute interaction energy and forces contribution -!> from one helium bead of one helium particle and the corresponding -!> solute time slice. -!> \param pint_env ... +!> \brief Calculate general helium-solute interaction energy (and forces) +!> between one helium bead and the corresponding solute time slice. +!> \param pint_env path integral environment !> \param helium ... -!> \param helium_part_index ... -!> \param helium_slice_index ... -!> \param helium_r_opt ... -!> \param energy ... -!> \param force ... -!> \date 2009-12-11 +!> \param helium_part_index helium particle index +!> \param helium_slice_index helium time slice index +!> \param helium_r_opt explicit helium bead coordinates (optional) +!> \param energy calculated energy +!> \param force calculated force (if requested) !> \author Lukasz Walewski -!> \note This is a stub, Lennard-Jones potential with no warranty. It should -!> be replaced with realistic potential for real-world simulations. ! ***************************************************************************** SUBROUTINE helium_bead_solute_e_f(pint_env, helium, helium_part_index, & helium_slice_index, helium_r_opt, energy, force) @@ -188,24 +185,14 @@ vkin = 0.0_dp INTENT(IN), OPTIONAL :: helium_r_opt REAL(KIND=dp), INTENT(OUT) :: energy REAL(KIND=dp), DIMENSION(:, :), & - INTENT(OUT) :: force + INTENT(OUT), OPTIONAL, POINTER :: force CHARACTER(len=*), PARAMETER :: routineN = 'helium_bead_solute_e_f', & routineP = moduleN//':'//routineN - INTEGER :: hbeads, hi, i, ig, & - num_chlorine, num_hydrogen, & - num_oxygen, qi - REAL(KIND=dp) :: d, d2, dd, ep, eps, s1, s2, & - sig - REAL(KIND=dp), DIMENSION(3) :: dr, helium_r, solute_r - - CPASSERT(ASSOCIATED(helium)) - CPASSERT(ASSOCIATED(pint_env)) - - num_chlorine = helium%solute_number(1) - num_oxygen = helium%solute_number(2) - num_hydrogen = helium%solute_number(3) + INTEGER :: hbeads, hi, qi + REAL(KIND=dp), DIMENSION(3) :: helium_r + REAL(KIND=dp), DIMENSION(:), POINTER :: my_force hbeads = helium%beads ! helium bead index that is invariant wrt the rotations @@ -220,78 +207,47 @@ vkin = 0.0_dp helium_r(:) = helium%pos(:,helium_part_index,helium_slice_index) END IF - energy = 0.0_dp - force(:,:) = 0.0_dp + SELECT CASE (helium%solute_interaction) - sig = 2.69_dp ! 1.4 Angstrom - eps = 60.61e-6_dp ! 19 K - s1 = 0.0_dp - DO i = 1, num_hydrogen - ig = helium%solute_index(3,i)-1 ! global hydrogen index (3 == H) - solute_r(1) = pint_env%x(qi,3*ig+1) - solute_r(2) = pint_env%x(qi,3*ig+2) - solute_r(3) = pint_env%x(qi,3*ig+3) - dr(:) = solute_r(:) - helium_r(:) - CALL helium_pbc( helium, dr ) - d2 = dr(1)*dr(1) + dr(2)*dr(2) + dr(3)*dr(3) - d = SQRT(d2) - dd = (sig/d)**6 - ep = 4.0_dp*eps*dd*(dd-1.0_dp) - s1 = s1 + ep - s2 = 24.0_dp*eps*dd*(2.0_dp*dd-1.0_dp)/d2 - force(qi,3*ig+1) = force(qi,3*ig+1) + s2*dr(1) - force(qi,3*ig+2) = force(qi,3*ig+2) + s2*dr(2) - force(qi,3*ig+3) = force(qi,3*ig+3) + s2*dr(3) - END DO ! i = 1, num_hydrogen - energy = energy + s1 - sig = 5.01_dp ! 2.6 Angstrom - eps = 79.17e-6_dp ! 25 K - s1 = 0.0_dp - DO i = 1, num_chlorine - ig = helium%solute_index(1,i)-1 ! global chlorine index (1 == Cl) - solute_r(1) = pint_env%x(qi,3*ig+1) - solute_r(2) = pint_env%x(qi,3*ig+2) - solute_r(3) = pint_env%x(qi,3*ig+3) - dr(:) = solute_r(:) - helium_r(:) - CALL helium_pbc( helium, dr ) - d2 = dr(1)*dr(1) + dr(2)*dr(2) + dr(3)*dr(3) - d = SQRT(d2) - dd = (sig/d)**6 - ep = 4.0_dp*eps*dd*(dd-1.0_dp) - s1 = s1 + ep - s2 = 24.0_dp*eps*dd*(2.0_dp*dd-1.0_dp)/d2 - force(qi,3*ig+1) = force(qi,3*ig+1) + s2*dr(1) - force(qi,3*ig+2) = force(qi,3*ig+2) + s2*dr(2) - force(qi,3*ig+3) = force(qi,3*ig+3) + s2*dr(3) - END DO ! i = 1, num_chlorine - energy = energy + s1 + CASE (helium_solute_intpot_mwater) + IF (PRESENT(force)) THEN + force(:,:) = 0.0_dp + my_force => force(qi,:) + CALL helium_intpot_model_water( & + pint_env%x(qi,:), & + helium%solute_i, & + helium, & + helium_r,& + energy, & + my_force & + ) + ELSE + CALL helium_intpot_model_water( & + pint_env%x(qi,:), & + helium%solute_i, & + helium, & + helium_r,& + energy & + ) + END IF - sig = 5.01_dp ! 2.6 Angstrom - eps = 104.5e-6_dp ! 33 K - s1 = 0.0_dp - DO i = 1, num_oxygen - ig = helium%solute_index(2,i)-1 ! global oxygen index (2 == O) - solute_r(1) = pint_env%x(qi,3*ig+1) - solute_r(2) = pint_env%x(qi,3*ig+2) - solute_r(3) = pint_env%x(qi,3*ig+3) - dr(:) = solute_r(:) - helium_r(:) - CALL helium_pbc( helium, dr ) - d2 = dr(1)*dr(1) + dr(2)*dr(2) + dr(3)*dr(3) - d = SQRT(d2) - dd = (sig/d)**6 - ep = 4.0_dp*eps*dd*(dd-1.0_dp) - s1 = s1 + ep - s2 = 24.0_dp*eps*dd*(2.0_dp*dd-1.0_dp)/d2 - force(qi,3*ig+1) = force(qi,3*ig+1) + s2*dr(1) - force(qi,3*ig+2) = force(qi,3*ig+2) + s2*dr(2) - force(qi,3*ig+3) = force(qi,3*ig+3) + s2*dr(3) - END DO ! i = 1, num_chlorine - energy = energy + s1 + CASE (helium_solute_intpot_none) + energy = 0.0_dp + IF (PRESENT(force)) THEN + force(:,:) = 0.0_dp + END IF + + + + CASE DEFAULT + + END SELECT RETURN END SUBROUTINE helium_bead_solute_e_f + ! *************************************************************************** !> \brief Calculate total helium-solute interaction energy and forces. !> \param pint_env - path integral environment @@ -308,7 +264,7 @@ vkin = 0.0_dp CHARACTER(len=*), PARAMETER :: routineN = 'helium_solute_e_f', & routineP = moduleN//':'//routineN - INTEGER :: i, ibead, ipart, j + INTEGER :: ia, ib, jb, jc REAL(KIND=dp) :: my_energy REAL(KIND=dp), DIMENSION(:, :), POINTER :: force @@ -320,14 +276,14 @@ vkin = 0.0_dp ! calculate the total interaction energy and gradients between the ! solute and the helium, sum over all beads of all He particles - DO ipart = 1, helium%atoms - DO ibead = 1, helium%beads - CALL helium_bead_solute_e_f(pint_env, helium, ipart, & - ibead, energy=my_energy, force=helium%rtmp_p_ndim_2d) - energy = energy + my_energy - DO i = 1, pint_env%p - DO j = 1, pint_env%ndim - force(i,j) = force(i,j) + helium%rtmp_p_ndim_2d(i,j) + DO ia = 1, helium%atoms + DO ib = 1, helium%beads + CALL helium_bead_solute_e_f(pint_env, helium, ia, ib, & + energy=my_energy, force=helium%rtmp_p_ndim_2d) + energy = energy + my_energy + DO jb = 1, pint_env%p + DO jc = 1, pint_env%ndim + force(jb,jc) = force(jb,jc) + helium%rtmp_p_ndim_2d(jb,jc) END DO END DO END DO @@ -336,113 +292,6 @@ vkin = 0.0_dp RETURN END SUBROUTINE helium_solute_e_f -! *************************************************************************** -!> \brief Calculate helium-solute interaction energy contribution from one -!> helium bead of one helium particle and the corresponding solute -!> time slice. -!> \param pint_env ... -!> \param helium ... -!> \param helium_part_index ... -!> \param helium_slice_index ... -!> \param helium_r_opt ... -!> \param energy ... -!> \date 2009-12-11 -!> \author Lukasz Walewski -!> \note This is a stub, Lennard-Jones potential with no warranty. It should -!> be replaced with realistic potential for real-world simulations. -! ***************************************************************************** - SUBROUTINE helium_bead_solute_e(pint_env, helium, helium_part_index, & - helium_slice_index, helium_r_opt, energy) - - TYPE(pint_env_type), POINTER :: pint_env - TYPE(helium_solvent_type), POINTER :: helium - INTEGER, INTENT(IN) :: helium_part_index, & - helium_slice_index - REAL(KIND=dp), DIMENSION(3), & - INTENT(IN), OPTIONAL :: helium_r_opt - REAL(KIND=dp), INTENT(OUT) :: energy - - INTEGER :: hbeads, hi, i, ig, & - num_chlorine, num_hydrogen, & - num_oxygen, qi - REAL(KIND=dp) :: d, d2, dd, ep, eps, s1, sig - REAL(KIND=dp), DIMENSION(3) :: dr, helium_r, solute_r - - num_chlorine = helium%solute_number(1) - num_oxygen = helium%solute_number(2) - num_hydrogen = helium%solute_number(3) - - hbeads = helium%beads - ! helium bead index that is invariant wrt the rotations - hi = MOD(helium_slice_index-1+hbeads+helium%relrot,hbeads) + 1 - ! solute bead index that belongs to hi helium index - qi = ((hi-1)*pint_env%p)/hbeads+1 - - ! coordinates of the helium bead - IF (PRESENT(helium_r_opt)) THEN - helium_r(:) = helium_r_opt(:) - ELSE - helium_r(:) = helium%pos(:,helium_part_index,helium_slice_index) - END IF - - energy = 0.0_dp - - sig = 2.69_dp ! 1.4 Angstrom - eps = 60.61e-6_dp ! 19 K - s1 = 0.0_dp - DO i = 1, num_hydrogen - ig = helium%solute_index(3,i)-1 ! global hydrogen index (3 == H) - solute_r(1) = pint_env%x(qi,3*ig+1) - solute_r(2) = pint_env%x(qi,3*ig+2) - solute_r(3) = pint_env%x(qi,3*ig+3) - dr(:) = solute_r(:) - helium_r(:) - CALL helium_pbc( helium, dr ) - d2 = dr(1)*dr(1)+dr(2)*dr(2)+dr(3)*dr(3) - d = SQRT(d2) - dd = (sig/d)**6 - ep = 4.0_dp*eps*dd*(dd-1.0_dp) - s1 = s1 + ep - END DO ! i = 1, num_hydrogen - energy = energy + s1 - - sig = 5.01_dp ! 2.6 Angstrom - eps = 79.17e-6_dp ! 25 K - s1 = 0.0_dp - DO i = 1, num_chlorine - ig = helium%solute_index(1,i)-1 ! global chlorine index (1 == Cl) - solute_r(1) = pint_env%x(qi,3*ig+1) - solute_r(2) = pint_env%x(qi,3*ig+2) - solute_r(3) = pint_env%x(qi,3*ig+3) - dr(:) = solute_r(:) - helium_r(:) - CALL helium_pbc( helium, dr ) - d2 = dr(1)*dr(1)+dr(2)*dr(2)+dr(3)*dr(3) - d = SQRT(d2) - dd = (sig/d)**6 - ep = 4.0_dp*eps*dd*(dd-1.0_dp) - s1 = s1 + ep - END DO ! i = 1, num_chlorine - energy = energy + s1 - - sig = 5.01_dp ! 2.6 Angstrom - eps = 104.5e-6_dp ! 33 K - s1 = 0.0_dp - DO i = 1, num_oxygen - ig = helium%solute_index(2,i)-1 ! global oxygen index (2 == O) - solute_r(1) = pint_env%x(qi,3*ig+1) - solute_r(2) = pint_env%x(qi,3*ig+2) - solute_r(3) = pint_env%x(qi,3*ig+3) - dr(:) = solute_r(:) - helium_r(:) - CALL helium_pbc( helium, dr ) - d2 = dr(1)*dr(1)+dr(2)*dr(2)+dr(3)*dr(3) - d = SQRT(d2) - dd = (sig/d)**6 - ep = 4.0_dp*eps*dd*(dd-1.0_dp) - s1 = s1 + ep - END DO ! i = 1, num_oxygen - energy = energy + s1 - - RETURN - END SUBROUTINE helium_bead_solute_e ! *************************************************************************** !> \brief Calculate total helium-solute interaction energy. @@ -457,15 +306,14 @@ vkin = 0.0_dp TYPE(helium_solvent_type), POINTER :: helium REAL(KIND=dp), INTENT(OUT) :: energy - INTEGER :: ibead, ipart + INTEGER :: ia, ib REAL(KIND=dp) :: my_energy energy = 0.0_dp - DO ipart = 1, helium%atoms - DO ibead = 1, helium%beads - CALL helium_bead_solute_e(pint_env, helium, ipart, & - ibead, energy=my_energy) + DO ia = 1, helium%atoms + DO ib = 1, helium%beads + CALL helium_bead_solute_e_f(pint_env, helium, ia, ib, energy=my_energy) energy = energy + my_energy END DO END DO @@ -473,6 +321,214 @@ vkin = 0.0_dp RETURN END SUBROUTINE helium_solute_e + +! *************************************************************************** +!> \brief Calculate l-th Legendre polynomial P_{l}(x) at point x +!> \param x ... +!> \param n ... +!> \retval Pl ... +! ***************************************************************************** + FUNCTION Pl(x,n) + REAL(KIND=dp), INTENT(IN) :: x + INTEGER, INTENT(IN) :: n + REAL(KIND=dp) :: Pl + + INTEGER :: k + REAL(KIND=dp) :: pln(0:n) + + pln(0) = 1.0_dp + pln(1) = x + + IF (n <= 1) THEN + Pl = pln(n) + ELSE + DO k=1,n-1 + pln(k+1) = ((2.0*k+1.0)*x*pln(k) - REAL(k,dp)*pln(k-1))/(REAL(k+1,dp)) + END DO + Pl = pln(n) + END IF + RETURN + END FUNCTION Pl + + +! *************************************************************************** +!> \brief Scan the helium-solute interaction energy within the periodic cell +!> \param pint_env ... +!> \param helium ... +!> \date 2014-01-22 +!> \author Lukasz Walewski +! ***************************************************************************** + SUBROUTINE helium_intpot_scan(pint_env, helium) + + TYPE(pint_env_type), POINTER :: pint_env + TYPE(helium_solvent_type), POINTER :: helium + + CHARACTER(len=*), PARAMETER :: routineN = 'helium_intpot_scan', & + routineP = moduleN//':'//routineN + + INTEGER :: handle, ic, ix, iy, iz, nbin + LOGICAL :: wrapped + REAL(KIND=dp) :: delr, my_en, ox, oy, oz + REAL(kind=dp), DIMENSION(3) :: pbc1, pbc2, pos + + CALL timeset(routineN,handle) + + nbin = helium%rho_nbin + delr = helium%rho_delr + ox = helium%center(1) - helium%rho_maxr / 2.0_dp + oy = helium%center(2) - helium%rho_maxr / 2.0_dp + oz = helium%center(3) - helium%rho_maxr / 2.0_dp + + DO ix = 1, nbin + DO iy = 1, nbin + DO iz = 1, nbin + + ! put the probe in the center of the current voxel + pos(:) = (/ox+(ix-0.5_dp)*delr, oy+(iy-0.5_dp)*delr, oz+(iz-0.5_dp)*delr/) + + ! calc interaction energy for the current probe position + helium%pos(:,1,1) = pos(:) + CALL helium_bead_solute_e_f(pint_env,helium,1,1,energy=my_en) + + ! check if the probe fits within the unit cell + pbc1(:) = pos(:) - helium%center + pbc2(:) = pbc1(:) + CALL helium_pbc( helium, pbc2 ) + wrapped = .FALSE. + DO ic = 1, 3 + IF (ABS(pbc1(ic)-pbc2(ic)) .GT. 10.0_dp * EPSILON(0.0_dp)) THEN + wrapped = .TRUE. + END IF + END DO + + ! set the interaction energy value + IF (wrapped) THEN + helium%rho_inst(1,ix,iy,iz) = 0.0_dp + ELSE + helium%rho_inst(1,ix,iy,iz) = my_en + END IF + + END DO + END DO + END DO + + CALL timestop(handle) + + RETURN + END SUBROUTINE helium_intpot_scan + + +! *************************************************************************** +!> \brief Calculate model helium-solute interaction energy and forces +!> between one helium bead and the corresponding solute time +!> slice asuming water solute. +!> \param solute_x solute positions ARR(3*NATOMS) +!> \param solute_i solute indices, mapping from instances of a given element +!> to global atom indices +!> \param helium only needed for helium_pbc call at the moment +!> \param helium_x helium bead position ARR(3) +!> \param energy calculated interaction energy +!> \param force ... +!> \author Felix Uhl +! ***************************************************************************** + SUBROUTINE helium_intpot_model_water(solute_x, solute_i, helium, helium_x, energy, force) + + + REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: solute_x + TYPE(int_arr_ptr), DIMENSION(:), & + INTENT(IN) :: solute_i + TYPE(helium_solvent_type), POINTER :: helium + REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: helium_x + REAL(KIND=dp), INTENT(OUT) :: energy + REAL(KIND=dp), DIMENSION(:), & + INTENT(OUT), OPTIONAL, POINTER :: force + + CHARACTER(LEN=*), PARAMETER :: routineN = 'helium_intpot_model_water', & + routineP = moduleN//':'//routineN + + INTEGER :: i, ig, num_chlorine, & + num_hydrogen, num_oxygen + REAL(KIND=dp) :: d, d2, dd, ep, eps, s1, s2, & + sig + REAL(KIND=dp), DIMENSION(3) :: dr, solute_r + + IF (ASSOCIATED(solute_i(hid_chlorine)%iap)) THEN + num_chlorine = SIZE(solute_i(hid_chlorine)%iap) + ELSE + num_chlorine = 0 + END IF + + IF (ASSOCIATED(solute_i(hid_oxygen)%iap)) THEN + num_oxygen = SIZE(solute_i(hid_oxygen)%iap) + ELSE + num_oxygen = 0 + END IF + + IF (ASSOCIATED(solute_i(hid_hydrogen)%iap)) THEN + num_hydrogen = SIZE(solute_i(hid_hydrogen)%iap) + ELSE + num_hydrogen = 0 + END IF + + energy = 0.0_dp + IF (PRESENT(force)) THEN + force(:) = 0.0_dp + END IF + + sig = 2.69_dp ! 1.4 Angstrom + eps = 60.61e-6_dp ! 19 K + s1 = 0.0_dp + DO i = 1, num_hydrogen + ig = solute_i(hid_hydrogen)%iap(i)-1 ! global hydrogen index (3 == H) + solute_r(1) = solute_x(3*ig+1) + solute_r(2) = solute_x(3*ig+2) + solute_r(3) = solute_x(3*ig+3) + dr(:) = solute_r(:) - helium_x(:) + CALL helium_pbc( helium, dr ) + d2 = dr(1)*dr(1) + dr(2)*dr(2) + dr(3)*dr(3) + d = SQRT(d2) + dd = (sig/d)**6 + ep = 4.0_dp*eps*dd*(dd-1.0_dp) + s1 = s1 + ep + s2 = 24.0_dp*eps*dd*(2.0_dp*dd-1.0_dp)/d2 + IF (PRESENT(force)) THEN + force(3*ig+1) = force(3*ig+1) + s2*dr(1) + force(3*ig+2) = force(3*ig+2) + s2*dr(2) + force(3*ig+3) = force(3*ig+3) + s2*dr(3) + END IF + END DO ! i = 1, num_hydrogen + energy = energy + s1 + + sig = 5.01_dp ! 2.6 Angstrom + eps = 104.5e-6_dp ! 33 K + s1 = 0.0_dp + DO i = 1, num_oxygen + ig = solute_i(hid_oxygen)%iap(i)-1 ! global oxygen index (2 == O) + solute_r(1) = solute_x(3*ig+1) + solute_r(2) = solute_x(3*ig+2) + solute_r(3) = solute_x(3*ig+3) + dr(:) = solute_r(:) - helium_x(:) + CALL helium_pbc( helium, dr ) + d2 = dr(1)*dr(1) + dr(2)*dr(2) + dr(3)*dr(3) + d = SQRT(d2) + dd = (sig/d)**6 + ep = 4.0_dp*eps*dd*(dd-1.0_dp) + s1 = s1 + ep + s2 = 24.0_dp*eps*dd*(2.0_dp*dd-1.0_dp)/d2 + IF (PRESENT(force)) THEN + force(3*ig+1) = force(3*ig+1) + s2*dr(1) + force(3*ig+2) = force(3*ig+2) + s2*dr(2) + force(3*ig+3) = force(3*ig+3) + s2*dr(3) + END IF + END DO ! i = 1, num_chlorine + energy = energy + s1 + + RETURN + +END SUBROUTINE helium_intpot_model_water + + + ! *************************************************************************** !> \brief Helium-helium pair interaction potential. !> \param r ... @@ -498,6 +554,11 @@ vkin = 0.0_dp RETURN END FUNCTION helium_vij + +#if 0 + + ! this block is currently turned off + ! *************************************************************************** !> \brief Helium-helium pair interaction potential's derivative. !> \param r ... @@ -530,4 +591,224 @@ vkin = 0.0_dp RETURN END FUNCTION helium_d_vij + +! ***************************************************************************** +!> \brief ... +!> \param helium ... +!> \param n ... +!> \param i ... +!> \retval res ... +! ***************************************************************************** + FUNCTION helium_atom_action(helium,n,i) RESULT(res) + + TYPE(helium_solvent_type), POINTER :: helium + INTEGER, INTENT(IN) :: n, i + REAL(KIND=dp) :: res + + INTEGER :: c, j + REAL(KIND=dp) :: r(3), rp(3), s, t + + s = 0.0_dp + t = 0.0_dp + IF (n < helium%beads) THEN + DO c = 1, 3 + r(c) = helium%pos(c,i,n) - helium%pos(c,i,n+1) + END DO + CALL helium_pbc( helium, r ) + t = r(1)*r(1) + r(2)*r(2) + r(3)*r(3) + DO j = 1, i-1 + DO c = 1, 3 + r(c) = helium%pos(c,i,n) - helium%pos(c,j,n) + rp(c) = helium%pos(c,i,n+1) - helium%pos(c,j,n+1) + END DO + CALL helium_pbc( helium, r ) + CALL helium_pbc( helium, rp ) + s = s + helium_eval_expansion(helium,r,rp,helium%uij,1) + END DO + DO j = i+1, helium%atoms + DO c = 1, 3 + r(c) = helium%pos(c,i,n) - helium%pos(c,j,n) + rp(c) = helium%pos(c,i,n+1) - helium%pos(c,j,n+1) + END DO + CALL helium_pbc( helium, r ) + CALL helium_pbc( helium, rp ) + s = s + helium_eval_expansion(helium,r,rp,helium%uij,1) + END DO + ELSE + DO c = 1, 3 + r(c) = helium%pos(c,i,n) - helium%pos(c,helium%permutation(i),1) + END DO + CALL helium_pbc( helium, r ) + t = r(1)*r(1) + r(2)*r(2) + r(3)*r(3) + DO j = 1, i-1 + DO c = 1, 3 + r(c) = helium%pos(c,i,n) - helium%pos(c,j,n) + rp(c) = helium%pos(c,helium%permutation(i),1) - helium%pos(c,helium%permutation(j),1) + END DO + CALL helium_pbc( helium, r ) + CALL helium_pbc( helium, rp ) + s = s + helium_eval_expansion(helium,r,rp,helium%uij,1) + END DO + DO j = i+1, helium%atoms + DO c = 1, 3 + r(c) = helium%pos(c,i,n) - helium%pos(c,j,n) + rp(c) = helium%pos(c,helium%permutation(i),1) - helium%pos(c,helium%permutation(j),1) + END DO + CALL helium_pbc( helium, r ) + CALL helium_pbc( helium, rp ) + s = s + helium_eval_expansion(helium,r,rp,helium%uij,1) + END DO + END IF + t = t / (2.0_dp*helium%tau*helium%hb2m) + s = s * 0.5_dp + res = s+t + RETURN + + END FUNCTION helium_atom_action + +! ***************************************************************************** +!> \brief ... +!> \param helium ... +!> \param n ... +!> \retval res ... +! ***************************************************************************** + FUNCTION helium_link_action(helium,n) RESULT(res) + + TYPE(helium_solvent_type), POINTER :: helium + INTEGER, INTENT(IN) :: n + REAL(KIND=dp) :: res + + INTEGER :: c, i, j + REAL(KIND=dp) :: r(3), rp(3), s, t + + s = 0.0_dp + t = 0.0_dp + IF (n < helium%beads) THEN + DO i = 1, helium%atoms + DO c = 1, 3 + r(c) = helium%pos(c,i,n) - helium%pos(c,i,n+1) + END DO + CALL helium_pbc( helium, r ) + t = r(1)*r(1) + r(2)*r(2) + r(3)*r(3) + DO j = 1, i-1 + DO c = 1, 3 + r(c) = helium%pos(c,i,n) - helium%pos(c,j,n) + rp(c) = helium%pos(c,i,n+1) - helium%pos(c,j,n+1) + END DO + CALL helium_pbc( helium, r ) + CALL helium_pbc( helium, rp ) + s = s + helium_eval_expansion(helium,r,rp,helium%uij,1) + END DO + END DO + ELSE + DO i = 1, helium%atoms + DO c = 1, 3 + r(c) = helium%pos(c,i,n) - helium%pos(c,helium%permutation(i),1) + END DO + CALL helium_pbc( helium, r ) + t = r(1)*r(1) + r(2)*r(2) + r(3)*r(3) + DO j = 1, i-1 + DO c = 1, 3 + r(c) = helium%pos(c,i,n) - helium%pos(c,j,n) + rp(c) = helium%pos(c,helium%permutation(i),1) - helium%pos(c,helium%permutation(j),1) + END DO + CALL helium_pbc( helium, r ) + CALL helium_pbc( helium, rp ) + s = s + helium_eval_expansion(helium,r,rp,helium%uij,1) + END DO + END DO + END IF + t = t / (2.0_dp*helium%tau*helium%hb2m) + res = s+t + RETURN + + END FUNCTION helium_link_action + +! ***************************************************************************** +!> \brief ... +!> \param helium ... +!> \retval res ... +! ***************************************************************************** + FUNCTION helium_total_action(helium) RESULT(res) + + TYPE(helium_solvent_type), POINTER :: helium + REAL(KIND=dp) :: res + + INTEGER :: i + REAL(KIND=dp) :: s + + s = 0.0_dp + DO i = 1, helium%beads + s = s + helium_link_action(helium,i) + END DO + res = s + RETURN + + END FUNCTION helium_total_action + +! ***************************************************************************** +!> \brief ... +!> \param helium ... +!> \param part ... +!> \param ref_bead ... +!> \param delta_bead ... +!> \param d ... +! ***************************************************************************** + SUBROUTINE helium_delta_pos(helium,part,ref_bead,delta_bead,d) + + TYPE(helium_solvent_type), POINTER :: helium + INTEGER, INTENT(IN) :: part, ref_bead, delta_bead + REAL(KIND=dp), DIMENSION(3), INTENT(OUT) :: d + + INTEGER :: b, bead, db, nbead, np, p + REAL(KIND=dp), DIMENSION(3) :: r + + b = helium%beads + + d(:) = 0.0_dp + IF (delta_bead > 0) THEN + bead = ref_bead + p = part + db = delta_bead + DO + IF (db < 1) EXIT + nbead = bead + 1 + np = p + IF (nbead > b) THEN + nbead = nbead - b + np = helium%permutation(np) + END IF + r(:) = helium%pos(:,p,bead) - helium%pos(:,np,nbead) + CALL helium_pbc( helium, r ) + d(:) = d(:) + r(:) + bead = nbead + p = np + db = db-1 + END DO + ELSEIF ( delta_bead < 0) THEN + bead = ref_bead + p = part + db = delta_bead + DO + IF (db >= 0) EXIT + nbead = bead - 1 + np = p + IF (nbead < 1) THEN + nbead = nbead + b + np = helium%iperm(np) + END IF + r(:) = helium%pos(:,p,bead) - helium%pos(:,np,nbead) + CALL helium_pbc( helium, r ) + d(:) = d(:) + r(:) + bead = nbead + p = np + db = db + 1 + END DO + END IF + RETURN + END SUBROUTINE helium_delta_pos + +#endif + + END MODULE helium_interactions diff --git a/src/motion/helium_io.F b/src/motion/helium_io.F new file mode 100644 index 0000000000..7767c251fd --- /dev/null +++ b/src/motion/helium_io.F @@ -0,0 +1,1675 @@ +!-----------------------------------------------------------------------------! +! CP2K: A general program to perform molecular dynamics simulations ! +! Copyright (C) 2000 - 2015 CP2K developers group ! +!-----------------------------------------------------------------------------! + +! ***************************************************************************** +!> \brief I/O subroutines for helium +!> \author Lukasz Walewski +!> \date 2009-06-08 +! ***************************************************************************** +MODULE helium_io + + USE cell_types, ONLY: get_cell + USE cp_log_handling, ONLY: cp_get_default_logger,& + cp_logger_get_default_unit_nr,& + cp_logger_type + USE cp_output_handling, ONLY: cp_p_file,& + cp_print_key_finished_output,& + cp_print_key_should_output,& + cp_print_key_unit_nr + USE cp_para_types, ONLY: cp_para_env_type + USE cp_parser_methods, ONLY: parser_get_next_line,& + parser_get_object + USE cp_parser_types, ONLY: cp_parser_type,& + parser_create,& + parser_release + USE cp_units, ONLY: cp_unit_from_cp2k,& + cp_unit_to_cp2k + USE helium_common, ONLY: helium_cycle_number,& + helium_cycle_of,& + helium_is_winding,& + helium_path_length,& + helium_pbc + USE helium_types, ONLY: e_id_interact,& + e_id_kinetic,& + e_id_potential,& + e_id_thermo,& + e_id_total,& + e_id_virial,& + helium_solvent_type,& + rho_num + USE input_constants, ONLY: helium_cell_shape_cube,& + helium_cell_shape_octahedron,& + helium_sampling_ceperley,& + helium_solute_intpot_mwater,& + helium_solute_intpot_none,& + perm_cycle,& + perm_plain + USE input_section_types, ONLY: section_vals_get_subs_vals,& + section_vals_type,& + section_vals_val_get + USE kinds, ONLY: default_path_length,& + default_string_length,& + dp,& + int_8 + USE machine, ONLY: m_flush + USE memory_utilities, ONLY: reallocate + USE message_passing, ONLY: mp_gather,& + mp_sum + USE physcon, ONLY: angstrom +#include "../base/base_uses.f90" + + IMPLICIT NONE + + PRIVATE + + LOGICAL, PRIVATE, PARAMETER :: debug_this_module = .TRUE. + CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'helium_io' + + CHARACTER(len=*), DIMENSION(6), PARAMETER, PRIVATE :: m_dist_name = (/& + "SINGLEV ",& + "UNIFORM ",& + "LINEAR ",& + "QUADRATIC ",& + "EXPONENTIAL",& + "GAUSSIAN "/) + + PUBLIC :: helium_read_xyz + PUBLIC :: helium_print_rdf + PUBLIC :: helium_print_rho + PUBLIC :: helium_write_line + PUBLIC :: helium_write_setup + PUBLIC :: helium_print_energy + PUBLIC :: helium_print_vector + PUBLIC :: helium_print_plength + PUBLIC :: helium_print_coordinates + PUBLIC :: helium_print_force + PUBLIC :: helium_print_accepts + PUBLIC :: helium_print_perm + PUBLIC :: helium_write_cubefile + + CONTAINS + + +! *************************************************************************** +!> \brief Read XYZ coordinates from file +!> \param coords ... +!> \param file_name ... +!> \param para_env ... +!> \date 2009-06-03 +!> \author Lukasz Walewski +!> \note This is a parallel routine, all ranks get coords defined +! ***************************************************************************** + SUBROUTINE helium_read_xyz(coords,file_name,para_env) + + REAL(KIND=dp), DIMENSION(:), POINTER :: coords + CHARACTER(LEN=default_path_length) :: file_name + TYPE(cp_para_env_type), POINTER :: para_env + + CHARACTER(len=*), PARAMETER :: routineN = 'helium_read_xyz', & + routineP = moduleN//':'//routineN + + CHARACTER(LEN=default_string_length) :: strtmp + INTEGER :: frame, handle, istat, j, natom + LOGICAL :: found, my_end + TYPE(cp_parser_type), POINTER :: parser + + CALL timeset(routineN,handle) + + ! check if the file can be accessed + INQUIRE(FILE=file_name,EXIST=found,IOSTAT=istat) + IF (istat /= 0) THEN + WRITE (UNIT=strtmp,FMT="(A,I0,A)")& + "An error occurred inquiring the file <"//& + TRIM(file_name)//">" + CPABORT(TRIM(strtmp)) + END IF + IF (.NOT.found) THEN + CPABORT("Coordinate file <"//TRIM(file_name)//"> not found.") + END IF + + NULLIFY (parser) + CALL parser_create( & + parser, & + file_name, & + para_env=para_env, & + parse_white_lines=.TRUE.) + + natom = 0 + frame = 0 + CALL parser_get_next_line(parser,1) + Frames: DO + ! Atom number + CALL parser_get_object(parser,natom) + frame = frame + 1 + IF (frame == 1) THEN + ALLOCATE(coords(3*natom)) + ELSE + strtmp = "Warning: more than one frame on file <"//TRIM(file_name)//">" + CALL helium_write_line(strtmp) + strtmp = "Warning: using the first frame only!" + CALL helium_write_line(strtmp) + EXIT Frames + END IF + ! Dummy line + CALL parser_get_next_line(parser,2) + DO j=1,natom + ! Atom coordinates + READ (parser%input_line,*) strtmp,& + coords(3*(j-1)+1),& + coords(3*(j-1)+2),& + coords(3*(j-1)+3) + coords(3*(j-1)+1) = cp_unit_to_cp2k(coords(3*(j-1)+1),"angstrom") + coords(3*(j-1)+2) = cp_unit_to_cp2k(coords(3*(j-1)+2),"angstrom") + coords(3*(j-1)+3) = cp_unit_to_cp2k(coords(3*(j-1)+3),"angstrom") + ! If there's a white line or end of file exit.. otherwise go on + CALL parser_get_next_line(parser,1,at_end=my_end) + my_end = my_end.OR.(LEN_TRIM(parser%input_line) == 0) + IF (my_end) THEN + IF (j/=natom) THEN + CPABORT("Error in XYZ format.") + END IF + EXIT Frames + END IF + END DO + END DO Frames + CALL parser_release(parser) + + CALL timestop(handle) + + RETURN + END SUBROUTINE helium_read_xyz + + +! *************************************************************************** +!> \brief Write helium parameters to the output unit +!> \param helium ... +!> \date 2009-06-03 +!> \author Lukasz Walewski +! ***************************************************************************** + SUBROUTINE helium_write_setup( helium ) + + TYPE(helium_solvent_type), POINTER :: helium + + CHARACTER(len=*), PARAMETER :: routineN = 'helium_write_setup', & + routineP = moduleN//':'//routineN + + CHARACTER(len=default_string_length) :: msg_str, my_label, stmp, & + stmp1, stmp2, unit_str + INTEGER :: i, itmp, j, unit_nr + INTEGER(KIND=int_8) :: i8tmp + LOGICAL :: first + REAL(KIND=dp) :: rtmp, v1, v2, v3 + REAL(KIND=dp), DIMENSION(3) :: my_abc + TYPE(cp_logger_type), POINTER :: logger + + NULLIFY(logger) + logger => cp_get_default_logger() + my_label = "HELIUM| " + + IF (logger%para_env%ionode) THEN + unit_nr = cp_logger_get_default_unit_nr(logger) + + WRITE(unit_nr,*) + WRITE(unit_nr,'(T2,A,1X,I0)') TRIM(my_label)//& + " Number of helium environments: ", helium%num_env + + WRITE(unit_nr,'(T2,A,1X,I0)') TRIM(my_label)//& + " Number of solvent atoms: ", helium%atoms + WRITE(unit_nr,'(T2,A,1X,I0)') TRIM(my_label)//& + " Number of solvent beads: ", helium%beads + WRITE(unit_nr,'(T2,A,1X,I0)') TRIM(my_label)//& + " Total number of solvent particles: ", helium%atoms*helium%beads + + unit_str = "angstrom^-3" + rtmp = cp_unit_from_cp2k(helium%density, & + unit_str) + WRITE(unit_nr,'(T2,A,F12.6)') TRIM(my_label)//" Density ["// & + TRIM(unit_str)//"]:", rtmp + + unit_str = "angstrom" + rtmp = cp_unit_from_cp2k(helium%cell_size, & + unit_str) + WRITE(unit_nr,'(T2,A,F12.6)') TRIM(my_label)//" Cell size ["// & + TRIM(unit_str)//"]: ", rtmp + + IF ( helium%periodic ) THEN + SELECT CASE (helium%cell_shape) + CASE (helium_cell_shape_cube) + CALL helium_write_line("PBC cell shape: CUBE.") + CASE (helium_cell_shape_octahedron) + CALL helium_write_line("PBC cell shape: TRUNCATED OCTAHEDRON.") + CASE DEFAULT + CALL helium_write_line("*** Warning: unknown cell shape.") + END SELECT + ELSE + CALL helium_write_line("PBC turned off.") + END IF + + IF (helium%droplet_radius .LT. HUGE(1.0_dp)) THEN + WRITE(stmp,*) helium%droplet_radius*angstrom + CALL helium_write_line("Droplet radius: "//TRIM(ADJUSTL(stmp))//" [angstrom]") + END IF + + ! first step gets incremented during first iteration + WRITE(unit_nr,'(T2,A,1X,I0)') TRIM(my_label)//& + " First MC step :", helium%first_step + 1 + WRITE(unit_nr,'(T2,A,1X,I0)') TRIM(my_label)//& + " Last MC step :", helium%last_step + WRITE(unit_nr,'(T2,A,1X,I0)') TRIM(my_label)//& + " Total number of MC steps :", helium%num_steps + WRITE(unit_nr,'(T2,A,1X,I0)') TRIM(my_label)//& + " Number of outer MC trials per step :", helium%iter_rot + WRITE(unit_nr,'(T2,A,1X,I0)') TRIM(my_label)//& + " Number of inner MC trials per step :", helium%iter_norot + i8tmp = INT(helium%iter_rot,int_8) + i8tmp = i8tmp * INT(helium%iter_norot,int_8) + stmp = "" + WRITE(stmp, *) i8tmp + WRITE(unit_nr,'(T2,A)') TRIM(my_label)//& + " Total number of MC trials per step : " // TRIM(ADJUSTL(stmp)) + i8tmp = INT(helium%num_steps,int_8) + i8tmp = i8tmp * INT(helium%iter_rot,int_8) + i8tmp = i8tmp * INT(helium%iter_norot,int_8) + stmp = "" + WRITE(stmp, *) i8tmp + WRITE(unit_nr,'(T2,A)') TRIM(my_label) //& + " Total number of MC trials : " // TRIM(ADJUSTL(stmp)) + + SELECT CASE (helium%sampling_method) + + CASE(helium_sampling_ceperley) + + ! permutation cycle length sampling + stmp = "" + CALL helium_write_line(stmp) + WRITE(stmp,*) helium%maxcycle + stmp2 = "" + WRITE(stmp2,*) "Using maximum permutation cycle length: " //& + TRIM(ADJUSTL(stmp)) + CALL helium_write_line(stmp2) + stmp = "" + WRITE(stmp,*) "Permutation cycle length distribution: " //& + TRIM(ADJUSTL(m_dist_name(helium%m_dist_type))) + CALL helium_write_line(stmp) + stmp = "" + stmp1 = "" + WRITE(stmp1,*) helium%m_ratio + stmp2 = "" + WRITE(stmp2,*) helium%m_value + WRITE(stmp,*) "Using ratio " // TRIM(ADJUSTL(stmp1)) //& + " for M = " // TRIM(ADJUSTL(stmp2)) + CALL helium_write_line(stmp) + stmp = "" + CALL helium_write_line(stmp) + + CASE DEFAULT + WRITE(msg_str,*) helium%sampling_method + msg_str = "Sampling method ("//TRIM(ADJUSTL(msg_str))//") not supported." + CPABORT(msg_str) + + + + END SELECT + + ! solute related data + IF (helium%solute_present) THEN + WRITE(unit_nr,'(T2,A,1X,I0)') TRIM(my_label)//& + " Number of solute atoms: ", helium%solute_atoms + WRITE(unit_nr,'(T2,A,1X,I0)') TRIM(my_label)//& + " Number of solute beads: ", helium%solute_beads + WRITE(unit_nr,'(T2,A,1X,I0)') TRIM(my_label)//& + " Total number of solute particles: ", helium%solute_atoms*& + helium%solute_beads + DO i = 1, helium%enum + WRITE(unit_nr,'(T2,A,1X,A2,A,I0,A,I0,A)', ADVANCE='NO') & + TRIM(my_label)//" Solute atom type: ", & + helium%ename(i), & + "(", & + helium%eid(i), & + "), count: ", & + SIZE(helium%solute_i(helium%eid(i))%iap), & + ", " + first = .TRUE. + DO j = 1, SIZE(helium%solute_i(helium%eid(i))%iap) + IF (first) THEN + WRITE(unit_nr,'(A)', ADVANCE='NO') "indices: " + first = .FALSE. + ELSE + WRITE(unit_nr,'(A)', ADVANCE='NO') ", " + END IF + WRITE(unit_nr,'(I0)', ADVANCE='NO') helium%solute_i(helium%eid(i))%iap(j) + END DO + WRITE(unit_nr,'(1X)') + END DO + + stmp1 = "" + SELECT CASE (helium%solute_interaction) + CASE (helium_solute_intpot_none) + WRITE(stmp1,*) "NONE" + CASE (helium_solute_intpot_mwater) + WRITE(stmp1,*) "MWATER" + CASE DEFAULT + WRITE(stmp1,*) "***UNKNOWN***" + END SELECT + WRITE(unit_nr,'(T2,A,A,A)') & + TRIM(my_label), & + " Solute interaction type: ", & + TRIM(ADJUSTL(stmp1)) + + CALL get_cell(helium%solute_cell, abc=my_abc) + unit_str = "angstrom" + v1 = cp_unit_from_cp2k(my_abc(1), unit_str) + v2 = cp_unit_from_cp2k(my_abc(2), unit_str) + v3 = cp_unit_from_cp2k(my_abc(3), unit_str) + WRITE(unit_nr,'(T2,A,F12.6,1X,F12.6,1X,F12.6)') & + TRIM(my_label)//" Solute cell size ["// & + TRIM(unit_str)//"]: ", v1, v2, v3 + ELSE + WRITE(unit_nr,'(T2,A)') TRIM(my_label)//" Solute is NOT present" + END IF + END IF + CALL helium_write_line("") + + ! RDF related settings + IF (helium%rdf_present) THEN + WRITE(stmp,'(I6)') helium%rdf_num_ctr + CALL helium_write_line("RDF| number of centers: "//TRIM(stmp)) + rtmp = cp_unit_from_cp2k(helium%rdf_delr, "angstrom") + WRITE(stmp, '(1X,F12.6)') rtmp + CALL helium_write_line("RDF| delr [angstrom] : "//TRIM(stmp)) + rtmp = cp_unit_from_cp2k(helium%rdf_maxr, "angstrom") + WRITE(stmp, '(1X,F12.6)') rtmp + CALL helium_write_line("RDF| maxr [angstrom] : "//TRIM(stmp)) + itmp = helium%rdf_nbin + WRITE(stmp, '(I6)') itmp + CALL helium_write_line("RDF| nbin : "//TRIM(stmp)) + CALL helium_write_line("") + ELSE + CALL helium_write_line("RDF| radial distributions will NOT be calculated.") + CALL helium_write_line("") + END IF + + ! RHO related settings + IF (helium%rho_present) THEN + CALL helium_write_line('RHO| The following densities will be calculated:') + DO i = 1, rho_num + IF (helium%rho_property(i)%is_calculated) THEN + WRITE(stmp,'(A)') 'RHO| '//TRIM(helium%rho_property(i)%name) + CALL helium_write_line(TRIM(stmp)) + END IF + END DO + CALL helium_write_line('RHO|') + rtmp = cp_unit_from_cp2k(helium%rho_delr, "angstrom") + WRITE(stmp, '(1X,F12.6)') rtmp + CALL helium_write_line("RHO| delr [angstrom] : "//TRIM(stmp)) + rtmp = cp_unit_from_cp2k(helium%rho_maxr, "angstrom") + WRITE(stmp, '(1X,F12.6)') rtmp + CALL helium_write_line("RHO| maxr [angstrom] : "//TRIM(stmp)) + itmp = helium%rho_nbin + WRITE(stmp, '(I6)') itmp + CALL helium_write_line("RHO| nbin : "//TRIM(stmp)) + CALL helium_write_line("") + ELSE + CALL helium_write_line("RHO| Density distributions will NOT be calculated.") + CALL helium_write_line("") + END IF + + RETURN + END SUBROUTINE helium_write_setup + + +! *************************************************************************** +!> \brief Writes out a line of text to the default output unit +!> \param line ... +!> \date 2009-07-10 +!> \author Lukasz Walewski +! ***************************************************************************** + SUBROUTINE helium_write_line(line) + + CHARACTER(len=*), INTENT(IN) :: line + + CHARACTER(len=*), PARAMETER :: routineN = 'helium_write_line', & + routineP = moduleN//':'//routineN + + CHARACTER(len=default_string_length) :: my_label + INTEGER :: unit_nr + TYPE(cp_logger_type), POINTER :: logger + + NULLIFY(logger) + logger => cp_get_default_logger() + my_label = "HELIUM|" + + IF (logger%para_env%ionode) THEN + unit_nr = cp_logger_get_default_unit_nr(logger) + WRITE(unit_nr,'(T2,A)') TRIM(my_label)//" "//TRIM(line) + END IF + + RETURN + END SUBROUTINE helium_write_line + + +! *************************************************************************** +!> \brief Print energies according to HELIUM%PRINT%ENERGY +!> \param helium ... +!> \date 2009-06-08 +!> \author Lukasz Walewski +! ***************************************************************************** + SUBROUTINE helium_print_energy( helium ) + + TYPE(helium_solvent_type), POINTER :: helium + + CHARACTER(len=*), PARAMETER :: routineN = 'helium_print_energy', & + routineP = moduleN//':'//routineN + + INTEGER :: handle, iteration, m, unit_nr + LOGICAL :: file_is_new, should_output + REAL(KIND=dp) :: naccptd + REAL(KIND=dp), DIMENSION(:), POINTER :: my_energy + TYPE(cp_logger_type), POINTER :: logger + TYPE(section_vals_type), POINTER :: print_key + + CALL timeset(routineN,handle) + + my_energy => helium%energy_avrg + + NULLIFY(logger,print_key) + logger => cp_get_default_logger() + print_key => section_vals_get_subs_vals(helium%input, & + "MOTION%PINT%HELIUM%PRINT%ENERGY") + should_output = BTEST(cp_print_key_should_output( & + iteration_info=logger%iter_info, & + basis_section=print_key), cp_p_file) + + IF ( should_output ) THEN + + iteration = logger%iter_info%iteration(2) + naccptd = 0.0_dp + DO m = 1, helium%maxcycle + naccptd = naccptd + helium%num_accepted(helium%bisctlog2+2,m) + END DO + CALL mp_sum(naccptd,logger%para_env%group) + naccptd = naccptd / REAL(logger%para_env%num_pe,dp) + + IF (logger%para_env%ionode) THEN + + unit_nr=cp_print_key_unit_nr( & + logger, & + print_key, & + middle_name="helium-energy", & + extension=".dat", & + is_new_file=file_is_new) + + IF ( file_is_new ) THEN + WRITE(unit_nr,'(A9,1X,A12,6(1X,A20))')& + "# Step",& + " Naccptd",& + " E_pot",& + " E_kin",& + " E_thermo",& + " E_virial",& + " E_inter",& + " E_tot" + END IF + + WRITE (unit_nr,"(I9,1X,F12.1,6(1X,F20.9))") & + iteration, & + naccptd,& + my_energy(e_id_potential), & + my_energy(e_id_kinetic), & + my_energy(e_id_thermo), & + my_energy(e_id_virial), & + my_energy(e_id_interact), & + my_energy(e_id_total) + + CALL m_flush(unit_nr) + CALL cp_print_key_finished_output(unit_nr,logger,print_key) + + END IF + END IF + + CALL timestop(handle) + + RETURN + END SUBROUTINE helium_print_energy + + +! *************************************************************************** +!> \brief Print a 3D real vector accoring to printkey +!> \param helium ... +!> \param pkey ... +!> \param DATA ... +!> \param uconv ... +!> \param col_label ... +!> \param cmmnt ... +!> \param fname ... +!> \param fpos ... +!> \param avg ... +!> \date 2014-09-09 +!> \author Lukasz Walewski +! ***************************************************************************** + SUBROUTINE helium_print_vector(helium,pkey,DATA,uconv,col_label,cmmnt,fname,fpos,avg) + + TYPE(helium_solvent_type), POINTER :: helium + CHARACTER(len=*) :: pkey + REAL(KIND=dp), DIMENSION(3) :: DATA + REAL(KIND=dp) :: uconv + CHARACTER(len=*), DIMENSION(3) :: col_label + CHARACTER(len=*) :: cmmnt, fname + CHARACTER(len=*), OPTIONAL :: fpos + LOGICAL, OPTIONAL :: avg + + CHARACTER(len=*), PARAMETER :: routineN = 'helium_print_vector', & + routineP = moduleN//':'//routineN + + CHARACTER(len=default_string_length) :: my_fpos + INTEGER :: handle, i, irank, msglen, & + nranks, offset, unit_nr + LOGICAL :: is_new, my_avg, should_output + REAL(KIND=dp), DIMENSION(3) :: avg_data + REAL(KIND=dp), DIMENSION(:), POINTER :: data_p + TYPE(cp_logger_type), POINTER :: logger + TYPE(section_vals_type), POINTER :: psection + + CALL timeset(routineN,handle) + + IF (PRESENT(avg)) THEN + my_avg = avg + ELSE + my_avg = .FALSE. + END IF + + IF (PRESENT(fpos)) THEN + my_fpos = fpos + ELSE + my_fpos = "APPEND" + END IF + + NULLIFY(logger,psection) + logger => cp_get_default_logger() + psection => section_vals_get_subs_vals(helium%input,pkey) + should_output = BTEST(cp_print_key_should_output( & + iteration_info=logger%iter_info, & + basis_section=psection), cp_p_file) + + IF ( .NOT. should_output ) THEN + CALL timestop(handle) + RETURN + END IF + + IF (my_avg) THEN + ! average data over all processors + avg_data(:) = DATA(:) + CALL mp_sum(avg_data,logger%para_env%group) + nranks = logger%para_env%num_pe + ELSE + ! gather data from all processors + CALL mp_gather( DATA, & + helium%rtmp_3_np_1d, & + logger%para_env%source, & + logger%para_env%group ) + END IF + + unit_nr=cp_print_key_unit_nr( & + logger, & + psection, & + middle_name=fname, & + extension=".dat", & + file_position=my_fpos, & + is_new_file=is_new) + + IF (logger%para_env%ionode) THEN + + IF (is_new) THEN + ! comment + IF (cmmnt.NE."") THEN + WRITE(unit_nr, '(A)') "# "//cmmnt + END IF + ! column labels + WRITE(unit_nr, '(A2,A18,1X,A20,1X,A20)') & + "# ",& + col_label(1), & + col_label(2), & + col_label(3) + END IF + + IF (my_avg) THEN + DO i = 1, 3 + WRITE(unit_nr,'(E27.20)',ADVANCE='NO') uconv * avg_data(i) + IF ( i .LT. 3 ) THEN + WRITE(unit_nr,'(1X)',ADVANCE='NO') + END IF + END DO + WRITE(unit_nr, '(A)') "" + ELSE + ! iterate over processors/helium environments + DO irank = 1, helium%num_env + ! unpack data (actually point to the right fragment only) + msglen = SIZE(DATA) + offset = (irank-1) * msglen + data_p => helium%rtmp_3_np_1d(offset+1:offset+msglen) + ! write out the data + DO i = 1, 3 + WRITE(unit_nr,'(E27.20)',ADVANCE='NO') uconv * data_p(i) + IF ( i .LT. 3 ) THEN + WRITE(unit_nr,'(1X)',ADVANCE='NO') + END IF + END DO + WRITE(unit_nr, '(A)') "" + END DO + END IF + + CALL m_flush(unit_nr) + CALL cp_print_key_finished_output(unit_nr,logger,psection) + + END IF + + CALL timestop(handle) + + RETURN + END SUBROUTINE helium_print_vector + + +! *************************************************************************** +!> \brief Print acceptance counts according to HELIUM%PRINT%ACCEPTS +!> \param helium ... +!> \date 2010-05-27 +!> \author Lukasz Walewski +! ***************************************************************************** + SUBROUTINE helium_print_accepts( helium ) + + TYPE(helium_solvent_type), POINTER :: helium + + CHARACTER(len=*), PARAMETER :: routineN = 'helium_print_accepts', & + routineP = moduleN//':'//routineN + + INTEGER :: handle, i, j, unit_nr + LOGICAL :: file_is_new, should_output + TYPE(cp_logger_type), POINTER :: logger + TYPE(section_vals_type), POINTER :: print_key + + CALL timeset(routineN,handle) + + NULLIFY(logger,print_key) + logger => cp_get_default_logger() + print_key => section_vals_get_subs_vals(helium%input, & + "MOTION%PINT%HELIUM%PRINT%ACCEPTS") + should_output = BTEST(cp_print_key_should_output( & + iteration_info=logger%iter_info, & + basis_section=print_key), cp_p_file) + + IF ( should_output ) THEN + + IF (logger%para_env%ionode) THEN + + unit_nr=cp_print_key_unit_nr( & + logger, & + print_key, & + middle_name="helium-accepts", & + extension=".dat", & + is_new_file=file_is_new ) + + IF ( file_is_new ) THEN + WRITE(unit_nr,'(A8,1X,A15,1X,A20)',ADVANCE='NO')& + "# Length",& + " Trials",& + " Selected" + DO j = 1, helium%bisctlog2 + WRITE(unit_nr,'(A17,1X,I3)',ADVANCE='NO') " Level", j + END DO + WRITE(unit_nr, '(A)') "" + END IF + + DO i = 1, helium%maxcycle + WRITE(unit_nr, '(I3)',ADVANCE='NO') i + DO j = 1, helium%bisctlog2 + 2 + WRITE(unit_nr,'(1X,F20.2)',ADVANCE='NO') helium%num_accepted(j,i) + END DO + WRITE(unit_nr, '(A)') "" + END DO + WRITE(unit_nr, '(A)') "&" + + CALL m_flush(unit_nr) + CALL cp_print_key_finished_output(unit_nr,logger,print_key) + + END IF + END IF + + CALL timestop(handle) + RETURN + END SUBROUTINE helium_print_accepts + + +! *************************************************************************** +!> \brief Print permutation state according to HELIUM%PRINT%PERM +!> \param helium ... +!> \date 2010-06-07 +!> \author Lukasz Walewski +! ***************************************************************************** + SUBROUTINE helium_print_perm( helium ) + + TYPE(helium_solvent_type), POINTER :: helium + + CHARACTER(len=*), PARAMETER :: routineN = 'helium_print_perm', & + routineP = moduleN//':'//routineN + + CHARACTER :: left_delim, right_delim + CHARACTER(len=default_string_length) :: msg_str, my_middle_name, stmp + INTEGER :: curat, handle, i, irank, lb, & + msglen, nused, offset, & + outformat, ub, unit_nr + INTEGER, DIMENSION(:), POINTER :: my_cycle, my_perm, & + used_indices + LOGICAL :: first, first_cycle, & + should_output + TYPE(cp_logger_type), POINTER :: logger + TYPE(section_vals_type), POINTER :: print_key + + CALL timeset(routineN,handle) + + NULLIFY(logger,print_key) + logger => cp_get_default_logger() + print_key => section_vals_get_subs_vals(helium%input, & + "MOTION%PINT%HELIUM%PRINT%PERM") + should_output = BTEST(cp_print_key_should_output( & + iteration_info=logger%iter_info,& + basis_section=print_key), cp_p_file) + + IF ( .NOT. should_output ) THEN + CALL timestop(handle) + RETURN + END IF + + ! get the output type + CALL section_vals_val_get(print_key,"FORMAT",i_val=outformat) + + IF (outformat .EQ. perm_cycle) THEN + ! gather positions from all processors to logger%para_env%source + helium%rtmp_3_atoms_beads_1d(:) = PACK( helium%pos(:,:,1:helium%beads), .TRUE. ) + CALL mp_gather( helium%rtmp_3_atoms_beads_1d, & + helium%rtmp_3_atoms_beads_np_1d, & + logger%para_env%source, logger%para_env%group ) + ! set logical mask for unpacking coordinates gathered from other ranks + helium%ltmp_3_atoms_beads_3d(:,:,:) = .TRUE. + END IF + + ! gather permutation state from all processors to logger%para_env%source + helium%itmp_atoms_np_1d(:) = 0 + CALL mp_gather( helium%permutation, & + helium%itmp_atoms_np_1d, & + logger%para_env%source, logger%para_env%group ) + + IF (logger%para_env%ionode) THEN + + ! iterate over processors/helium environments + DO irank = 1, helium%num_env + + ! generate one file per processor + stmp = "" + WRITE(stmp,*) irank + my_middle_name = "helium-perm-" // TRIM(ADJUSTL(stmp)) + unit_nr=cp_print_key_unit_nr( & + logger, & + print_key, & + middle_name=TRIM(my_middle_name), & + extension=".dat" ) + + ! unpack permutation state (actually point to the right section only) + lb = (irank-1) * helium%atoms + 1 + ub = irank * helium%atoms + my_perm => helium%itmp_atoms_np_1d(lb:ub) + + SELECT CASE(outformat) + + CASE (perm_cycle) + ! write the permutation grouped into cycles + + ! unpack coordinates (necessary only for winding path delimiters) + msglen = SIZE(helium%rtmp_3_atoms_beads_1d) + offset = (irank-1) * msglen + helium%work(:,:,1:helium%beads) = & + UNPACK(helium%rtmp_3_atoms_beads_np_1d(offset+1:offset+msglen), & + MASK=helium%ltmp_3_atoms_beads_3d, FIELD=0.0_dp ) + + curat = 1 + nused = 0 + first_cycle = .TRUE. + DO WHILE (curat .LE. helium%atoms) + + ! get the permutation cycle the current atom belongs to + my_cycle => helium_cycle_of(curat, my_perm) + + ! include the current cycle in the pool of "used" indices + nused = nused + SIZE(my_cycle) + CALL reallocate(used_indices,1,nused) + used_indices(nused-SIZE(my_cycle)+1:nused) = my_cycle(1:SIZE(my_cycle)) + + ! select delimiters accoring to the cycle's winding state + IF (helium_is_winding(helium,curat,helium%work,my_perm)) THEN + left_delim = "[" + right_delim = "]" + ELSE + left_delim = "(" + right_delim = ")" + END IF + + ! cycle delimiter + IF (first_cycle) THEN + first_cycle = .FALSE. + ELSE + WRITE(unit_nr,'(1X)',ADVANCE='NO') + END IF + + ! write out the current cycle + WRITE(unit_nr,'(A1)',ADVANCE='NO') left_delim + first = .TRUE. + DO i = 1, SIZE(my_cycle) + IF (first) THEN + first = .FALSE. + ELSE + WRITE(unit_nr,'(1X)',ADVANCE='NO') + END IF + WRITE(unit_nr,'(I0)',ADVANCE='NO') my_cycle(i) + END DO + WRITE(unit_nr,'(A1)',ADVANCE='NO') right_delim + + ! clean up + DEALLOCATE(my_cycle) + NULLIFY(my_cycle) + + ! try to increment the current atom index + DO WHILE (ANY(used_indices .EQ. curat)) + curat = curat + 1 + END DO + + END DO + WRITE(unit_nr,*) + + DEALLOCATE(used_indices) + NULLIFY(used_indices) + + CASE (perm_plain) + ! write the plain permutation + + first = .TRUE. + DO i = 1, helium%atoms + IF (first) THEN + first = .FALSE. + ELSE + WRITE(unit_nr,'(1X)',ADVANCE='NO') + END IF + WRITE(unit_nr,'(I0)',ADVANCE='NO') my_perm(i) + END DO + WRITE(unit_nr, '(A)') "" + + CASE default + + msg_str = "Format for permutation output unknown." + CPABORT( msg_str ) + + END SELECT + + CALL m_flush(unit_nr) + CALL cp_print_key_finished_output(unit_nr,logger,print_key) + + END DO + + END IF + + CALL timestop(handle) + + RETURN + END SUBROUTINE helium_print_perm + + +! *************************************************************************** +!> \brief Print coordinates according to HELIUM%PRINT%COORDINATES +!> \param helium ... +!> \date 2009-07-16 +!> \author Lukasz Walewski +! ***************************************************************************** + SUBROUTINE helium_print_coordinates( helium ) + + TYPE(helium_solvent_type), POINTER :: helium + + CHARACTER(len=*), PARAMETER :: routineN = 'helium_print_coordinates', & + routineP = moduleN//':'//routineN + + CHARACTER(3) :: resName + CHARACTER(len=default_string_length) :: fmt_string, my_middle_name, & + stmp + INTEGER :: handle, ia, ib, ib1, ib2, ic, & + icycle, irank, msglen, & + offset, tmp1, tmp2, unit_nr + INTEGER, DIMENSION(:), POINTER :: my_perm + LOGICAL :: are_connected, is_winding, & + ltmp, should_output + REAL(KIND=dp) :: xtmp, ytmp, ztmp + REAL(KIND=dp), DIMENSION(3) :: r0, r1, r2 + TYPE(cp_logger_type), POINTER :: logger + TYPE(section_vals_type), POINTER :: print_key + + CALL timeset(routineN,handle) + + NULLIFY(logger,print_key) + logger => cp_get_default_logger() + print_key => section_vals_get_subs_vals(helium%input, & + "MOTION%PINT%HELIUM%PRINT%COORDINATES") + should_output = BTEST(cp_print_key_should_output( & + iteration_info=logger%iter_info,& + basis_section=print_key), cp_p_file) + + IF ( .NOT. should_output ) THEN + CALL timestop(handle) + RETURN + END IF + + ! prepare the coordinates for output (use unit cell centered around r0) + r0(:) = helium%center(:) + DO ia = 1, helium%atoms + DO ib = 1, helium%beads + r1(:) = helium%pos(:,ia,ib) - r0(:) + r2(:) = helium%pos(:,ia,ib) - r0(:) + CALL helium_pbc( helium, r2 ) + ltmp = .FALSE. + DO ic = 1, 3 + IF ( ABS(r1(ic)-r2(ic)) .GT. 100.0_dp*EPSILON(0.0_dp) ) THEN + ltmp = .TRUE. + CYCLE + END IF + END DO + IF ( ltmp ) THEN + helium%work(:,ia,ib) = r0(:) + r2(:) + ELSE + helium%work(:,ia,ib) = helium%pos(:,ia,ib) + END IF + END DO + END DO + + ! gather positions from all processors to logger%para_env%source + helium%rtmp_3_atoms_beads_1d(:) = PACK( helium%work(:,:,1:helium%beads), .TRUE. ) + CALL mp_gather( helium%rtmp_3_atoms_beads_1d, & + helium%rtmp_3_atoms_beads_np_1d, & + logger%para_env%source, logger%para_env%group ) + + ! gather permutation state from all processors to logger%para_env%source + CALL mp_gather( helium%permutation, & + helium%itmp_atoms_np_1d, & + logger%para_env%source, logger%para_env%group ) + + ! set logical mask for unpacking coordinates gathered from other ranks + helium%ltmp_3_atoms_beads_3d(:,:,:) = .TRUE. + + IF (logger%para_env%ionode) THEN + + ! iterate over processors/helium environments + DO irank = 1, helium%num_env + + ! generate one file per processor + stmp = "" + WRITE(stmp,*) irank + my_middle_name = "helium-pos-" // TRIM(ADJUSTL(stmp)) + unit_nr=cp_print_key_unit_nr( & + logger, & + print_key, & + middle_name=TRIM(my_middle_name), & + extension=".pdb" ) + + ! write out the unit cell parameters + fmt_string = "(A6,3F9.3,3F7.2,1X,A11,1X,I3)" + xtmp = helium%cell_size + xtmp = cp_unit_from_cp2k(xtmp, "angstrom") + SELECT CASE (helium%cell_shape) + CASE (helium_cell_shape_cube) + stmp = "C " + CASE (helium_cell_shape_octahedron) + stmp = "O " + CASE DEFAULT + stmp = "UNKNOWN " + END SELECT + WRITE(unit_nr,fmt_string) "CRYST1", & + xtmp, xtmp, xtmp, & + 90.0_dp, 90.0_dp, 90.0_dp, & + stmp, helium%beads + + ! unpack coordinates + msglen = SIZE(helium%rtmp_3_atoms_beads_1d) + offset = (irank-1) * msglen + helium%work(:,:,1:helium%beads) = & + UNPACK(helium%rtmp_3_atoms_beads_np_1d(offset+1:offset+msglen), & + MASK=helium%ltmp_3_atoms_beads_3d, FIELD=0.0_dp ) + + ! unpack permutation state (actually point to the right section only) + msglen = SIZE(helium%permutation) + offset = (irank-1) * msglen + my_perm => helium%itmp_atoms_np_1d(offset+1:offset+msglen) + + ! write out coordinates + fmt_string = & + "(A6,I5,1X,A4,A1,A3,1X,A1,I4,A1,3X,3F8.3,2F6.2,10X,A2,A2)" + DO ia = 1, helium%atoms + icycle = helium_cycle_number(helium, ia, my_perm) + is_winding = helium_is_winding(helium,ia,helium%work,my_perm) + IF ( is_winding ) THEN + resName = "SPR" + ELSE + resName = "NRM" + END IF + DO ib = 1, helium%beads + xtmp = helium%work(1,ia,ib) + xtmp = cp_unit_from_cp2k(xtmp, "angstrom") + ytmp = helium%work(2,ia,ib) + ytmp = cp_unit_from_cp2k(ytmp, "angstrom") + ztmp = helium%work(3,ia,ib) + ztmp = cp_unit_from_cp2k(ztmp, "angstrom") + WRITE(unit_nr,fmt_string) "ATOM ", & + (ia-1)*helium%beads+ib, & + " He ", " ", resName, "X", & + icycle, & + " ", & + xtmp, ytmp, ztmp, & + 1.0_dp, 0.0_dp, "HE", " " + END DO + END DO + + ! write out the bead connectivity information + DO ia = 1, helium%atoms + + ! write connectivity records for this atom only if the path + ! it belongs to is longer than 1. + IF ( helium_path_length(helium, ia, my_perm) .LE. 1 ) THEN + CYCLE + END IF + + DO ib = 1, helium%beads-1 + ! check wheather the consecutive beads belong to the same box + r1(:) = helium%work(:,ia,ib) - helium%work(:,ia,ib+1) + r2(:) = r1(:) + CALL helium_pbc( helium, r2 ) + are_connected = .TRUE. + DO ic = 1, 3 + IF ( ABS(r1(ic)-r2(ic)) .GT. 100.0_dp*EPSILON(0.0_dp) ) THEN + ! if the distance betw ib and ib+1 changes upon applying + ! PBC do not connect them + are_connected = .FALSE. + CYCLE + END IF + END DO + IF ( are_connected ) THEN + tmp1 = (ia-1)*helium%beads+ib + tmp2 = (ia-1)*helium%beads+ib+1 + ! smaller value has to go first + IF (tmp1 .LT. tmp2) THEN + ib1 = tmp1 + ib2 = tmp2 + ELSE + ib1 = tmp2 + ib2 = tmp1 + END IF + WRITE(unit_nr,'(A6,2I5)') "CONECT", ib1, ib2 + END IF + END DO + + ! last bead of atom connects to the first bead + ! of the next atom in the permutation cycle + r1(:) = helium%work(:,ia,helium%beads) - helium%work(:,my_perm(ia),1) + r2(:) = r1(:) + CALL helium_pbc( helium, r2 ) + are_connected = .TRUE. + DO ic = 1, 3 + IF ( ABS(r1(ic)-r2(ic)) .GT. 100.0_dp*EPSILON(0.0_dp) ) THEN + ! if the distance betw ib and ib+1 changes upon applying + ! PBC do not connect them + are_connected = .FALSE. + CYCLE + END IF + END DO + IF ( are_connected ) THEN + tmp1 = ia*helium%beads + tmp2 = (my_perm(ia)-1)*helium%beads+1 + IF (tmp1 .LT. tmp2) THEN + ib1 = tmp1 + ib2 = tmp2 + ELSE + ib1 = tmp2 + ib2 = tmp1 + END IF + WRITE(unit_nr,'(A6,2I5)') "CONECT", ib1, ib2 + END IF + END DO + WRITE(unit_nr,'(A)') "END" + + CALL m_flush(unit_nr) + CALL cp_print_key_finished_output(unit_nr,logger,print_key) + + END DO + + END IF + + CALL timestop(handle) + + RETURN + END SUBROUTINE helium_print_coordinates + + +! *************************************************************************** +!> \brief Print radial distribution functions according to HELIUM%PRINT%RDF +!> \param helium ... +!> \date 2009-07-23 +!> \author Lukasz Walewski +! ***************************************************************************** + SUBROUTINE helium_print_rdf( helium) + + TYPE(helium_solvent_type), POINTER :: helium + + CHARACTER(len=*), PARAMETER :: routineN = 'helium_print_rdf', & + routineP = moduleN//':'//routineN + + CHARACTER(len=default_string_length) :: comment, stmp + INTEGER :: handle, ia, ic, id, itmp, & + iweight, nsteps, unit_nr + LOGICAL :: should_output + REAL(KIND=dp) :: inv_norm, rtmp + REAL(KIND=dp), DIMENSION(:, :, :), & + POINTER :: message + TYPE(cp_logger_type), POINTER :: logger + TYPE(section_vals_type), POINTER :: print_key + + CALL timeset(routineN,handle) + + + NULLIFY(logger,print_key) + logger => cp_get_default_logger() + print_key => section_vals_get_subs_vals(helium%input, & + "MOTION%PINT%HELIUM%PRINT%RDF") + should_output = BTEST(cp_print_key_should_output( & + iteration_info=logger%iter_info, & + basis_section=print_key), cp_p_file) + + IF (should_output) THEN + + ! work on the temporary array so that accumulated data remains intact + helium%rdf_inst(:,:,:) = helium%rdf_accu(:,:,:) + + ! average over helium environments + NULLIFY(message) + message => helium%rdf_inst(:,:,:) + CALL mp_sum(message,logger%para_env%group) + itmp = logger%para_env%num_pe + inv_norm = 1.0_dp / REAL(itmp,dp) + helium%rdf_inst(:,:,:) = helium%rdf_inst(:,:,:) * inv_norm + + ! average over steps performed so far in this run + nsteps = helium%current_step-helium%first_step + inv_norm = 1.0_dp / REAL(nsteps,dp) + helium%rdf_inst(:,:,:) = helium%rdf_inst(:,:,:) * inv_norm + + iweight = helium%rdf_iweight + ! average over the old and the current density (observe the weights!) + helium%rdf_inst(:,:,:) = nsteps * helium%rdf_inst(:,:,:) + & + iweight * helium%rdf_rstr(:,:,:) + helium%rdf_inst(:,:,:) = helium%rdf_inst(:,:,:) / REAL(nsteps + iweight,dp) + + IF (logger%para_env%ionode) THEN + + DO id = 1, helium%rdf_num ! loop over estimators --- + + ! overwrite RDF file each time it is written + stmp = "" + WRITE(stmp,*) id + unit_nr=cp_print_key_unit_nr( & + logger, & + print_key, & + middle_name="helium-rdf-"//TRIM(ADJUSTL(stmp)), & + extension=".dat",& + file_position="REWIND", & + do_backup=.FALSE.) + + comment = "Radial distribution function" + + DO ic = 1, helium%rdf_nbin + rtmp = ( REAL(ic,dp) - 0.5_dp ) * helium%rdf_delr + rtmp = cp_unit_from_cp2k(rtmp, "angstrom") + WRITE(unit_nr,'(F20.10)',ADVANCE='NO') rtmp + DO ia = 1, helium%rdf_num_ctr + WRITE(unit_nr,'(F20.10)',ADVANCE='NO') helium%rdf_inst(id,ic,ia) + END DO + WRITE(unit_nr,*) + END DO + + CALL m_flush(unit_nr) + CALL cp_print_key_finished_output(unit_nr,logger,print_key) + + END DO ! loop over estimators --- + + END IF + END IF + + CALL timestop(handle) + + RETURN + END SUBROUTINE helium_print_rdf + + +! *************************************************************************** +!> \brief Print densities according to HELIUM%PRINT%RHO +!> \param helium ... +!> \date 2011-06-21 +!> \par History +!> 08.2015 cleaned code from unneded arrays +!> \author Lukasz Walewski +! ***************************************************************************** + SUBROUTINE helium_print_rho( helium ) + + TYPE(helium_solvent_type), POINTER :: helium + + CHARACTER(len=*), PARAMETER :: routineN = 'helium_print_rho', & + routineP = moduleN//':'//routineN + + CHARACTER(len=default_string_length) :: comment, fname + INTEGER :: handle, ic, id, itmp, & + iweight, nsteps, unit_nr + LOGICAL :: should_output + REAL(KIND=dp) :: inv_norm, invproc + REAL(KIND=dp), DIMENSION(3) :: center + REAL(KIND=dp), DIMENSION(:, :, :), & + POINTER :: cubdata + TYPE(cp_logger_type), POINTER :: logger + TYPE(section_vals_type), POINTER :: print_key + + CALL timeset(routineN,handle) + + NULLIFY(logger,print_key) + logger => cp_get_default_logger() + print_key => section_vals_get_subs_vals(helium%input, & + "MOTION%PINT%HELIUM%PRINT%RHO") + should_output = BTEST(cp_print_key_should_output( & + iteration_info=logger%iter_info, & + basis_section=print_key), cp_p_file) + + IF ( .NOT. should_output ) THEN + CALL timestop(handle) + RETURN + END IF + + ! work on temporary array so that the average remains intact + helium%rho_inst(:,:,:,:) = helium%rho_accu(:,:,:,:) + + ! average over processors / helium environments + CALL mp_sum(helium%rho_inst,logger%para_env%group) + itmp = logger%para_env%num_pe + invproc = 1.0_dp / REAL(itmp,dp) + helium%rho_inst(:,:,:,:) = helium%rho_inst(:,:,:,:) * invproc + + ! average over steps performed so far in this run + nsteps = helium%current_step-helium%first_step + inv_norm = 1.0_dp / REAL(nsteps,dp) + helium%rho_inst(:,:,:,:) = helium%rho_inst(:,:,:,:) * inv_norm + + iweight = helium%rho_iweight + ! average over the old and the current density (observe the weights!) + helium%rho_inst(:,:,:,:) = nsteps * helium%rho_inst(:,:,:,:) + & + iweight * helium%rho_rstr(:,:,:,:) + helium%rho_inst(:,:,:,:) = helium%rho_inst(:,:,:,:) / REAL( nsteps + iweight,dp) + + + ! set center of the cubefile + IF (helium%solute_present) THEN + ! should be set to solute's COM + center(:) = helium%center(:) + ELSE + ! regardless of whether we are periodic or not use the origin, since + ! pure cluster's COM might drift, but we want the cube fixed (note that + ! the densities are correctly calculated wrt to COM in such case) + center(:) = (/0.0_dp, 0.0_dp, 0.0_dp/) + END IF + + DO id = 1, rho_num ! loop over densities --- + + IF (.NOT.helium%rho_property(id)%is_calculated) THEN + ! skip densities that are not requested by the user + CYCLE + END IF + + DO ic = 1, helium%rho_property(id)%num_components ! loop over components + + WRITE(fname,'(A)') "helium-rho-"//& + TRIM(ADJUSTL(helium%rho_property(id)%filename_suffix(ic))) + IF (helium%rho_property(id)%component_name(ic).EQ."") THEN + WRITE(comment,'(A)') TRIM(helium%rho_property(id)%name) + ELSE + WRITE(comment,'(A)') TRIM(helium%rho_property(id)%name)//& + ", "//& + TRIM(helium%rho_property(id)%component_name(ic)) + END IF + cubdata => helium%rho_inst(helium%rho_property(id)%component_index(ic),:,:,:) + + unit_nr=cp_print_key_unit_nr( & + logger, & + print_key, & + middle_name=TRIM(ADJUSTL(fname)), & + extension=".cube", & + file_position="REWIND", & + do_backup=.FALSE.) + + IF (logger%para_env%ionode) THEN + CALL helium_write_cubefile( & + unit_nr, & + comment, & + center-0.5_dp*(helium%rho_maxr-helium%rho_delr), & + helium%rho_delr, & + helium%rho_nbin, & + cubdata ) + CALL m_flush(unit_nr) + CALL cp_print_key_finished_output(unit_nr,logger,print_key) + END IF + + END DO ! loop over components + + END DO ! loop over densities --- + + CALL timestop(handle) + + END SUBROUTINE helium_print_rho + + +! *************************************************************************** +!> \brief Write volumetric data to an orthorhombic cubefile +!> \param unit - unit number to which output will be sent +!> \param comment - description of the data stored in the cubefile +!> \param origin - position of the cubefile origin +!> \param deltar - voxel side length +!> \param ndim - number of voxels in each dimension +!> \param DATA - array (ndim x ndim x ndim) with the data for output +!> \date 2013-11-25 +!> \author Lukasz Walewski +! ***************************************************************************** + SUBROUTINE helium_write_cubefile(unit, comment, origin, deltar, ndim, DATA) + + INTEGER, INTENT(IN) :: unit + CHARACTER(len=default_string_length), & + INTENT(IN) :: comment + REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: origin + REAL(KIND=dp), INTENT(IN) :: deltar + INTEGER, INTENT(IN) :: ndim + REAL(KIND=dp), DIMENSION(:, :, :), & + INTENT(IN), POINTER :: DATA + + CHARACTER(len=*), PARAMETER :: routineN = 'helium_write_cubefile', & + routineP = moduleN//':'//routineN + + INTEGER :: handle, ix, iy, iz, nw + REAL(KIND=dp) :: delr, inva3 + REAL(KIND=dp), DIMENSION(3) :: orig + + CALL timeset(routineN,handle) + + ! convert cubefile data to the proper units of measure + delr = angstrom * deltar + orig(:) = angstrom * origin(:) + + ! output cube file header + WRITE(unit,'(A)') comment + WRITE(unit,'(A)') "Volumetric data in cubefile format generated by CP2K" + WRITE(unit,'(I5,3(1X,F12.8))') 0, orig(1), orig(2), orig(3) + WRITE(unit,'(I5,3(1X,F12.8))') ndim, delr, 0.0_dp, 0.0_dp + WRITE(unit,'(I5,3(1X,F12.8))') ndim, 0.0_dp, delr, 0.0_dp + WRITE(unit,'(I5,3(1X,F12.8))') ndim, 0.0_dp, 0.0_dp, delr + + ! output cube file data + nw = 0 + inva3 = 1.0_dp / (angstrom * angstrom * angstrom ) + DO ix = 1, ndim + DO iy = 1, ndim + DO iz = 1, ndim + WRITE(unit,'(1X,E13.5)', ADVANCE='NO') inva3 * DATA(ix,iy,iz) + nw = nw + 1 + IF ( MOD(nw,6) .EQ. 0 ) THEN + nw = 0 + WRITE(unit,*) + END IF + END DO + END DO + END DO + ! some compilers write over the first entry on a line loosing all previous + ! values written on that line unless line terminator is written at the end + ! so make sure that the last WRITE statement runs without ADVANCE='NO' + ! (observed for ifort 14.0.1 and 14.0.2 but not for gfortran 4.8.2) + IF (nw.NE.0) THEN + WRITE(unit,*) + END IF + + CALL timestop(handle) + + END SUBROUTINE helium_write_cubefile + + +! *************************************************************************** +!> \brief Print permutation length according to HELIUM%PRINT%PLENGTH +!> \param helium ... +!> \date 2010-06-07 +!> \author Lukasz Walewski +! ***************************************************************************** + SUBROUTINE helium_print_plength( helium ) + + TYPE(helium_solvent_type), POINTER :: helium + + CHARACTER(len=*), PARAMETER :: routineN = 'helium_print_plength', & + routineP = moduleN//':'//routineN + + INTEGER :: handle, i, unit_nr + LOGICAL :: is_new, should_output + TYPE(cp_logger_type), POINTER :: logger + TYPE(section_vals_type), POINTER :: print_key + + CALL timeset(routineN,handle) + + NULLIFY(logger,print_key) + logger => cp_get_default_logger() + print_key => section_vals_get_subs_vals(helium%input, & + "MOTION%PINT%HELIUM%PRINT%PLENGTH") + should_output = BTEST(cp_print_key_should_output( & + iteration_info=logger%iter_info, & + basis_section=print_key), cp_p_file) + + IF (should_output) THEN + + IF (logger%para_env%ionode) THEN + + unit_nr=cp_print_key_unit_nr( & + logger, & + print_key, & + middle_name="helium-plength", & + extension=".dat", & + is_new_file=is_new) + + DO i = 1, helium%atoms + WRITE(unit_nr,'(F20.10)',ADVANCE='NO') helium%plength_avrg(i) + IF ( i .LT. helium%atoms ) THEN + WRITE(unit_nr,'(1X)',ADVANCE='NO') + END IF + END DO + WRITE(unit_nr, '(A)') "" + + CALL m_flush(unit_nr) + CALL cp_print_key_finished_output(unit_nr,logger,print_key) + + END IF + END IF + + CALL timestop(handle) + + RETURN + END SUBROUTINE helium_print_plength + + +! *************************************************************************** +!> \brief Print helium force according to HELIUM%PRINT%FORCE +!> \param helium ... +!> \date 2010-01-27 +!> \author Lukasz Walewski +! ***************************************************************************** + SUBROUTINE helium_print_force( helium ) + + TYPE(helium_solvent_type), POINTER :: helium + + CHARACTER(len=*), PARAMETER :: routineN = 'helium_print_force', & + routineP = moduleN//':'//routineN + + CHARACTER(len=default_string_length) :: msgstr + INTEGER :: handle, ia, ib, ic, idim, & + unit_nr + LOGICAL :: should_output + TYPE(cp_logger_type), POINTER :: logger + TYPE(section_vals_type), POINTER :: print_key + + CALL timeset(routineN,handle) + + NULLIFY(logger,print_key) + logger => cp_get_default_logger() + print_key => section_vals_get_subs_vals( helium%input, & + "MOTION%PINT%HELIUM%PRINT%FORCES") + should_output = BTEST(cp_print_key_should_output( & + logger%iter_info, & + basis_section=print_key), cp_p_file) + + IF ( .NOT. should_output ) THEN + CALL timestop(handle) + RETURN + END IF + + ! check if there is anything to be printed out + IF ( .NOT. helium%solute_present ) THEN + msgstr = "Warning: force printout requested but there is no solute!" + CALL helium_write_line( msgstr ) + CALL timestop(handle) + RETURN + END IF + + IF (logger%para_env%ionode) THEN + + unit_nr=cp_print_key_unit_nr( & + logger, & + print_key, & + middle_name="helium-force", & + extension=".dat") + + ! print all force components in one line + DO ib = 1, helium%solute_beads + idim = 0 + DO ia = 1, helium%solute_atoms + DO ic = 1, 3 + idim = idim + 1 + WRITE(unit_nr,'(F20.10)',ADVANCE='NO') helium%force_avrg(ib,idim) + END DO + END DO + END DO + WRITE(unit_nr,*) + + CALL m_flush(unit_nr) + CALL cp_print_key_finished_output(unit_nr,logger,print_key) + + END IF + + CALL timestop(handle) + + RETURN + END SUBROUTINE helium_print_force + +#if 0 + +! *************************************************************************** +!> \brief Print instantaneous force according to HELIUM%PRINT%FORCES_INST +!> \param helium ... +!> \date 2010-01-29 +!> \author Lukasz Walewski +!> \note Collects instantaneous helium forces from all processors on +!> logger%para_env%source and writes them to files - one file per processor. +! ***************************************************************************** + SUBROUTINE helium_print_force_inst( helium ) + + TYPE(helium_solvent_type), POINTER :: helium + + CHARACTER(len=*), PARAMETER :: routineN = 'helium_print_force_inst', & + routineP = moduleN//':'//routineN + + CHARACTER(len=default_string_length) :: my_middle_name, stmp + INTEGER :: handle, ia, ib, ic, idim, & + irank, offset, unit_nr + LOGICAL :: should_output + TYPE(cp_logger_type), POINTER :: logger + TYPE(section_vals_type), POINTER :: print_key + + CALL timeset(routineN,handle) + + NULLIFY(logger,print_key) + logger => cp_get_default_logger() + print_key => section_vals_get_subs_vals( helium%input, & + "MOTION%PINT%HELIUM%PRINT%FORCES_INST") + should_output = BTEST(cp_print_key_should_output( & + logger%iter_info, & + basis_section=print_key), cp_p_file) + + IF ( should_output ) THEN + + ! check if there is anything to be printed out + IF ( .NOT. helium%solute_present ) THEN + stmp = "Warning: force printout requested but there is no solute!" + CALL helium_write_line( stmp ) + CALL timestop(handle) + RETURN + END IF + + ! fill the tmp buffer with instantaneous helium forces at each proc + helium%rtmp_p_ndim_1d(:) = PACK( helium%force_inst, .TRUE. ) + + ! pass the message from all processors to logger%para_env%source + helium%rtmp_p_ndim_np_1d(:) = 0.0_dp + CALL mp_gather( helium%rtmp_p_ndim_1d, helium%rtmp_p_ndim_np_1d, & + logger%para_env%source, logger%para_env%group ) + + IF (logger%para_env%ionode) THEN + + ! iterate over processors/helium environments + DO irank = 1, helium%num_env + + ! generate one file per processor + stmp = "" + WRITE(stmp,*) irank + my_middle_name = "helium-force-inst-" // TRIM(ADJUSTL(stmp)) + unit_nr=cp_print_key_unit_nr( & + logger, & + print_key, & + middle_name=TRIM(my_middle_name), & + extension=".dat") + + ! unpack and actually print the forces - all components in one line + offset = (irank-1) * SIZE(helium%rtmp_p_ndim_1d) + idim = 0 + DO ib = 1, helium%solute_beads + DO ia = 1, helium%solute_atoms + DO ic = 1, 3 + idim = idim + 1 + WRITE(unit_nr,'(F20.10)',ADVANCE='NO') helium%rtmp_p_ndim_np_1d(offset+idim) + END DO + END DO + END DO + WRITE(unit_nr,*) + + CALL m_flush(unit_nr) + CALL cp_print_key_finished_output(unit_nr,logger,print_key) + + END DO + + END IF + END IF + + CALL timestop(handle) + + RETURN + END SUBROUTINE helium_print_force_inst + +#endif + +END MODULE helium_io diff --git a/src/motion/helium_methods.F b/src/motion/helium_methods.F index a087b880e9..3160350a1b 100644 --- a/src/motion/helium_methods.F +++ b/src/motion/helium_methods.F @@ -11,13 +11,15 @@ MODULE helium_methods USE atomic_kind_types, ONLY: get_atomic_kind + USE bibliography, ONLY: Walewski2014,& + cite_reference USE cell_types, ONLY: cell_type,& get_cell USE cp_files, ONLY: close_file,& open_file USE cp_log_handling, ONLY: cp_get_default_logger,& cp_logger_type - USE cp_output_handling, ONLY: silent_print_level + USE cp_output_handling, ONLY: cp_printkey_is_on USE cp_subsys_types, ONLY: cp_subsys_get,& cp_subsys_type USE cp_units, ONLY: cp_unit_from_cp2k @@ -25,16 +27,20 @@ MODULE helium_methods f_env_rm_defaults,& f_env_type USE force_env_types, ONLY: force_env_get - USE helium_common, ONLY: helium_eval_expansion,& + USE helium_common, ONLY: helium_com,& helium_pbc - USE helium_io, ONLY: helium_write_line,& + USE helium_io, ONLY: helium_read_xyz,& + helium_write_line,& helium_write_setup USE helium_sampling, ONLY: helium_sample - USE helium_types, ONLY: he_mass,& - helium_solvent_type + USE helium_types, ONLY: & + he_mass, helium_destroy_int_arr_ptr, helium_solvent_type, hid_carbon, & + hid_chlorine, hid_hydrogen, hid_num, hid_oxygen, rho_atom_number, & + rho_moment_of_inertia, rho_num, rho_projected_area, rho_winding_cycle, & + rho_winding_number USE input_constants, ONLY: helium_cell_shape_cube,& - helium_cell_shape_none,& - helium_cell_shape_octahedron + helium_cell_shape_octahedron,& + helium_solute_intpot_none USE input_section_types, ONLY: section_vals_get,& section_vals_get_subs_vals,& section_vals_type,& @@ -42,7 +48,8 @@ MODULE helium_methods section_vals_val_set USE kinds, ONLY: default_path_length,& default_string_length,& - dp + dp,& + max_line_length USE mathconstants, ONLY: twopi USE message_passing, ONLY: mp_bcast USE parallel_rng_types, ONLY: GAUSSIAN,& @@ -53,7 +60,10 @@ MODULE helium_methods rng_stream_type,& set_rng_stream USE particle_list_types, ONLY: particle_list_type - USE physcon, ONLY: angstrom,& + USE physcon, ONLY: a_mass,& + angstrom,& + boltzmann,& + h_bar,& kelvin,& massunit USE pint_public, ONLY: pint_com_pos @@ -95,14 +105,14 @@ MODULE helium_methods CHARACTER(len=*), PARAMETER :: routineN = 'helium_create', & routineP = moduleN//':'//routineN - CHARACTER(len=default_path_length) :: potential_file_name - CHARACTER(len=default_string_length) :: msg_str, stmp + CHARACTER(len=default_path_length) :: msg_str, potential_file_name + CHARACTER(len=default_string_length) :: stmp INTEGER :: handle, i, input_unit, isize, & - itmp, j, jtmp, nlines, ntab - LOGICAL :: cell_shape_supported, & - expl_cell, expl_dens, & + itmp, j, nlines, ntab + LOGICAL :: expl_cell, expl_dens, & expl_nats, explicit, ltmp - REAL(KIND=dp) :: cgeof, dx, rtmp, tcheck, x1 + REAL(KIND=dp) :: cgeof, dx, mHe, rtmp, T, & + tcheck, x1 REAL(KIND=dp), ALLOCATABLE, & DIMENSION(:, :) :: pot_transfer TYPE(cp_logger_type), POINTER :: logger @@ -110,15 +120,11 @@ MODULE helium_methods CALL timeset(routineN,handle) - - CPASSERT(.NOT.ASSOCIATED(helium)) - CPASSERT(ASSOCIATED(input)) - CPASSERT(input%ref_count>0) + CALL cite_reference(Walewski2014) NULLIFY(helium_section) helium_section => section_vals_get_subs_vals(input, & "MOTION%PINT%HELIUM") CALL section_vals_get(helium_section,explicit=explicit) - CPASSERT(explicit) ALLOCATE(helium) NULLIFY ( helium%input, & helium%ptable, helium%permutation, & @@ -139,11 +145,12 @@ MODULE helium_methods helium%tmatrix, helium%pmatrix, & helium%nmatrix, helium%ipmatrix, & helium%uij, helium%eij, & - helium%rdf_avrg,& helium%rdf_inst,& helium%plength_avrg, & helium%plength_inst, & - helium%atom_plength & + helium%atom_plength, & + helium%ename, & + helium%eid& ) helium%ref_count=1 @@ -156,15 +163,32 @@ MODULE helium_methods NULLIFY(logger) logger => cp_get_default_logger() + ! check if solute is present in our simulation + helium%solute_present = .FALSE. + helium%solute_atoms = 0 + helium%solute_beads = 0 + CALL section_vals_val_get( & + helium_section, & + "HELIUM_ONLY", & + l_val=ltmp) + IF (.NOT. ltmp) THEN + IF (PRESENT(solute)) THEN + IF (ASSOCIATED(solute)) THEN + helium%solute_present = .TRUE. + helium%solute_atoms = solute%ndim / 3 + helium%solute_beads = solute%p + END IF + END IF + END IF + ! get number of environments in the restart file (if present) CALL section_vals_val_get(helium_section,"NUM_ENV",& explicit=explicit) IF ( explicit ) THEN CALL section_vals_val_get(helium_section,"NUM_ENV",& i_val=itmp) - CPASSERT(itmp>=0) helium%num_env_restart = itmp - ELSE + ELSE helium%num_env_restart = -1 END IF @@ -179,11 +203,11 @@ MODULE helium_methods ! will be lost, we won't proceed in this case by default, the user might ! enforce this explicitly though IF ( helium%num_env_restart .GT. helium%num_env ) THEN - stmp = "" + stmp = "" WRITE(stmp,*) helium%num_env msg_str = "Number of He environments in the runtime (" // & TRIM(ADJUSTL(stmp)) // ") smaller than in the restart (" - stmp = "" + stmp = "" WRITE(stmp,*) helium%num_env_restart msg_str = TRIM(ADJUSTL(msg_str)) // TRIM(ADJUSTL(stmp)) // ")!" CALL helium_write_line(msg_str) @@ -191,7 +215,7 @@ MODULE helium_methods l_val=ltmp) IF (ltmp) THEN msg_str = "DROP_UNUSED_ENVS set - proceeding anyways." - CALL helium_write_line(msg_str) + CPWARN(msg_str) ELSE CPABORT(msg_str) END IF @@ -222,32 +246,15 @@ MODULE helium_methods helium%last_step = helium%first_step + helium%num_steps END IF - ! If we should apply periodicity, check wheather we support the cell - ! shape or not, and refuse to proceed if not. Otherwise just go on. + ! boundary conditions CALL section_vals_val_get(helium_section,"PERIODIC",& l_val=helium%periodic) - IF ( helium%periodic ) THEN - CALL section_vals_val_get(helium_section,"CELL_SHAPE",& - i_val=helium%cell_shape) - cell_shape_supported = .FALSE. - IF ( helium%cell_shape .EQ. helium_cell_shape_cube ) THEN - cell_shape_supported = .TRUE. - END IF - IF ( helium%cell_shape .EQ. helium_cell_shape_octahedron ) THEN - cell_shape_supported = .TRUE. - END IF - IF ( .NOT. cell_shape_supported ) THEN - stmp = "" - WRITE(stmp,*) helium%cell_shape - msg_str = "PBC cell shape " // & - TRIM(ADJUSTL(stmp)) // & - " not supported for HELIUM" - CPABORT(msg_str) - END IF - ELSE - helium%cell_shape = helium_cell_shape_none - END IF - ! Further PBC code depends on the correct value of helium%cell_shape. + CALL section_vals_val_get(helium_section,"CELL_SHAPE",& + i_val=helium%cell_shape) + + CALL section_vals_val_get(helium_section,"DROPLET_RADIUS",& + r_val=helium%droplet_radius) + ! Set density Rho, number of atoms N and volume V ( Rho = N / V ). ! Allow only 2 out of 3 values to be defined at the same time, calculate @@ -264,7 +271,9 @@ MODULE helium_methods CALL section_vals_val_get(helium_section,"CELL_SIZE",& explicit=expl_cell) cgeof = 1.0_dp - IF ( helium%cell_shape .EQ. helium_cell_shape_octahedron ) cgeof = 2.0_dp + IF (helium%periodic) THEN + IF ( helium%cell_shape .EQ. helium_cell_shape_octahedron ) cgeof = 2.0_dp + END IF rtmp = ( cgeof * helium%atoms / helium%density )**(1.0_dp/3.0_dp) IF ( .NOT. expl_cell ) THEN helium%cell_size = rtmp @@ -277,15 +286,15 @@ MODULE helium_methods IF ( expl_dens .AND. expl_nats ) THEN msg_str = "DENSITY, NATOMS and CELL_SIZE options "//& "contradict each other" - CPABORT(msg_str) + CPWARN(msg_str) END IF !ok we have enough freedom to resolve the conflict: IF ( .NOT. expl_dens ) THEN helium%density = cgeof*helium%atoms / helium%cell_size**3.0_dp IF ( .NOT. expl_nats ) THEN - msg_str = "Warning: CELL_SIZE defined but neither "//& + msg_str = "CELL_SIZE defined but neither "//& "NATOMS nor DENSITY given, using default NATOMS." - CALL helium_write_line(msg_str) + CPWARN(msg_str) END IF ELSE ! ( expl_dens .AND. .NOT. expl_nats ) ! calculate the nearest number of atoms for given conditions @@ -297,9 +306,9 @@ MODULE helium_methods )**(1.0_dp/3.0_dp) IF ( ABS(helium%cell_size-rtmp) .GT. 100.0_dp*EPSILON(0.0_dp)& * ( ABS(helium%cell_size)+rtmp ) ) THEN - msg_str = "Warning: Adjusting actual cell size "//& + msg_str = "Adjusting actual cell size "//& "to maintain correct density." - CALL helium_write_line(msg_str) + CPWARN(msg_str) helium%cell_size = rtmp END IF END IF @@ -310,80 +319,97 @@ MODULE helium_methods ! correctly defined. ! set the M matrix for winding number calculations - IF ( helium%cell_shape .EQ. helium_cell_shape_octahedron ) THEN - helium%cell_m_inv(1,1) = 1.0_dp / helium%cell_size; - helium%cell_m_inv(2,1) = 0.0_dp; - helium%cell_m_inv(3,1) = 0.0_dp; - helium%cell_m_inv(1,2) = 0.0_dp; - helium%cell_m_inv(2,2) = 1.0_dp / helium%cell_size; - helium%cell_m_inv(3,2) = 0.0_dp; - helium%cell_m_inv(1,3) = -1.0_dp / helium%cell_size; - helium%cell_m_inv(2,3) = -1.0_dp / helium%cell_size; - helium%cell_m_inv(3,3) = 2.0_dp / helium%cell_size; - ELSE - helium%cell_m_inv(1,1) = 1.0_dp / helium%cell_size; - helium%cell_m_inv(2,1) = 0.0_dp; - helium%cell_m_inv(3,1) = 0.0_dp; - helium%cell_m_inv(1,2) = 0.0_dp; - helium%cell_m_inv(2,2) = 1.0_dp / helium%cell_size; - helium%cell_m_inv(3,2) = 0.0_dp; - helium%cell_m_inv(1,3) = 0.0_dp; - helium%cell_m_inv(2,3) = 0.0_dp; - helium%cell_m_inv(3,3) = 1.0_dp / helium%cell_size; - END IF + SELECT CASE (helium%cell_shape) + + CASE (helium_cell_shape_octahedron) + helium%cell_m(1,1) = helium%cell_size; + helium%cell_m(2,1) = 0.0_dp; + helium%cell_m(3,1) = 0.0_dp; + helium%cell_m(1,2) = 0.0_dp; + helium%cell_m(2,2) = helium%cell_size; + helium%cell_m(3,2) = 0.0_dp; + helium%cell_m(1,3) = helium%cell_size / 2.0_dp; + helium%cell_m(2,3) = helium%cell_size / 2.0_dp; + helium%cell_m(3,3) = helium%cell_size / 2.0_dp; + + helium%cell_m_inv(1,1) = 1.0_dp / helium%cell_size; + helium%cell_m_inv(2,1) = 0.0_dp; + helium%cell_m_inv(3,1) = 0.0_dp; + helium%cell_m_inv(1,2) = 0.0_dp; + helium%cell_m_inv(2,2) = 1.0_dp / helium%cell_size; + helium%cell_m_inv(3,2) = 0.0_dp; + helium%cell_m_inv(1,3) = -1.0_dp / helium%cell_size; + helium%cell_m_inv(2,3) = -1.0_dp / helium%cell_size; + helium%cell_m_inv(3,3) = 2.0_dp / helium%cell_size; + + CASE (helium_cell_shape_cube) + + helium%cell_m(1,1) = helium%cell_size; + helium%cell_m(2,1) = 0.0_dp; + helium%cell_m(3,1) = 0.0_dp; + helium%cell_m(1,2) = 0.0_dp; + helium%cell_m(2,2) = helium%cell_size; + helium%cell_m(3,2) = 0.0_dp; + helium%cell_m(1,3) = 0.0_dp; + helium%cell_m(2,3) = 0.0_dp; + helium%cell_m(3,3) = helium%cell_size; + + helium%cell_m_inv(1,1) = 1.0_dp / helium%cell_size; + helium%cell_m_inv(2,1) = 0.0_dp; + helium%cell_m_inv(3,1) = 0.0_dp; + helium%cell_m_inv(1,2) = 0.0_dp; + helium%cell_m_inv(2,2) = 1.0_dp / helium%cell_size; + helium%cell_m_inv(3,2) = 0.0_dp; + helium%cell_m_inv(1,3) = 0.0_dp; + helium%cell_m_inv(2,3) = 0.0_dp; + helium%cell_m_inv(3,3) = 1.0_dp / helium%cell_size; + + CASE DEFAULT + helium%cell_m(:,:) = 0.0_dp + helium%cell_m_inv(:,:) = 0.0_dp + + END SELECT ! check value of maxcycle CALL section_vals_val_get(helium_section,"MAX_PERM_CYCLE",& i_val=helium%maxcycle) i = helium%maxcycle - CPASSERT(i>=0) i = helium%atoms - helium%maxcycle - CPASSERT(i>=0) ! set m-distribution parameters + CALL section_vals_val_get(helium_section,"M-SAMPLING%DISTRIBUTION-TYPE",& + i_val=i) + helium%m_dist_type = i CALL section_vals_val_get(helium_section,"M-SAMPLING%M-VALUE",& i_val=i) - CPASSERT(i>=1) - CPASSERT(i<=helium%maxcycle) helium%m_value = i CALL section_vals_val_get(helium_section,"M-SAMPLING%M-RATIO",& r_val=rtmp) - CPASSERT(rtmp>0.0_dp) - CPASSERT(rtmp<=1.0_dp) helium%m_ratio = rtmp CALL section_vals_val_get(helium_section,"BISECTION",& i_val=helium%bisection) ! precheck bisection value (not all invalids are filtered out here yet) i = helium%bisection - CPASSERT(i>1) i = helium%beads - helium%bisection - CPASSERT(i>0) ! itmp = helium%bisection - rtmp = 2**(ANINT(LOG(REAL(itmp))/LOG(2.0_dp))) + rtmp = 2.0_dp**(ANINT(LOG(REAL(itmp,dp))/LOG(2.0_dp))) tcheck=ABS(REAL(itmp,KIND=dp)-rtmp) - msg_str = "BISECTION should be integer power of 2." - IF(tcheck>=100.0_dp*EPSILON(0.0_dp)) CPABORT(msg_str) - helium%bisctlog2 = NINT(LOG(REAL(itmp,KIND=dp))/LOG(2.0_dp)) + IF (tcheck>100.0_dp*EPSILON(0.0_dp)) THEN + msg_str = "BISECTION should be integer power of 2." + CPABORT(msg_str) + END IF + helium%bisctlog2 = NINT(LOG(REAL(itmp,dp))/LOG(2.0_dp)) + + CALL section_vals_val_get(helium_section,"SAMPLING_METHOD", & + i_val=helium%sampling_method) ! hard coded He4 directly (mass so i get my original hb2m value) ! He4 mass defined as a constant in helium_types.F now [lwalewski] helium%hb2m = 1.0_dp/(he_mass*massunit) - helium%pweight = 0.0_dp - ! get the RDF parameters - CALL section_vals_val_get(helium_section,"RDF%MAXR",& - explicit=explicit) - IF (explicit) THEN - CALL section_vals_val_get(helium_section,"RDF%MAXR",& - r_val=helium%rdf_maxr) - ELSE - helium%rdf_maxr = helium%cell_size - END IF - CALL section_vals_val_get(helium_section,"RDF%NBIN",& - i_val=helium%rdf_nbin) - helium%rdf_delr = helium%rdf_maxr / REAL(helium%rdf_nbin,KIND=dp) + helium%pweight = 0.0_dp IF (logger%para_env%ionode) THEN CALL section_vals_val_get(helium_section,"POTENTIAL_FILE_NAME",& @@ -407,6 +433,17 @@ MODULE helium_methods CALL mp_bcast(dx,logger%para_env%source,& logger%para_env%group) + ! boltzmann : Boltzmann constant [J/K] + ! h_bar : Planck constant [J*s] + ! J = kg*m^2/s^2 + ! 4He mass in [kg] + mHe = he_mass * a_mass + ! physical temperature [K] + T = kelvin / helium%tau / helium%beads + ! prefactors for calculating superfluid fractions [Angstrom^-2] + helium%wpref = (((1e-20/h_bar)*mHe)/h_bar)*boltzmann*T + helium%apref = (((4e-20/h_bar)*mHe)/h_bar)*boltzmann*T + isize = helium%pdx+1 ALLOCATE(helium%uij(isize,isize)) ALLOCATE(helium%eij(isize,isize)) @@ -462,8 +499,9 @@ MODULE helium_methods ! ALLOCATE helium-related arrays i = helium%atoms j = helium%beads - ALLOCATE(helium%pos(3,i,j)) - ALLOCATE(helium%work(3,i,j)) + ALLOCATE(helium%pos(3,i,j+1)) + helium%pos = 0.0_dp + ALLOCATE(helium%work(3,i,j+1)) ALLOCATE(helium%ptable(helium%maxcycle+1)) ALLOCATE(helium%permutation(i)) ALLOCATE(helium%iperm(i)) @@ -473,85 +511,71 @@ MODULE helium_methods ALLOCATE(helium%ipmatrix(i,i)) itmp = helium%bisctlog2 + 2 ALLOCATE(helium%num_accepted(itmp,helium%maxcycle)) - ALLOCATE(helium%rdf_avrg(helium%rdf_nbin)) - ALLOCATE(helium%rdf_inst(helium%rdf_nbin)) ALLOCATE(helium%plength_avrg(helium%atoms)) ALLOCATE(helium%plength_inst(helium%atoms)) ALLOCATE(helium%atom_plength(helium%atoms)) - ! density related data - helium%rho_num = 1 - CALL section_vals_val_get(helium_section, & - "RHO%_SECTION_PARAMETERS_", & - l_val=helium%rho_present) - IF ( helium%rho_present ) THEN - helium%rho_maxr = helium%cell_size - CALL section_vals_val_get(helium%input, & - "MOTION%PINT%HELIUM%RHO%IWEIGHT",& - i_val=helium%rho_iweight) - CALL section_vals_val_get(helium_section,"RHO%NBIN",& - i_val=helium%rho_nbin) - helium%rho_delr = helium%rho_maxr / REAL(helium%rho_nbin,KIND=dp) - helium%rho_minb = INT(-helium%cell_size / 2.0_dp / helium%rho_delr ) - itmp = helium%rho_nbin - jtmp = helium%rho_num - ALLOCATE(helium%rho_avrg(jtmp,itmp,itmp,itmp)) - ALLOCATE(helium%rho_inst(jtmp,itmp,itmp,itmp)) - helium%rho_avrg(:,:,:,:) = 0.0_dp - helium%rho_inst(:,:,:,:) = 0.0_dp - - ! make sure that the density gets actually printed, - ! as we will make so much effort to calculated it - CALL section_vals_val_set(helium%input, & - "MOTION%PINT%HELIUM%PRINT%RHO%_SECTION_PARAMETERS_",& - i_val=silent_print_level-1) + ! check whether rdfs should be calculated and printed + helium%rdf_present = helium_property_active(helium,"RDF") + IF (helium%rdf_present) THEN + ! allocate & initialize rdf related data structures + CALL helium_rdf_init(helium) END IF - CALL section_vals_val_get(helium%input, & - "EXT_RESTART%RESTART_HELIUM_DENSITIES", & - l_val=helium%rho_restart) - IF ( helium%rho_restart ) THEN - IF ( helium%rho_present) THEN - CALL helium_densities_restore( helium) - ELSE - msg_str = "Inconsistent input: densities not calculated but restarted!" - CPABORT(msg_str) - END IF + ! check whether densities should be calculated and printed + helium%rho_present = helium_property_active(helium,"RHO") + IF (helium%rho_present) THEN + ! allocate & initialize density related data structures + NULLIFY(helium%rho_property) + CALL helium_rho_init(helium) END IF + ! restore averages calculated in previous runs + CALL helium_averages_restore(helium) + ! RNG state create & init - CALL helium_rng_state_init( helium) - - ! check if solute is present in our simulation - helium%solute_present = .FALSE. - IF (PRESENT(solute)) THEN - IF (ASSOCIATED(solute)) THEN - helium%solute_present = .TRUE. - END IF - END IF + CALL helium_rng_init( helium ) ! fill in the solute-related data structures helium%e_corr = 0.0_dp IF (helium%solute_present) THEN - helium%solute_atoms = solute%ndim / 3 - helium%solute_beads = solute%p helium%bead_ratio = helium%beads / helium%solute_beads ! check if bead numbers are commensurate: i = helium%bead_ratio*helium%solute_beads - helium%beads !TODO Adjust helium bead number if not comm. and if coords not given expl. - CPASSERT(i==0) ! check if tau, temperature and bead number are consistent: tcheck=ABS( (helium%tau*helium%beads-solute%beta) / solute%beta ) - msg_str = "Tau, temperature and bead number are inconsistent." - IF(tcheck>=1.0e-14_dp) CPABORT(msg_str) + IF (tcheck>1.0e-14_dp) THEN + msg_str = "Tau, temperature and bead number are inconsistent." + CPABORT(msg_str) + END IF CALL helium_set_solute_indices(helium,solute) CALL helium_set_solute_cell(helium,solute) + + ! set the interaction potential type + CALL section_vals_val_get(helium_section,"SOLUTE_INTERACTION",& + i_val=helium%solute_interaction) + IF (helium%solute_interaction .EQ. helium_solute_intpot_none) THEN + WRITE(msg_str,'(A,I0,A)') & + "Solute found but no helium-solute interaction selected "//& + "(see SOLUTE_INTERACTION keyword)" + CPABORT(msg_str) + END IF + + ! ALLOCATE solute-related arrays + ALLOCATE(helium%force_avrg(helium%solute_beads,& + helium%solute_atoms*3)) + ALLOCATE(helium%force_inst(helium%solute_beads,& + helium%solute_atoms*3)) + + ALLOCATE(helium%rtmp_p_ndim_1d(solute%p*solute%ndim)) + ALLOCATE(helium%rtmp_p_ndim_np_1d(solute%p*solute%ndim*helium%num_env)) + ALLOCATE(helium%rtmp_p_ndim_2d(solute%p,solute%ndim)) + ELSE - helium%solute_atoms = 0 - helium%solute_beads = 0 helium%bead_ratio = 0 IF (helium%periodic) THEN ! this assumes a specific potential (and its ugly): @@ -568,33 +592,20 @@ MODULE helium_methods END IF END IF - ! ALLOCATE solute-related arrays - ALLOCATE(helium%force_avrg(helium%solute_beads,& - helium%solute_atoms*3)) - ALLOCATE(helium%force_inst(helium%solute_beads,& - helium%solute_atoms*3)) - ! ALLOCATE temporary arrays ALLOCATE(helium%itmp_atoms_1d(helium%atoms)) ALLOCATE(helium%ltmp_atoms_1d(helium%atoms)) ALLOCATE(helium%itmp_atoms_np_1d(helium%atoms*helium%num_env)) ALLOCATE(helium%rtmp_3_np_1d(3*helium%num_env)) - ALLOCATE(helium%rtmp_p_ndim_1d(helium%solute_beads*& - helium%solute_atoms*3)) - ALLOCATE(helium%rtmp_p_ndim_np_1d(helium%solute_beads*& - helium%solute_atoms*3*helium%num_env)) ALLOCATE(helium%rtmp_3_atoms_beads_1d(3*helium%atoms*& helium%beads)) ALLOCATE(helium%rtmp_3_atoms_beads_np_1d(3*helium%atoms*& helium%beads*helium%num_env)) - ALLOCATE(helium%rtmp_p_ndim_2d(helium%solute_beads,& - helium%solute_atoms*3)) ALLOCATE(helium%ltmp_3_atoms_beads_3d(3,helium%atoms,& helium%beads)) CALL helium_write_setup(helium) - CALL timestop(handle) RETURN @@ -612,42 +623,103 @@ MODULE helium_methods routineP = moduleN//':'//routineN INTEGER :: i, j + LOGICAL :: failure + + failure=.FALSE. IF (ASSOCIATED(helium)) THEN - CPASSERT(helium%ref_count>0) helium%ref_count=helium%ref_count-1 IF (helium%ref_count<1) THEN ! DEALLOCATE temporary arrays DEALLOCATE ( & helium%ltmp_3_atoms_beads_3d, & - helium%rtmp_p_ndim_2d, & helium%rtmp_3_atoms_beads_np_1d, & helium%rtmp_3_atoms_beads_1d, & - helium%rtmp_p_ndim_np_1d, & - helium%rtmp_p_ndim_1d, & helium%rtmp_3_np_1d, & helium%itmp_atoms_np_1d, & helium%ltmp_atoms_1d, & helium%itmp_atoms_1d) - ! DEALLOCATE solute-related arrays - DEALLOCATE (helium%force_inst, helium%force_avrg) + NULLIFY ( & + helium%ltmp_3_atoms_beads_3d, & + helium%rtmp_3_atoms_beads_np_1d, & + helium%rtmp_3_atoms_beads_1d, & + helium%rtmp_3_np_1d, & + helium%itmp_atoms_np_1d, & + helium%ltmp_atoms_1d, & + helium%itmp_atoms_1d & + ) + + IF (helium%solute_present) THEN + ! DEALLOCATE solute-related arrays + DEALLOCATE ( & + helium%rtmp_p_ndim_2d, & + helium%rtmp_p_ndim_np_1d, & + helium%rtmp_p_ndim_1d, & + helium%force_inst, & + helium%force_avrg) + NULLIFY( & + helium%rtmp_p_ndim_2d, & + helium%rtmp_p_ndim_np_1d, & + helium%rtmp_p_ndim_1d, & + helium%force_inst, & + helium%force_avrg ) + END IF IF ( helium%rho_present ) THEN - IF ( helium%rho_restart ) THEN - DEALLOCATE( helium%rho_rstr) - END IF - DEALLOCATE(helium%rho_inst, helium%rho_avrg) + DEALLOCATE( & + helium%rho_rstr, & + helium%rho_accu, & + helium%rho_inst, & + helium%rho_incr) + NULLIFY(& + helium%rho_rstr, & + helium%rho_accu, & + helium%rho_inst, & + helium%rho_incr) + ! DEALLOCATE everything + DEALLOCATE(helium%rho_property(rho_atom_number)%filename_suffix) + DEALLOCATE(helium%rho_property(rho_atom_number)%component_name) + DEALLOCATE(helium%rho_property(rho_atom_number)%component_index) + NULLIFY(helium%rho_property(rho_atom_number)%filename_suffix) + NULLIFY(helium%rho_property(rho_atom_number)%component_name) + NULLIFY(helium%rho_property(rho_atom_number)%component_index) + DEALLOCATE(helium%rho_property(rho_winding_number)%filename_suffix) + DEALLOCATE(helium%rho_property(rho_winding_number)%component_name) + DEALLOCATE(helium%rho_property(rho_winding_number)%component_index) + NULLIFY(helium%rho_property(rho_winding_number)%filename_suffix) + NULLIFY(helium%rho_property(rho_winding_number)%component_name) + NULLIFY(helium%rho_property(rho_winding_number)%component_index) + DEALLOCATE(helium%rho_property(rho_winding_cycle)%filename_suffix) + DEALLOCATE(helium%rho_property(rho_winding_cycle)%component_name) + DEALLOCATE(helium%rho_property(rho_winding_cycle)%component_index) + NULLIFY(helium%rho_property(rho_winding_cycle)%filename_suffix) + NULLIFY(helium%rho_property(rho_winding_cycle)%component_name) + NULLIFY(helium%rho_property(rho_winding_cycle)%component_index) + DEALLOCATE(helium%rho_property(rho_projected_area)%filename_suffix) + DEALLOCATE(helium%rho_property(rho_projected_area)%component_name) + DEALLOCATE(helium%rho_property(rho_projected_area)%component_index) + NULLIFY(helium%rho_property(rho_projected_area)%filename_suffix) + NULLIFY(helium%rho_property(rho_projected_area)%component_name) + NULLIFY(helium%rho_property(rho_projected_area)%component_index) + DEALLOCATE(helium%rho_property(rho_moment_of_inertia)%filename_suffix) + DEALLOCATE(helium%rho_property(rho_moment_of_inertia)%component_name) + DEALLOCATE(helium%rho_property(rho_moment_of_inertia)%component_index) + NULLIFY(helium%rho_property(rho_moment_of_inertia)%filename_suffix) + NULLIFY(helium%rho_property(rho_moment_of_inertia)%component_name) + NULLIFY(helium%rho_property(rho_moment_of_inertia)%component_index) + DEALLOCATE(helium%rho_property) + NULLIFY(helium%rho_property) END IF + CALL helium_rdf_release (helium) + ! DEALLOCATE helium-related arrays DEALLOCATE ( & helium%atom_plength, & helium%plength_inst, & helium%plength_avrg, & - helium%rdf_inst, & - helium%rdf_avrg, & helium%num_accepted, & helium%ipmatrix, & helium%pmatrix, & @@ -658,6 +730,22 @@ MODULE helium_methods helium%ptable, & helium%work, & helium%pos) + NULLIFY( & + helium%atom_plength, & + helium%plength_inst, & + helium%plength_avrg, & + helium%num_accepted, & + helium%ipmatrix, & + helium%pmatrix, & + helium%nmatrix, & + helium%tmatrix, & + helium%iperm, & + helium%permutation, & + helium%ptable, & + helium%work, & + helium%pos & + ) + DO i = 1, SIZE ( helium%eij , 1 ) DO j = 1, SIZE ( helium%eij , 1 ) CALL spline_data_release(helium%eij(i,j)%spline_data) @@ -668,41 +756,40 @@ MODULE helium_methods END DO END DO - DEALLOCATE( helium%eij) + DEALLOCATE(helium%eij) + NULLIFY(helium%eij) - DEALLOCATE( helium%uij) + DEALLOCATE(helium%uij) + NULLIFY(helium%uij) CALL delete_rng_stream(helium%rng_stream_uniform) CALL delete_rng_stream(helium%rng_stream_gaussian) ! deallocate solute-related arrays IF (helium%solute_present) THEN - DEALLOCATE(helium%solute_element, helium%solute_number, helium%solute_index) + CALL helium_destroy_int_arr_ptr(helium%solute_i) + DEALLOCATE(helium%solute_element) + NULLIFY(helium%solute_element) + END IF + + ! Deallocate everything from the helium_set_solute_indices + IF (ASSOCIATED(helium%ename)) THEN + DEALLOCATE(helium%ename) + NULLIFY(helium%ename) END IF - DEALLOCATE( helium) + IF (ASSOCIATED(helium%eid)) THEN + DEALLOCATE(helium%eid) + NULLIFY(helium%eid) + END IF + + DEALLOCATE( helium ) END IF END IF RETURN END SUBROUTINE helium_release -! *************************************************************************** -!> \brief Retains helium_solvent_type -!> \param helium ... -!> \author hforbert -! ***************************************************************************** - SUBROUTINE helium_retain(helium) - TYPE(helium_solvent_type), POINTER :: helium - - CHARACTER(len=*), PARAMETER :: routineN = 'helium_retain', & - routineP = moduleN//':'//routineN - - CPASSERT(ASSOCIATED(helium)) - CPASSERT(helium%ref_count>0) - helium%ref_count=helium%ref_count+1 - RETURN - END SUBROUTINE helium_retain ! *************************************************************************** !> \brief Initialize helium data structures. @@ -717,7 +804,7 @@ MODULE helium_methods !> Initializes helium permutation state as identity permutation or !> from HELIUM%PERM section if it's present in the input file. ! ***************************************************************************** - SUBROUTINE helium_init( helium, pint_env) + SUBROUTINE helium_init( helium, pint_env ) TYPE(helium_solvent_type), POINTER :: helium TYPE(pint_env_type), POINTER :: pint_env @@ -725,33 +812,25 @@ MODULE helium_methods CHARACTER(len=*), PARAMETER :: routineN = 'helium_init', & routineP = moduleN//':'//routineN - INTEGER :: handle + INTEGER :: handle, i LOGICAL :: coords_presampled, explicit, & - explicit_presample, presample + failure, presample TYPE(section_vals_type), POINTER :: helium_section, sec CALL timeset(routineN,handle) - CPASSERT(ASSOCIATED(helium)) - CPASSERT(ASSOCIATED(helium%input)) + failure = .FALSE. NULLIFY(helium_section) helium_section => section_vals_get_subs_vals(helium%input, & "MOTION%PINT%HELIUM") - ! set the origin for rdf and density calculations - IF (helium%solute_present) THEN - helium%origin = pint_com_pos(pint_env) - ELSE - helium%origin = (/0.0_dp, 0.0_dp, 0.0_dp/) - END IF - ! restore RNG state NULLIFY(sec) sec => section_vals_get_subs_vals(helium_section,"RNG_STATE") CALL section_vals_get(sec,explicit=explicit) IF ( explicit ) THEN - CALL helium_rng_state_restore( helium) + CALL helium_rng_restore( helium ) ELSE CALL helium_write_line("RNG state initialized as new.") END IF @@ -761,9 +840,9 @@ MODULE helium_methods sec => section_vals_get_subs_vals(helium_section,"PERM") CALL section_vals_get(sec,explicit=explicit) IF ( explicit ) THEN - CALL helium_perm_restore( helium) + CALL helium_perm_restore( helium ) ELSE - CALL helium_perm_init( helium) + CALL helium_perm_init( helium ) CALL helium_write_line("Permutation state initialized as identity.") END IF @@ -771,53 +850,43 @@ MODULE helium_methods NULLIFY(sec) sec => section_vals_get_subs_vals(helium_section,"COORD") CALL section_vals_get(sec,explicit=explicit) - + IF ( explicit ) THEN + CALL helium_coord_restore( helium ) + ELSE + CALL helium_coord_init (helium) + END IF + DO i=1,helium%atoms + helium%pos(:,i,helium%beads+1)=helium%pos(:,helium%permutation(i),1) + END DO + helium%work=helium%pos + + ! Optional helium coordinate presampling: CALL section_vals_val_get(helium_section,"PRESAMPLE",& l_val=presample) - CALL section_vals_val_get(helium_section,"PRESAMPLE",& - explicit=explicit_presample) - coords_presampled = .FALSE. - IF ( explicit ) THEN - CALL helium_coord_restore( helium) - IF ( presample ) THEN - ! Default value of PINT%HELIUM%PRESAMPLE is .FALSE. so if the actual - ! value is .TRUE. it must have been supplied explicitly. - ! This might be used to force presampling even though the cooridnates - ! are given in the restart file. - CALL helium_sample( helium, pint_env) - helium%force_avrg(:,:) = 0.0_dp - helium%energy_avrg(:) = 0.0_dp - helium%wnumber_avrg(:) = 0.0_dp - helium%sdensity_avrg = 0.0_dp - helium%plength_avrg(:) = 0.0_dp - helium%rdf_avrg(:) = 0.0_dp - helium%num_accepted(:,:) = 0.0_dp - coords_presampled = .TRUE. - CALL helium_write_line("Bead coordinates pre-sampled.") - END IF + IF ( presample ) THEN + helium%current_step = 0 + CALL helium_sample( helium, pint_env ) + IF (helium%solute_present) helium%force_avrg(:,:) = 0.0_dp + helium%energy_avrg(:) = 0.0_dp + helium%plength_avrg(:) = 0.0_dp + helium%num_accepted(:,:) = 0.0_dp + coords_presampled = .TRUE. + CALL helium_write_line("Bead coordinates pre-sampled.") + END IF + + ! Specify if forces should be obtained as AVG or LAST + CALL section_vals_val_get(helium_section, "GET_FORCES",& + i_val=helium%get_helium_forces) + + ! init center of mass + IF (helium%solute_present) THEN + helium%center(:) = pint_com_pos(pint_env) ELSE - CALL helium_coord_init( helium) - CALL helium_write_line("Bead coordinates initialized as random.") - IF ( (explicit_presample .AND. presample) .OR. & - (.NOT. explicit_presample) ) THEN - ! Perform initial MC sampling to get rid of the overlaps. - ! This IF catches two cases: a) PRESAMPLE given explicitly and it's - ! value set to .TRUE. and b) PRESAMPLE not given explicitly (then - ! it's value is set to .FALSE. by default. It does not catch the - ! case when PRESAMPLE is given explicitly and it's value is set to - ! .FALSE. - this might be used to skip presampling even though the - ! coordinates are not given in the restart file. - CALL helium_sample( helium, pint_env) - helium%force_avrg(:,:) = 0.0_dp - helium%energy_avrg(:) = 0.0_dp - helium%wnumber_avrg(:) = 0.0_dp - helium%sdensity_avrg = 0.0_dp - helium%plength_avrg(:) = 0.0_dp - helium%rdf_avrg(:) = 0.0_dp - helium%num_accepted(:,:) = 0.0_dp - coords_presampled = .TRUE. - CALL helium_write_line("Bead coordinates pre-sampled.") + IF (helium%periodic) THEN + helium%center(:) = (/0.0_dp, 0.0_dp, 0.0_dp/) + ELSE + helium%center(:) = helium_com(helium) END IF END IF @@ -828,11 +897,11 @@ MODULE helium_methods CALL section_vals_get(sec,explicit=explicit) IF ( explicit ) THEN IF ( .NOT. coords_presampled ) THEN - CALL helium_force_restore( helium) + CALL helium_force_restore( helium ) END IF ELSE IF ( .NOT. coords_presampled ) THEN - CALL helium_force_init( helium) + CALL helium_force_init (helium) CALL helium_write_line("Forces on the solute initialized as zero.") END IF END IF @@ -843,11 +912,12 @@ MODULE helium_methods RETURN END SUBROUTINE helium_init + ! *************************************************************************** - ! Data transfer functions. - ! - ! These functions manipulate and transfer data between the runtime - ! environment and the input structure. +! Data transfer functions. +! +! These functions manipulate and transfer data between the runtime +! environment and the input structure. ! *************************************************************************** ! *************************************************************************** @@ -856,16 +926,17 @@ MODULE helium_methods !> \date 2009-11-09 !> \author Lukasz Walewski ! ***************************************************************************** - SUBROUTINE helium_coord_init( helium) + SUBROUTINE helium_coord_init(helium) TYPE(helium_solvent_type), POINTER :: helium CHARACTER(len=*), PARAMETER :: routineN = 'helium_coord_init', & routineP = moduleN//':'//routineN INTEGER :: ia, ib, ic - REAL(kind=dp) :: r1, r2 + LOGICAL :: failure + REAL(KIND=dp) :: r1, r2 - CPASSERT(ASSOCIATED(helium)) + failure=.FALSE. DO ia = 1, helium%atoms DO ic = 1, 3 @@ -882,6 +953,13 @@ MODULE helium_methods END DO END DO + ! store positions at time slice nbeads+1 (rperez): + DO ia = 1, helium%atoms + helium%pos(:,ia,helium%beads+1) = helium%pos(:,ia,1) + END DO + ! initialize work array (rperez): + helium%work=helium%pos + RETURN END SUBROUTINE helium_coord_init @@ -894,7 +972,7 @@ MODULE helium_methods !> restart [lwalewski] !> \author Lukasz Walewski ! ***************************************************************************** - SUBROUTINE helium_coord_restore( helium) + SUBROUTINE helium_coord_restore( helium ) TYPE(helium_solvent_type), POINTER :: helium CHARACTER(len=*), PARAMETER :: routineN = 'helium_coord_restore', & @@ -903,13 +981,14 @@ MODULE helium_methods CHARACTER(len=default_string_length) :: err_str, stmp INTEGER :: actlen, msglen, & num_env_restart, offset + LOGICAL :: failure LOGICAL, DIMENSION(:, :, :), POINTER :: m - REAL(kind=dp), DIMENSION(:), POINTER :: message - REAL(kind=dp), DIMENSION(:, :, :), & + REAL(KIND=dp), DIMENSION(:), POINTER :: message + REAL(KIND=dp), DIMENSION(:, :, :), & POINTER :: f TYPE(cp_logger_type), POINTER :: logger - CPASSERT(ASSOCIATED(helium)) + failure=.FALSE. NULLIFY(logger) logger => cp_get_default_logger() @@ -933,7 +1012,7 @@ MODULE helium_methods ALLOCATE(f(3,helium%atoms,helium%beads)) m(:,:,:) = .TRUE. f(:,:,:) = 0.0_dp - helium%pos(:,:,:) = UNPACK(message(offset+1:offset+msglen), MASK=m, FIELD=f ) + helium%pos(:,:,1:helium%beads) = UNPACK(message(offset+1:offset+msglen), MASK=m, FIELD=f ) DEALLOCATE(f,m) IF ( num_env_restart .NE. logger%para_env%num_pe ) THEN @@ -969,26 +1048,23 @@ MODULE helium_methods END SUBROUTINE helium_coord_restore ! *************************************************************************** -!> \brief Initialize forces exerted on the solute. +!> \brief Initialize forces exerted on the solute !> \param helium ... !> \date 2009-11-10 !> \author Lukasz Walewski -!> \note The forces are calculated based on both the helium and the solute -!> positions, hence this function should be called AFTER -!> helium_coord_init/restore. ! ***************************************************************************** - SUBROUTINE helium_force_init( helium) + SUBROUTINE helium_force_init (helium) + TYPE(helium_solvent_type), POINTER :: helium CHARACTER(len=*), PARAMETER :: routineN = 'helium_force_init', & routineP = moduleN//':'//routineN - CPASSERT(ASSOCIATED(helium)) + LOGICAL :: failure + + failure=.FALSE. IF ( helium%solute_present ) THEN -!TODO initial forces are set to 0 due to possible overlapping atoms -! CALL helium_solute_e_f(pint_env, helium, rtmp) -! ELSE helium%force_avrg(:,:) = 0.0_dp helium%force_inst(:,:) = 0.0_dp END IF @@ -996,26 +1072,27 @@ MODULE helium_methods RETURN END SUBROUTINE helium_force_init + ! *************************************************************************** !> \brief Restore forces from the input structure to the runtime environment. !> \param helium ... !> \date 2009-11-10 !> \author Lukasz Walewski ! ***************************************************************************** - SUBROUTINE helium_force_restore( helium) + SUBROUTINE helium_force_restore( helium ) TYPE(helium_solvent_type), POINTER :: helium CHARACTER(len=*), PARAMETER :: routineN = 'helium_force_restore', & routineP = moduleN//':'//routineN CHARACTER(len=default_string_length) :: err_str, stmp - INTEGER :: actlen, msglen, & - num_env_restart + INTEGER :: actlen, msglen + LOGICAL :: failure LOGICAL, DIMENSION(:, :), POINTER :: m - REAL(kind=dp), DIMENSION(:), POINTER :: message - REAL(kind=dp), DIMENSION(:, :), POINTER :: f + REAL(KIND=dp), DIMENSION(:), POINTER :: message + REAL(KIND=dp), DIMENSION(:, :), POINTER :: f - CPASSERT(ASSOCIATED(helium)) + failure=.FALSE. ! assign the pointer to the memory location of the input structure, where ! the forces are stored @@ -1024,10 +1101,6 @@ MODULE helium_methods "MOTION%PINT%HELIUM%FORCE%_DEFAULT_KEYWORD_", & r_vals=message) - ! check the number of environments presumably stored in the restart - actlen = SIZE(message) - num_env_restart = actlen / helium%solute_atoms / helium%solute_beads / 3 - ! check if the destination array has correct size msglen = helium%solute_atoms * helium%solute_beads * 3 actlen = SIZE(helium%force_avrg) @@ -1038,9 +1111,11 @@ MODULE helium_methods TRIM(ADJUSTL(stmp)) // "' but expected '" stmp = "" WRITE(stmp,*) msglen - err_str = TRIM(ADJUSTL(err_str)) // & - TRIM(ADJUSTL(stmp)) // "'." - IF(actlen/=msglen) CPABORT(err_str) + IF (actlen/=msglen) THEN + err_str = TRIM(ADJUSTL(err_str)) // & + TRIM(ADJUSTL(stmp)) // "'." + CPABORT(err_str) + END IF ! restore forces on all processors (no message passing) NULLIFY(m,f) @@ -1064,18 +1139,19 @@ MODULE helium_methods !> \param helium ... !> \date 2009-11-05 !> \author Lukasz Walewski -!> \note Assign the identity permutation at each processor. Inverse +!> \note Assign the identity permutation at each processor. Inverse !> permutation array gets assigned as well. ! ***************************************************************************** - SUBROUTINE helium_perm_init( helium) + SUBROUTINE helium_perm_init( helium ) TYPE(helium_solvent_type), POINTER :: helium CHARACTER(len=*), PARAMETER :: routineN = 'helium_perm_init', & routineP = moduleN//':'//routineN INTEGER :: ia + LOGICAL :: failure - CPASSERT(ASSOCIATED(helium)) + failure=.FALSE. DO ia = 1, helium%atoms helium%permutation(ia) = ia @@ -1093,11 +1169,11 @@ MODULE helium_methods !> 2010-07-22 accomodate additional cpus in the runtime wrt the !> restart [lwalewski] !> \author Lukasz Walewski -!> \note Transfer permutation state from the input tree to the runtime +!> \note Transfer permutation state from the input tree to the runtime !> data structures on each processor. Inverse permutation array is !> recalculated according to the restored permutation state. ! ***************************************************************************** - SUBROUTINE helium_perm_restore( helium) + SUBROUTINE helium_perm_restore( helium ) TYPE(helium_solvent_type), POINTER :: helium CHARACTER(len=*), PARAMETER :: routineN = 'helium_perm_restore', & @@ -1107,9 +1183,10 @@ MODULE helium_methods INTEGER :: actlen, ia, ic, msglen, & num_env_restart, offset INTEGER, DIMENSION(:), POINTER :: message + LOGICAL :: failure TYPE(cp_logger_type), POINTER :: logger - CPASSERT(ASSOCIATED(helium)) + failure=.FALSE. NULLIFY(logger) logger => cp_get_default_logger() @@ -1172,35 +1249,154 @@ MODULE helium_methods err_str = "Invalid HELIUM%PERM state: some numbers not within (1," stmp = "" WRITE(stmp,*) msglen - err_str = TRIM(ADJUSTL(err_str)) // & - TRIM(ADJUSTL(stmp)) // ")." - IF(ic/=msglen) CPABORT(err_str) + IF (ic/=msglen) THEN + err_str = TRIM(ADJUSTL(err_str)) // & + TRIM(ADJUSTL(stmp)) // ")." + CPABORT(err_str) + END IF NULLIFY(message) RETURN END SUBROUTINE helium_perm_restore + +! *************************************************************************** +!> \brief Restore averages from the input structure +!> \param helium ... +!> \date 2014-06-25 +!> \author Lukasz Walewski +! ***************************************************************************** + SUBROUTINE helium_averages_restore(helium) + + TYPE(helium_solvent_type), POINTER :: helium + + CHARACTER(len=*), PARAMETER :: routineN = 'helium_averages_restore', & + routineP = moduleN//':'//routineN + + INTEGER :: msglen, num_env_restart, & + offset + LOGICAL :: explicit + REAL(KIND=dp), DIMENSION(:), POINTER :: message + TYPE(cp_logger_type), POINTER :: logger + + NULLIFY(logger) + logger => cp_get_default_logger() + + ! restore projected area + CALL section_vals_val_get( helium%input, & + "MOTION%PINT%HELIUM%AVERAGES%PROJECTED_AREA", & + explicit=explicit) + IF (explicit) THEN + NULLIFY(message) + CALL section_vals_val_get( helium%input, & + "MOTION%PINT%HELIUM%AVERAGES%PROJECTED_AREA", & + r_vals=message) + num_env_restart = SIZE(message) / 3 ! apparent number of environments + msglen = 3 + offset = msglen * MOD( logger%para_env%mepos, num_env_restart ) + helium%proarea%rstr(:) = message(offset+1:offset+msglen) + ELSE + helium%proarea%rstr(:) = 0.0_dp + END IF + + ! restore projected area squared + CALL section_vals_val_get( helium%input, & + "MOTION%PINT%HELIUM%AVERAGES%PROJECTED_AREA_2", & + explicit=explicit) + IF (explicit) THEN + NULLIFY(message) + CALL section_vals_val_get( helium%input, & + "MOTION%PINT%HELIUM%AVERAGES%PROJECTED_AREA_2", & + r_vals=message) + num_env_restart = SIZE(message) / 3 ! apparent number of environments + msglen = 3 + offset = msglen * MOD( logger%para_env%mepos, num_env_restart ) + helium%prarea2%rstr(:) = message(offset+1:offset+msglen) + ELSE + helium%prarea2%rstr(:) = 0.0_dp + END IF + + ! restore winding number squared + CALL section_vals_val_get( helium%input, & + "MOTION%PINT%HELIUM%AVERAGES%WINDING_NUMBER_2", & + explicit=explicit) + IF (explicit) THEN + NULLIFY(message) + CALL section_vals_val_get( helium%input, & + "MOTION%PINT%HELIUM%AVERAGES%WINDING_NUMBER_2", & + r_vals=message) + num_env_restart = SIZE(message) / 3 ! apparent number of environments + msglen = 3 + offset = msglen * MOD( logger%para_env%mepos, num_env_restart ) + helium%wnmber2%rstr(:) = message(offset+1:offset+msglen) + ELSE + helium%wnmber2%rstr(:) = 0.0_dp + END IF + + ! restore moment of inertia + CALL section_vals_val_get( helium%input, & + "MOTION%PINT%HELIUM%AVERAGES%MOMENT_OF_INERTIA", & + explicit=explicit) + IF (explicit) THEN + NULLIFY(message) + CALL section_vals_val_get( helium%input, & + "MOTION%PINT%HELIUM%AVERAGES%MOMENT_OF_INERTIA", & + r_vals=message) + num_env_restart = SIZE(message) / 3 ! apparent number of environments + msglen = 3 + offset = msglen * MOD( logger%para_env%mepos, num_env_restart ) + helium%mominer%rstr(:) = message(offset+1:offset+msglen) + ELSE + helium%mominer%rstr(:) = 0.0_dp + END IF + + IF ( helium%rdf_present ) THEN + CALL helium_rdf_restore( helium ) + END IF + + IF (helium%rho_present) THEN + ! restore densities + CALL helium_rho_restore( helium ) + END IF + + ! get the weighting factor + CALL section_vals_val_get( & + helium%input, & + "MOTION%PINT%HELIUM%AVERAGES%IWEIGHT", & + i_val=helium%averages_iweight) + + ! set the flag indicating whether the averages have been restarted + CALL section_vals_val_get( & + helium%input, & + "EXT_RESTART%RESTART_HELIUM_AVERAGES", & + l_val=helium%averages_restarted) + + RETURN + END SUBROUTINE helium_averages_restore + + ! *************************************************************************** !> \brief Create RNG streams and initialize their state. !> \param helium ... !> \date 2009-11-04 !> \author Lukasz Walewski -!> \note This function shouldn't create (allocate) objects! Only -!> initialization, i.e. setting the seed values etc, should be done -!> here, allocation should be moved to helium_create +!> \note TODO: This function shouldn't create (allocate) objects! Only +!> initialization, i.e. setting the seed values etc, should be done +!> here, allocation should be moved to helium_create ! ***************************************************************************** - SUBROUTINE helium_rng_state_init( helium) + SUBROUTINE helium_rng_init( helium ) TYPE(helium_solvent_type), POINTER :: helium - CHARACTER(len=*), PARAMETER :: routineN = 'helium_rng_state_init', & + CHARACTER(len=*), PARAMETER :: routineN = 'helium_rng_init', & routineP = moduleN//':'//routineN INTEGER :: rank + LOGICAL :: failure TYPE(cp_logger_type), POINTER :: logger TYPE(rng_stream_type), POINTER :: next_rngs, prev_rngs - CPASSERT(ASSOCIATED(helium)) + failure=.FALSE. NULLIFY(logger) logger => cp_get_default_logger() @@ -1266,7 +1462,7 @@ MODULE helium_methods END DO RETURN - END SUBROUTINE helium_rng_state_init + END SUBROUTINE helium_rng_init ! *************************************************************************** !> \brief Restore RNG state from the input structure. @@ -1277,24 +1473,24 @@ MODULE helium_methods !> runtime than in the restart [lwalewski] !> \author Lukasz Walewski ! ***************************************************************************** - SUBROUTINE helium_rng_state_restore( helium) + SUBROUTINE helium_rng_restore( helium ) TYPE(helium_solvent_type), POINTER :: helium - CHARACTER(len=*), PARAMETER :: routineN = 'helium_rng_state_restore', & + CHARACTER(len=*), PARAMETER :: routineN = 'helium_rng_restore', & routineP = moduleN//':'//routineN CHARACTER(len=default_string_length) :: err_str, stmp INTEGER :: actlen, msglen, & num_env_restart, offset, rank - LOGICAL :: lbf + LOGICAL :: failure, lbf LOGICAL, DIMENSION(3, 2) :: m - REAL(kind=dp) :: bf, bu - REAL(kind=dp), DIMENSION(3, 2) :: bg, cg, f, ig - REAL(kind=dp), DIMENSION(:), POINTER :: message + REAL(KIND=dp) :: bf, bu + REAL(KIND=dp), DIMENSION(3, 2) :: bg, cg, f, ig + REAL(KIND=dp), DIMENSION(:), POINTER :: message TYPE(cp_logger_type), POINTER :: logger TYPE(rng_stream_type), POINTER :: next_rngs, prev_rngs - CPASSERT(ASSOCIATED(helium)) + failure=.FALSE. NULLIFY(logger) logger => cp_get_default_logger() @@ -1312,39 +1508,39 @@ MODULE helium_methods IF ( logger%para_env%mepos .LT. num_env_restart ) THEN - ! unpack the buffer at each processor, set RNG state (no message passing) - msglen = 40 - offset = msglen * logger%para_env%mepos - m(:,:) = .TRUE. - f(:,:) = 0.0_dp + ! unpack the buffer at each processor, set RNG state (no message passing) + msglen = 40 + offset = msglen * logger%para_env%mepos + m(:,:) = .TRUE. + f(:,:) = 0.0_dp bg(:,:) = UNPACK(message(offset+1:offset+6), MASK=m, FIELD=f ) cg(:,:) = UNPACK(message(offset+7:offset+12), MASK=m, FIELD=f ) ig(:,:) = UNPACK(message(offset+13:offset+18), MASK=m, FIELD=f ) bf = message(offset+19) bu = message(offset+20) - IF ( bf .GT. 0) THEN - lbf = .TRUE. - ELSE - lbf = .FALSE. - END IF - CALL set_rng_stream(helium%rng_stream_uniform,bg=bg,cg=cg,ig=ig,& - buffer=bu,buffer_filled=lbf) + IF ( bf .GT. 0) THEN + lbf = .TRUE. + ELSE + lbf = .FALSE. + END IF + CALL set_rng_stream(helium%rng_stream_uniform,bg=bg,cg=cg,ig=ig,& + buffer=bu,buffer_filled=lbf) bg(:,:) = UNPACK(message(offset+21:offset+26), MASK=m, FIELD=f ) cg(:,:) = UNPACK(message(offset+27:offset+32), MASK=m, FIELD=f ) ig(:,:) = UNPACK(message(offset+33:offset+38), MASK=m, FIELD=f ) bf = message(offset+39) bu = message(offset+40) - IF ( bf .GT. 0) THEN - lbf = .TRUE. - ELSE - lbf = .FALSE. - END IF - CALL set_rng_stream(helium%rng_stream_gaussian,bg=bg,cg=cg,ig=ig,& - buffer=bu,buffer_filled=lbf) + IF ( bf .GT. 0) THEN + lbf = .TRUE. + ELSE + lbf = .FALSE. + END IF + CALL set_rng_stream(helium%rng_stream_gaussian,bg=bg,cg=cg,ig=ig,& + buffer=bu,buffer_filled=lbf) ELSE ! On processors that did not receive rng state from the restart file - ! delete rng streams created in helium_rng_state_init and create them + ! delete rng streams created in helium_rng_init and create them ! anew, as they have been initialized with default initial state. Here ! the sequence of rng streams starts from the last stream from the ! restart file, each stream is initialized from the previously created @@ -1474,8 +1670,584 @@ MODULE helium_methods NULLIFY(message) - RETURN - END SUBROUTINE helium_rng_state_restore + RETURN + END SUBROUTINE helium_rng_restore + + +! *************************************************************************** +!> \brief Create the RDF related data structures and initialize +!> \param helium ... +!> \date 2014-02-25 +!> \author Lukasz Walewski +! ***************************************************************************** + SUBROUTINE helium_rdf_init(helium) + + TYPE(helium_solvent_type), POINTER :: helium + + CHARACTER(len=*), PARAMETER :: routineN = 'helium_rdf_init', & + routineP = moduleN//':'//routineN + + CHARACTER(len=default_path_length) :: file_name + CHARACTER(len=default_string_length) :: err_str, stmp + INTEGER :: ifirst, ii, ij, ik + LOGICAL :: explicit + REAL(KIND=dp), DIMENSION(:), POINTER :: coords + TYPE(cp_logger_type), POINTER :: logger + + IF (helium%solute_present) THEN + ! get number of centers from solute + helium%rdf_num_ctr = helium%solute_atoms + ELSE + ! use center of the unit cell or COM of the He droplet + helium%rdf_num_ctr = 1 + END IF + ifirst = helium%rdf_num_ctr + + ! read auxiliary centers from file + NULLIFY(logger) + logger => cp_get_default_logger() + CALL section_vals_val_get( & + helium%input, & + "MOTION%PINT%HELIUM%RDF%CENTERS_FILE_NAME",& + c_val=file_name, & + explicit=explicit) + NULLIFY(coords) + IF (explicit) THEN + CALL section_vals_val_get( & + helium%input, & + "MOTION%PINT%HELIUM%RDF%CENTERS_FILE_NAME", & + c_val=file_name) + CALL helium_read_xyz(coords,file_name,logger%para_env) + END IF + + ! increment number of centers if necessary + IF (ASSOCIATED(coords)) THEN + helium%rdf_num_ctr = helium%rdf_num_ctr + SIZE(coords)/3 + END IF + + ! set the flag for RDF and either proceed or return + IF (helium%rdf_num_ctr>0) THEN + helium%rdf_present = .TRUE. + ELSE + helium%rdf_present = .FALSE. + RETURN + END IF + + ! allocate & store auxiliary centers (align to the end of array) + ALLOCATE(helium%rdf_centers(3*helium%rdf_num_ctr)) + helium%rdf_centers(:) = 0.0_dp + IF (ASSOCIATED(coords)) THEN + ii = 3*ifirst+1 + ij = 3*helium%rdf_num_ctr + helium%rdf_centers(ii:ij) = coords(:) + DEALLOCATE(coords) + NULLIFY(coords) + END IF + + helium%rdf_num = 4 ! see also helium%rho_num_def + + ! set the maximum RDF range + CALL section_vals_val_get( & + helium%input, & + "MOTION%PINT%HELIUM%RDF%MAXR", & + explicit=explicit) + IF (explicit) THEN + ! use the value explicitly set in the input + CALL section_vals_val_get( & + helium%input, & + "MOTION%PINT%HELIUM%RDF%MAXR",& + r_val=helium%rdf_maxr) + ELSE + ! use the default value + CALL section_vals_val_get( & + helium%input, & + "MOTION%PINT%HELIUM%DROPLET_RADIUS", & + explicit=explicit) + IF (explicit) THEN + ! use the droplet radius + helium%rdf_maxr = helium%droplet_radius + ELSE + ! use cell_size and cell_shape + ! (they are set regardless of us being periodic or not) + SELECT CASE (helium%cell_shape) + CASE (helium_cell_shape_cube) + helium%rdf_maxr = helium%cell_size / 2.0_dp + CASE (helium_cell_shape_octahedron) + helium%rdf_maxr = helium%cell_size * SQRT(3.0_dp) / 4.0_dp + CASE DEFAULT + helium%rdf_maxr = 0.0_dp + WRITE(stmp,*) helium%cell_shape + err_str = "cell shape unknown (" // TRIM(ADJUSTL(stmp)) // ")" + CPABORT(err_str) + END SELECT + END IF + END IF + + ! get number of bins and set bin spacing + CALL section_vals_val_get( & + helium%input, & + "MOTION%PINT%HELIUM%RDF%NBIN", & + i_val=helium%rdf_nbin) + helium%rdf_delr = helium%rdf_maxr / REAL(helium%rdf_nbin,dp) + + ! get the weighting factor + CALL section_vals_val_get( & + helium%input, & + "MOTION%PINT%HELIUM%AVERAGES%IWEIGHT", & + i_val=helium%rdf_iweight) + + ! allocate and initialize memory for RDF storage + ii = helium%rdf_num + ij = helium%rdf_nbin + ik = helium%rdf_num_ctr + ALLOCATE(helium%rdf_inst(ii,ij,ik)) + ALLOCATE(helium%rdf_accu(ii,ij,ik)) + ALLOCATE(helium%rdf_rstr(ii,ij,ik)) + helium%rdf_inst(:,:,:) = 0.0_dp + helium%rdf_accu(:,:,:) = 0.0_dp + helium%rdf_rstr(:,:,:) = 0.0_dp + + RETURN + END SUBROUTINE helium_rdf_init + + +! *************************************************************************** +!> \brief Restore the RDFs from the input structure +!> \param helium ... +!> \date 2011-06-22 +!> \author Lukasz Walewski +! ***************************************************************************** + SUBROUTINE helium_rdf_restore (helium) + + TYPE(helium_solvent_type), POINTER :: helium + + CHARACTER(len=*), PARAMETER :: routineN = 'helium_rdf_restore', & + routineP = moduleN//':'//routineN + + CHARACTER(len=default_string_length) :: stmp1, stmp2 + CHARACTER(len=max_line_length) :: err_str + INTEGER :: ii, ij, ik, itmp, msglen + LOGICAL :: explicit, ltmp + LOGICAL, DIMENSION(:, :, :), POINTER :: m + REAL(KIND=dp), DIMENSION(:), POINTER :: message + REAL(KIND=dp), DIMENSION(:, :, :), & + POINTER :: f + + CALL section_vals_val_get( helium%input, & + "MOTION%PINT%HELIUM%AVERAGES%RDF", & + explicit=explicit) + IF (explicit) THEN + NULLIFY(message) + CALL section_vals_val_get( helium%input, & + "MOTION%PINT%HELIUM%AVERAGES%RDF", & + r_vals=message) + msglen = SIZE(message) + itmp = SIZE(helium%rdf_rstr) + ltmp = ( msglen .EQ. itmp ) + IF ( .NOT. ltmp ) THEN + stmp1 = "" + WRITE(stmp1,*) msglen + stmp2 = "" + WRITE(stmp2,*) itmp + err_str = "Size of the RDF array in the input (" // & + TRIM(ADJUSTL(stmp1)) // & + ") .NE. that in the runtime (" // & + TRIM(ADJUSTL(stmp2)) // ")." + CPABORT(err_str) + END IF + ELSE + RETURN + END IF + + ii = helium%rdf_num + ij = helium%rdf_nbin + ik = helium%rdf_num_ctr + NULLIFY(m,f) + ALLOCATE(m(ii,ij,ik)) + ALLOCATE(f(ii,ij,ik)) + m(:,:,:) = .TRUE. + f(:,:,:) = 0.0_dp + + helium%rdf_rstr(:,:,:) = UNPACK(message(1:msglen), MASK=m, FIELD=f) + CALL section_vals_val_get( helium%input, & + "MOTION%PINT%HELIUM%AVERAGES%IWEIGHT", & + i_val=helium%rdf_iweight) + + DEALLOCATE(f,m) + NULLIFY(message) + + RETURN + END SUBROUTINE helium_rdf_restore + + +! *************************************************************************** +!> \brief Release/deallocate RDF related data structures +!> \param helium ... +!> \date 2014-02-25 +!> \author Lukasz Walewski +! ***************************************************************************** + SUBROUTINE helium_rdf_release (helium) + + TYPE(helium_solvent_type), POINTER :: helium + + CHARACTER(len=*), PARAMETER :: routineN = 'helium_rdf_release', & + routineP = moduleN//':'//routineN + + IF (helium%rdf_present) THEN + + DEALLOCATE( & + helium%rdf_centers, & + helium%rdf_rstr, & + helium%rdf_accu, & + helium%rdf_inst) + + NULLIFY( & + helium%rdf_centers, & + helium%rdf_rstr, & + helium%rdf_accu, & + helium%rdf_inst ) + + END IF + + RETURN + END SUBROUTINE helium_rdf_release + + +! *************************************************************************** +!> \brief Check whether property is activated in the input structure +!> \param helium ... +!> \param prop ... +!> \retval is_active ... +!> \date 2014-06-26 +!> \author Lukasz Walewski +!> \note The property is controlled by two items in the input structure, +!> the printkey and the control section. Two settings result in +!> the property being considered active: +!> 1. printkey is on at the given print level +!> 2. control section is explicit and on +!> If the property is considered active it should be calculated +!> and printed through out the run. +! ***************************************************************************** + FUNCTION helium_property_active(helium,prop) RESULT(is_active) + + TYPE(helium_solvent_type), POINTER :: helium + CHARACTER(len=*) :: prop + LOGICAL :: is_active + + CHARACTER(len=*), PARAMETER :: routineN = 'helium_property_active', & + routineP = moduleN//':'//routineN + + CHARACTER(len=default_string_length) :: input_path + INTEGER :: print_level + LOGICAL :: explicit, is_on + TYPE(cp_logger_type), POINTER :: logger + TYPE(section_vals_type), POINTER :: print_key, section + + NULLIFY(logger) + logger => cp_get_default_logger() + + ! if the printkey is on at this runlevel consider prop to be active + NULLIFY(print_key) + input_path = "MOTION%PINT%HELIUM%PRINT%" // TRIM(ADJUSTL(prop)) + print_key => section_vals_get_subs_vals( & + helium%input, & + input_path) + is_on = cp_printkey_is_on( & + iteration_info=logger%iter_info, & + print_key=print_key) + IF (is_on) THEN + is_active = .TRUE. + RETURN + END IF + + ! if the control section is explicit and on consider prop to be active + ! and activate the printkey + is_active = .FALSE. + NULLIFY(section) + input_path = "MOTION%PINT%HELIUM%" // TRIM(ADJUSTL(prop)) + section => section_vals_get_subs_vals( & + helium%input, & + input_path) + CALL section_vals_get(section,explicit=explicit) + IF (explicit) THEN + ! control section explicitly present, continue checking + CALL section_vals_val_get( & + section, & + "_SECTION_PARAMETERS_", & + l_val=is_on) + IF (is_on) THEN + ! control section is explicit and on, activate the property + is_active = .TRUE. + ! activate the corresponding print_level as well + print_level = logger%iter_info%print_level + CALL section_vals_val_set( & + print_key, & + "_SECTION_PARAMETERS_", & + i_val=print_level) + END IF + END IF + + RETURN + END FUNCTION helium_property_active + + +! *************************************************************************** +!> \brief Create the density related data structures and initialize +!> \param helium ... +!> \date 2014-02-25 +!> \author Lukasz Walewski +! ***************************************************************************** + SUBROUTINE helium_rho_property_init(helium) + + TYPE(helium_solvent_type), POINTER :: helium + + CHARACTER(len=*), PARAMETER :: routineN = 'helium_rho_property_init', & + routineP = moduleN//':'//routineN + + INTEGER :: nc + + ALLOCATE(helium%rho_property(rho_num)) + + helium%rho_property(rho_atom_number)%name = 'Atom number density' + nc = 1 + helium%rho_property(rho_atom_number)%num_components = nc + ALLOCATE(helium%rho_property(rho_atom_number)%filename_suffix(nc)) + ALLOCATE(helium%rho_property(rho_atom_number)%component_name(nc)) + ALLOCATE(helium%rho_property(rho_atom_number)%component_index(nc)) + helium%rho_property(rho_atom_number)%filename_suffix(1) = 'an' + helium%rho_property(rho_atom_number)%component_name(1) = '' + helium%rho_property(rho_atom_number)%component_index(:) = 0 + + helium%rho_property(rho_projected_area)%name = 'Projected area squared density, A*A(r)' + nc = 3 + helium%rho_property(rho_projected_area)%num_components = nc + ALLOCATE(helium%rho_property(rho_projected_area)%filename_suffix(nc)) + ALLOCATE(helium%rho_property(rho_projected_area)%component_name(nc)) + ALLOCATE(helium%rho_property(rho_projected_area)%component_index(nc)) + helium%rho_property(rho_projected_area)%filename_suffix(1) = 'pa_x' + helium%rho_property(rho_projected_area)%filename_suffix(2) = 'pa_y' + helium%rho_property(rho_projected_area)%filename_suffix(3) = 'pa_z' + helium%rho_property(rho_projected_area)%component_name(1) = 'component x' + helium%rho_property(rho_projected_area)%component_name(2) = 'component y' + helium%rho_property(rho_projected_area)%component_name(3) = 'component z' + helium%rho_property(rho_projected_area)%component_index(:) = 0 + + helium%rho_property(rho_winding_number)%name = 'Winding number squared density, W*W(r)' + nc = 3 + helium%rho_property(rho_winding_number)%num_components = nc + ALLOCATE(helium%rho_property(rho_winding_number)%filename_suffix(nc)) + ALLOCATE(helium%rho_property(rho_winding_number)%component_name(nc)) + ALLOCATE(helium%rho_property(rho_winding_number)%component_index(nc)) + helium%rho_property(rho_winding_number)%filename_suffix(1) = 'wn_x' + helium%rho_property(rho_winding_number)%filename_suffix(2) = 'wn_y' + helium%rho_property(rho_winding_number)%filename_suffix(3) = 'wn_z' + helium%rho_property(rho_winding_number)%component_name(1) = 'component x' + helium%rho_property(rho_winding_number)%component_name(2) = 'component y' + helium%rho_property(rho_winding_number)%component_name(3) = 'component z' + helium%rho_property(rho_winding_number)%component_index(:) = 0 + + helium%rho_property(rho_winding_cycle)%name = 'Winding number squared density, W^2(r)' + nc = 3 + helium%rho_property(rho_winding_cycle)%num_components = nc + ALLOCATE(helium%rho_property(rho_winding_cycle)%filename_suffix(nc)) + ALLOCATE(helium%rho_property(rho_winding_cycle)%component_name(nc)) + ALLOCATE(helium%rho_property(rho_winding_cycle)%component_index(nc)) + helium%rho_property(rho_winding_cycle)%filename_suffix(1) = 'wc_x' + helium%rho_property(rho_winding_cycle)%filename_suffix(2) = 'wc_y' + helium%rho_property(rho_winding_cycle)%filename_suffix(3) = 'wc_z' + helium%rho_property(rho_winding_cycle)%component_name(1) = 'component x' + helium%rho_property(rho_winding_cycle)%component_name(2) = 'component y' + helium%rho_property(rho_winding_cycle)%component_name(3) = 'component z' + helium%rho_property(rho_winding_cycle)%component_index(:) = 0 + + helium%rho_property(rho_moment_of_inertia)%name = 'Moment of inertia' + nc = 3 + helium%rho_property(rho_moment_of_inertia)%num_components = nc + ALLOCATE(helium%rho_property(rho_moment_of_inertia)%filename_suffix(nc)) + ALLOCATE(helium%rho_property(rho_moment_of_inertia)%component_name(nc)) + ALLOCATE(helium%rho_property(rho_moment_of_inertia)%component_index(nc)) + helium%rho_property(rho_moment_of_inertia)%filename_suffix(1) = 'mi_x' + helium%rho_property(rho_moment_of_inertia)%filename_suffix(2) = 'mi_y' + helium%rho_property(rho_moment_of_inertia)%filename_suffix(3) = 'mi_z' + helium%rho_property(rho_moment_of_inertia)%component_name(1) = 'component x' + helium%rho_property(rho_moment_of_inertia)%component_name(2) = 'component y' + helium%rho_property(rho_moment_of_inertia)%component_name(3) = 'component z' + helium%rho_property(rho_moment_of_inertia)%component_index(:) = 0 + + helium%rho_property(:)%is_calculated = .FALSE. + + RETURN + END SUBROUTINE helium_rho_property_init + + +! *************************************************************************** +!> \brief Create the density related data structures and initialize +!> \param helium ... +!> \date 2014-02-25 +!> \author Lukasz Walewski +! ***************************************************************************** + SUBROUTINE helium_rho_init(helium) + + TYPE(helium_solvent_type), POINTER :: helium + + CHARACTER(len=*), PARAMETER :: routineN = 'helium_rho_init', & + routineP = moduleN//':'//routineN + + INTEGER :: ii, itmp, jtmp + LOGICAL :: explicit, ltmp + + CALL helium_rho_property_init(helium) + + helium%rho_num_act = 0 + + ! check for atom number density + CALL section_vals_val_get(& + helium%input,& + "MOTION%PINT%HELIUM%RHO%ATOM_NUMBER",& + l_val=ltmp) + IF (ltmp) THEN + helium%rho_property(rho_atom_number)%is_calculated = .TRUE. + helium%rho_num_act = helium%rho_num_act + 1 + helium%rho_property(rho_atom_number)%component_index(1) = helium%rho_num_act + END IF + + ! check for projected area density + CALL section_vals_val_get(& + helium%input,& + "MOTION%PINT%HELIUM%RHO%PROJECTED_AREA_2",& + l_val=ltmp) + IF (ltmp) THEN + helium%rho_property(rho_projected_area)%is_calculated = .TRUE. + DO ii = 1, helium%rho_property(rho_projected_area)%num_components + helium%rho_num_act = helium%rho_num_act + 1 + helium%rho_property(rho_projected_area)%component_index(ii) = helium%rho_num_act + END DO + END IF + + ! check for winding number density + CALL section_vals_val_get(& + helium%input,& + "MOTION%PINT%HELIUM%RHO%WINDING_NUMBER_2",& + l_val=ltmp) + IF (ltmp) THEN + helium%rho_property(rho_winding_number)%is_calculated = .TRUE. + DO ii = 1, helium%rho_property(rho_winding_number)%num_components + helium%rho_num_act = helium%rho_num_act + 1 + helium%rho_property(rho_winding_number)%component_index(ii) = helium%rho_num_act + END DO + END IF + + ! check for winding cycle density + CALL section_vals_val_get(& + helium%input,& + "MOTION%PINT%HELIUM%RHO%WINDING_CYCLE_2",& + l_val=ltmp) + IF (ltmp) THEN + helium%rho_property(rho_winding_cycle)%is_calculated = .TRUE. + DO ii = 1, helium%rho_property(rho_winding_cycle)%num_components + helium%rho_num_act = helium%rho_num_act + 1 + helium%rho_property(rho_winding_cycle)%component_index(ii) = helium%rho_num_act + END DO + END IF + + ! check for moment of inertia density + CALL section_vals_val_get(& + helium%input,& + "MOTION%PINT%HELIUM%RHO%MOMENT_OF_INERTIA",& + l_val=ltmp) + IF (ltmp) THEN + helium%rho_property(rho_moment_of_inertia)%is_calculated = .TRUE. + DO ii = 1, helium%rho_property(rho_moment_of_inertia)%num_components + helium%rho_num_act = helium%rho_num_act + 1 + helium%rho_property(rho_moment_of_inertia)%component_index(ii) = helium%rho_num_act + END DO + END IF + + ! set the cube dimensions, etc (common to all estimators) + helium%rho_maxr = helium%cell_size + CALL section_vals_val_get( & + helium%input, & + "MOTION%PINT%HELIUM%RHO%NBIN", & + i_val=helium%rho_nbin) + helium%rho_delr = helium%rho_maxr / REAL(helium%rho_nbin,dp) + + ! check for optional estimators based on winding paths + helium%rho_num_min_len_wdg = 0 + CALL section_vals_val_get( & + helium%input, & + "MOTION%PINT%HELIUM%RHO%MIN_CYCLE_LENGTHS_WDG", & + explicit=explicit) + IF (explicit) THEN + NULLIFY(helium%rho_min_len_wdg_vals) + CALL section_vals_val_get( & + helium%input, & + "MOTION%PINT%HELIUM%RHO%MIN_CYCLE_LENGTHS_WDG", & + i_vals=helium%rho_min_len_wdg_vals) + itmp = SIZE(helium%rho_min_len_wdg_vals) + IF (itmp .GT. 0) THEN + helium%rho_num_min_len_wdg = itmp + helium%rho_num_act = helium%rho_num_act + itmp + END IF + END IF + + ! check for optional estimators based on non-winding paths + helium%rho_num_min_len_non = 0 + CALL section_vals_val_get( & + helium%input, & + "MOTION%PINT%HELIUM%RHO%MIN_CYCLE_LENGTHS_NON", & + explicit=explicit) + IF (explicit) THEN + NULLIFY(helium%rho_min_len_non_vals) + CALL section_vals_val_get( & + helium%input, & + "MOTION%PINT%HELIUM%RHO%MIN_CYCLE_LENGTHS_NON", & + i_vals=helium%rho_min_len_non_vals) + itmp = SIZE(helium%rho_min_len_non_vals) + IF (itmp .GT. 0) THEN + helium%rho_num_min_len_non = itmp + helium%rho_num_act = helium%rho_num_act + itmp + END IF + END IF + + ! check for optional estimators based on all paths + helium%rho_num_min_len_all = 0 + CALL section_vals_val_get( & + helium%input, & + "MOTION%PINT%HELIUM%RHO%MIN_CYCLE_LENGTHS_ALL",& + explicit=explicit) + IF (explicit) THEN + NULLIFY(helium%rho_min_len_all_vals) + CALL section_vals_val_get( & + helium%input, & + "MOTION%PINT%HELIUM%RHO%MIN_CYCLE_LENGTHS_ALL", & + i_vals=helium%rho_min_len_all_vals) + itmp = SIZE(helium%rho_min_len_all_vals) + IF (itmp .GT. 0) THEN + helium%rho_num_min_len_all = itmp + helium%rho_num_act = helium%rho_num_act + itmp + END IF + END IF + + ! get the weighting factor + CALL section_vals_val_get( & + helium%input, & + "MOTION%PINT%HELIUM%AVERAGES%IWEIGHT", & + i_val=helium%rho_iweight) + + ! allocate and initialize memory for density storage + itmp = helium%rho_nbin + jtmp = helium%rho_num_act + ALLOCATE(helium%rho_inst(jtmp,itmp,itmp,itmp)) + ALLOCATE(helium%rho_accu(jtmp,itmp,itmp,itmp)) + ALLOCATE(helium%rho_rstr(jtmp,itmp,itmp,itmp)) + ALLOCATE(helium%rho_incr(jtmp,helium%atoms,helium%beads)) + + helium%rho_inst(:,:,:,:) = 0.0_dp + helium%rho_accu(:,:,:,:) = 0.0_dp + helium%rho_rstr(:,:,:,:) = 0.0_dp + + RETURN + END SUBROUTINE helium_rho_init ! *************************************************************************** @@ -1484,57 +2256,62 @@ MODULE helium_methods !> \date 2011-06-22 !> \author Lukasz Walewski ! ***************************************************************************** - SUBROUTINE helium_densities_restore( helium) + SUBROUTINE helium_rho_restore( helium ) TYPE(helium_solvent_type), POINTER :: helium - CHARACTER(len=*), PARAMETER :: routineN = 'helium_densities_restore', & + CHARACTER(len=*), PARAMETER :: routineN = 'helium_rho_restore', & routineP = moduleN//':'//routineN - CHARACTER(len=default_string_length) :: err_str, stmp1, stmp2 + CHARACTER(len=default_string_length) :: stmp1, stmp2 + CHARACTER(len=max_line_length) :: err_str INTEGER :: itmp, msglen - LOGICAL :: ltmp + LOGICAL :: explicit, ltmp LOGICAL, DIMENSION(:, :, :, :), POINTER :: m - REAL(kind=dp), DIMENSION(:), POINTER :: message - REAL(kind=dp), DIMENSION(:, :, :, :), & + REAL(KIND=dp), DIMENSION(:), POINTER :: message + REAL(KIND=dp), DIMENSION(:, :, :, :), & POINTER :: f - itmp = helium%rho_nbin - ALLOCATE(helium%rho_rstr(helium%rho_num,itmp,itmp,itmp)) - - ! assign pointers to the memory locations in the input structure, where - ! the old densities are stored and check if the sizes match - NULLIFY(message) CALL section_vals_val_get( helium%input, & - "MOTION%PINT%HELIUM%RHO%CUBE_DATA%_DEFAULT_KEYWORD_", & - r_vals=message) - msglen = SIZE(message) - itmp = SIZE(helium%rho_rstr) - ltmp = ( msglen .EQ. itmp ) - IF ( .NOT. ltmp ) THEN - stmp1 = "" - WRITE(stmp1,*) msglen - stmp2 = "" - WRITE(stmp2,*) itmp - err_str = "Size of the S density array in the input (" // & - TRIM(ADJUSTL(stmp1)) // & - ") .NE. that in the runtime (" // & - TRIM(ADJUSTL(stmp2)) // ")." - CPABORT(err_str) + "MOTION%PINT%HELIUM%AVERAGES%RHO", & + explicit=explicit) + IF (explicit) THEN + NULLIFY(message) + CALL section_vals_val_get( helium%input, & + "MOTION%PINT%HELIUM%AVERAGES%RHO", & + r_vals=message) + msglen = SIZE(message) + itmp = SIZE(helium%rho_rstr) + ltmp = ( msglen .EQ. itmp ) + IF ( .NOT. ltmp ) THEN + stmp1 = "" + WRITE(stmp1,*) msglen + stmp2 = "" + WRITE(stmp2,*) itmp + err_str = "Size of the S density array in the input (" // & + TRIM(ADJUSTL(stmp1)) // & + ") .NE. that in the runtime (" // & + TRIM(ADJUSTL(stmp2)) // ")." + CPABORT(err_str) + END IF + ELSE + RETURN END IF itmp = helium%rho_nbin NULLIFY(m,f) - ALLOCATE(m(helium%rho_num,itmp,itmp,itmp)) - ALLOCATE(f(helium%rho_num,itmp,itmp,itmp)) + ALLOCATE(m(helium%rho_num_act,itmp,itmp,itmp)) + ALLOCATE(f(helium%rho_num_act,itmp,itmp,itmp)) m(:,:,:,:) = .TRUE. f(:,:,:,:) = 0.0_dp helium%rho_rstr(:,:,:,:) = UNPACK(message(1:msglen), MASK=m, FIELD=f) DEALLOCATE(f,m) + NULLIFY(message) + RETURN - END SUBROUTINE helium_densities_restore + END SUBROUTINE helium_rho_restore ! *************************************************************************** @@ -1552,11 +2329,10 @@ MODULE helium_methods CHARACTER(len=*), PARAMETER :: routineN = 'helium_set_solute_indices', & routineP = moduleN//':'//routineN - CHARACTER(LEN=2) :: my_element_symbol - CHARACTER(LEN=2), DIMENSION(:), POINTER :: element - CHARACTER(len=default_string_length) :: msg - INTEGER :: i, istat, j, mnum, natoms, & - nelements + CHARACTER(LEN=2) :: cur_ename + CHARACTER(len=default_path_length) :: msg_str + INTEGER :: cur_eid, i, j, mnum, natoms + INTEGER, DIMENSION(hid_num) :: el_counts LOGICAL :: found, my_failure REAL(KIND=dp) :: mass TYPE(cp_subsys_type), POINTER :: my_subsys @@ -1564,97 +2340,115 @@ MODULE helium_methods TYPE(particle_list_type), POINTER :: my_particles my_failure=.FALSE. - CPASSERT(ASSOCIATED(pint_env)) ! set up my_particles structure NULLIFY(my_f_env, my_subsys, my_particles) CALL f_env_add_defaults(f_env_id=pint_env%replicas%f_env_id, & - f_env=my_f_env,failure=my_failure) + f_env=my_f_env, failure=my_failure) CALL force_env_get(force_env=my_f_env%force_env, subsys=my_subsys) CALL cp_subsys_get(my_subsys, particles=my_particles) - CALL f_env_rm_defaults(my_f_env,istat) - CPASSERT(istat==0) + CALL f_env_rm_defaults(my_f_env) natoms = helium%solute_atoms NULLIFY(helium%solute_element) ALLOCATE(helium%solute_element(natoms)) - ! in the worst case there will be as many atomic types as atoms - NULLIFY(element) - ALLOCATE(element(natoms)) + NULLIFY(helium%ename, helium%eid) + ALLOCATE(helium%ename(hid_num)) + ALLOCATE(helium%eid(hid_num)) + + NULLIFY(helium%solute_i) + ALLOCATE(helium%solute_i(hid_num)) + DO i = 1, hid_num +!TODO important to nullify here, otherwise helium_destroy_int_arr_ptr +! in helium_release will fail +! safer solution: change int_arr_ptr%iap from POINTER to ALLOCATABLE + NULLIFY(helium%solute_i(i)%iap) + END DO ! find out how many different atomic types are there - nelements = 0 + helium%enum = 0 + el_counts(:) = 0 DO i=1, natoms CALL get_atomic_kind( my_particles%els(i)%atomic_kind, mass=mass) mnum = NINT(cp_unit_from_cp2k(mass, "amu")) SELECT CASE (mnum) - CASE (1) - my_element_symbol = "H " - CASE (16) - my_element_symbol = "O " CASE (35) - my_element_symbol = "CL" + cur_ename = "CL" + cur_eid = hid_chlorine + CASE (16) + cur_ename = "O " + cur_eid = hid_oxygen + CASE (1) + cur_ename = "H " + cur_eid = hid_hydrogen + CASE (12) + cur_ename = "C " + cur_eid = hid_carbon CASE DEFAULT - WRITE(UNIT=msg,FMT=*) "Atomic mass number'", mnum, & + cur_ename = "XX" + cur_eid = -1 + WRITE(msg_str,'(A,I0,A)') & + "Atomic mass number '", & + mnum, & "' not supported by the HELIUM code." - CPABORT(msg) + CPABORT(msg_str) END SELECT - helium%solute_element(i) = my_element_symbol - ! check if this element symbol is already present in element + helium%solute_element(i) = cur_ename + el_counts(cur_eid) = el_counts(cur_eid) + 1 + ! check if this element symbol is already present in element table found = .FALSE. - DO j=1, nelements - IF ( element(j) == my_element_symbol ) THEN + DO j=1, helium%enum + IF ( helium%ename(j) == cur_ename ) THEN found = .TRUE. EXIT END IF END DO - ! increase the nelements counter if not IF (.NOT. found) THEN - nelements = nelements + 1 - element(nelements) = my_element_symbol + ! increase current number of different elements + helium%enum = helium%enum + 1 + helium%eid(helium%enum) = cur_eid + helium%ename(helium%enum) = cur_ename END IF END DO - CPASSERT(nelements.LE.3) - ! allocate the arrays, DEALLOCATE them in helium_release - ! (solute_index a bit superfluous at the moment) - NULLIFY(helium%solute_number,helium%solute_index) - ALLOCATE(helium%solute_number(3), STAT=istat) - ALLOCATE(helium%solute_index(3,natoms), STAT=istat) - CPASSERT(istat==0) + DO i = 1, helium%enum + ALLOCATE(helium%solute_i(helium%eid(i))%iap(el_counts(helium%eid(i)))) + END DO - ! collect atomic indices - helium%solute_number(:) = 0 + ! store atomic indices of different atomic kinds + el_counts(:) = 0 DO i=1, natoms SELECT CASE (helium%solute_element(i)) CASE ("CL") - helium%solute_number(1) = helium%solute_number(1) + 1 - helium%solute_index(1,helium%solute_number(1)) = i + el_counts(hid_chlorine) = el_counts(hid_chlorine) + 1 + helium%solute_i(hid_chlorine)%iap(el_counts(hid_chlorine)) = i CASE ("O ") - helium%solute_number(2) = helium%solute_number(2) + 1 - helium%solute_index(2,helium%solute_number(2)) = i + el_counts(hid_oxygen) = el_counts(hid_oxygen) + 1 + helium%solute_i(hid_oxygen)%iap(el_counts(hid_oxygen)) = i CASE ("H ") - helium%solute_number(3) = helium%solute_number(3) + 1 - helium%solute_index(3,helium%solute_number(3)) = i + el_counts(hid_hydrogen) = el_counts(hid_hydrogen) + 1 + helium%solute_i(hid_hydrogen)%iap(el_counts(hid_hydrogen)) = i + CASE ("C ") + el_counts(hid_carbon) = el_counts(hid_carbon) + 1 + helium%solute_i(hid_carbon)%iap(el_counts(hid_carbon)) = i CASE DEFAULT - WRITE(UNIT=msg,FMT=*) "Atom type '", helium%solute_element(i), & - "' not supported by the HELIUM code." - CPABORT(msg) + WRITE(msg_str,'(A)') & + "Should never get here, check what happened!" + CPABORT(msg_str) END SELECT END DO - DEALLOCATE(element) - RETURN END SUBROUTINE helium_set_solute_indices + ! *************************************************************************** !> \brief Sets helium%solute_cell based on the solute's force_env. !> \param helium ... !> \param pint_env ... !> \author Lukasz Walewski -!> \note The simulation cell for the solvated molecule is taken from force_env +!> \note The simulation cell for the solvated molecule is taken from force_env !> which should assure that we get proper cell dimensions regardless of !> the method used for the solute (QS, FIST). Helium solvent needs the !> solute's cell dimensions to calculate the solute-solvent distances @@ -1668,26 +2462,22 @@ MODULE helium_methods CHARACTER(len=*), PARAMETER :: routineN = 'helium_set_solute_cell', & routineP = moduleN//':'//routineN - INTEGER :: status LOGICAL :: my_failure, my_orthorhombic TYPE(cell_type), POINTER :: my_cell TYPE(f_env_type), POINTER :: my_f_env my_failure=.FALSE. - CPASSERT(ASSOCIATED(pint_env)) ! get the cell structure from pint_env NULLIFY(my_f_env, my_cell) CALL f_env_add_defaults(f_env_id=pint_env%replicas%f_env_id, & f_env=my_f_env,failure=my_failure) CALL force_env_get(force_env=my_f_env%force_env, cell=my_cell) - CALL f_env_rm_defaults(my_f_env,status) - CPASSERT(status==0) + CALL f_env_rm_defaults(my_f_env) CALL get_cell(my_cell, orthorhombic=my_orthorhombic) IF (.NOT. my_orthorhombic) THEN - PRINT *, "Helium solvent not implemented for non-orthorhombic cells." - CPABORT("") + CPABORT("Helium solvent not implemented for non-orthorhombic cells.") ELSE helium%solute_cell => my_cell END IF @@ -1695,223 +2485,5 @@ MODULE helium_methods RETURN END SUBROUTINE helium_set_solute_cell -!TODO headers/comments, beautify - -! ***************************************************************************** -!> \brief ... -!> \param helium ... -!> \param n ... -!> \param i ... -!> \retval res ... -! ***************************************************************************** -FUNCTION helium_atom_action(helium,n,i) RESULT(res) - - TYPE(helium_solvent_type), POINTER :: helium - INTEGER, INTENT(IN) :: n, i - REAL(KIND=dp) :: res - - INTEGER :: c, j - REAL(KIND=dp) :: r(3), rp(3), s, t - - s = 0.0_dp - t = 0.0_dp - IF (n < helium%beads) THEN - DO c = 1, 3 - r(c) = helium%pos(c,i,n) - helium%pos(c,i,n+1) - END DO - CALL helium_pbc( helium, r ) - t = r(1)*r(1) + r(2)*r(2) + r(3)*r(3) - DO j = 1, i-1 - DO c = 1, 3 - r(c) = helium%pos(c,i,n) - helium%pos(c,j,n) - rp(c) = helium%pos(c,i,n+1) - helium%pos(c,j,n+1) - END DO - CALL helium_pbc( helium, r ) - CALL helium_pbc( helium, rp ) - s = s + helium_eval_expansion(helium,r,rp,helium%uij,1) - END DO - DO j = i+1, helium%atoms - DO c = 1, 3 - r(c) = helium%pos(c,i,n) - helium%pos(c,j,n) - rp(c) = helium%pos(c,i,n+1) - helium%pos(c,j,n+1) - END DO - CALL helium_pbc( helium, r ) - CALL helium_pbc( helium, rp ) - s = s + helium_eval_expansion(helium,r,rp,helium%uij,1) - END DO - ELSE - DO c = 1, 3 - r(c) = helium%pos(c,i,n) - helium%pos(c,helium%permutation(i),1) - END DO - CALL helium_pbc( helium, r ) - t = r(1)*r(1) + r(2)*r(2) + r(3)*r(3) - DO j = 1, i-1 - DO c = 1, 3 - r(c) = helium%pos(c,i,n) - helium%pos(c,j,n) - rp(c) = helium%pos(c,helium%permutation(i),1) - helium%pos(c,helium%permutation(j),1) - END DO - CALL helium_pbc( helium, r ) - CALL helium_pbc( helium, rp ) - s = s + helium_eval_expansion(helium,r,rp,helium%uij,1) - END DO - DO j = i+1, helium%atoms - DO c = 1, 3 - r(c) = helium%pos(c,i,n) - helium%pos(c,j,n) - rp(c) = helium%pos(c,helium%permutation(i),1) - helium%pos(c,helium%permutation(j),1) - END DO - CALL helium_pbc( helium, r ) - CALL helium_pbc( helium, rp ) - s = s + helium_eval_expansion(helium,r,rp,helium%uij,1) - END DO - END IF - t = t / (2.0_dp*helium%tau*helium%hb2m) - s = s * 0.5_dp - res = s+t - RETURN - -END FUNCTION helium_atom_action - -! ***************************************************************************** -!> \brief ... -!> \param helium ... -!> \param n ... -!> \retval res ... -! ***************************************************************************** -FUNCTION helium_link_action(helium,n) RESULT(res) - - TYPE(helium_solvent_type), POINTER :: helium - INTEGER, INTENT(IN) :: n - REAL(KIND=dp) :: res - - INTEGER :: c, i, j - REAL(KIND=dp) :: r(3), rp(3), s, t - - s = 0.0_dp - t = 0.0_dp - IF (n < helium%beads) THEN - DO i = 1, helium%atoms - DO c = 1, 3 - r(c) = helium%pos(c,i,n) - helium%pos(c,i,n+1) - END DO - CALL helium_pbc( helium, r ) - t = r(1)*r(1) + r(2)*r(2) + r(3)*r(3) - DO j = 1, i-1 - DO c = 1, 3 - r(c) = helium%pos(c,i,n) - helium%pos(c,j,n) - rp(c) = helium%pos(c,i,n+1) - helium%pos(c,j,n+1) - END DO - CALL helium_pbc( helium, r ) - CALL helium_pbc( helium, rp ) - s = s + helium_eval_expansion(helium,r,rp,helium%uij,1) - END DO - END DO - ELSE - DO i = 1, helium%atoms - DO c = 1, 3 - r(c) = helium%pos(c,i,n) - helium%pos(c,helium%permutation(i),1) - END DO - CALL helium_pbc( helium, r ) - t = r(1)*r(1) + r(2)*r(2) + r(3)*r(3) - DO j = 1, i-1 - DO c = 1, 3 - r(c) = helium%pos(c,i,n) - helium%pos(c,j,n) - rp(c) = helium%pos(c,helium%permutation(i),1) - helium%pos(c,helium%permutation(j),1) - END DO - CALL helium_pbc( helium, r ) - CALL helium_pbc( helium, rp ) - s = s + helium_eval_expansion(helium,r,rp,helium%uij,1) - END DO - END DO - END IF - t = t / (2.0_dp*helium%tau*helium%hb2m) - res = s+t - RETURN - -END FUNCTION helium_link_action - -! ***************************************************************************** -!> \brief ... -!> \param helium ... -!> \retval res ... -! ***************************************************************************** -FUNCTION helium_total_action(helium) RESULT(res) - - TYPE(helium_solvent_type), POINTER :: helium - REAL(KIND=dp) :: res - - INTEGER :: i - REAL(KIND=dp) :: s - - s = 0.0_dp - DO i = 1, helium%beads - s = s + helium_link_action(helium,i) - END DO - res = s - RETURN - -END FUNCTION helium_total_action - -! ***************************************************************************** -!> \brief ... -!> \param helium ... -!> \param part ... -!> \param ref_bead ... -!> \param delta_bead ... -!> \param d ... -! ***************************************************************************** -SUBROUTINE helium_delta_pos(helium,part,ref_bead,delta_bead,d) - - TYPE(helium_solvent_type), POINTER :: helium - INTEGER, INTENT(IN) :: part, ref_bead, delta_bead - REAL(KIND=dp), DIMENSION(3), INTENT(OUT) :: d - - INTEGER :: b, bead, db, n, nbead, np, p - REAL(KIND=dp), DIMENSION(3) :: r - - b = helium%beads - n = helium%atoms - - d(:) = 0.0_dp - IF (delta_bead > 0) THEN - bead = ref_bead - p = part - db = delta_bead - DO - IF (db < 1) EXIT - nbead = bead + 1 - np = p - IF (nbead > b) THEN - nbead = nbead - b - np = helium%permutation(np) - END IF - r(:) = helium%pos(:,p,bead) - helium%pos(:,np,nbead) - CALL helium_pbc( helium, r ) - d(:) = d(:) + r(:) - bead = nbead - p = np - db = db-1 - END DO - ELSEIF ( delta_bead < 0) THEN - bead = ref_bead - p = part - db = delta_bead - DO - IF (db >= 0) EXIT - nbead = bead - 1 - np = p - IF (nbead < 1) THEN - nbead = nbead + b - np = helium%iperm(np) - END IF - r(:) = helium%pos(:,p,bead) - helium%pos(:,np,nbead) - CALL helium_pbc( helium, r ) - d(:) = d(:) + r(:) - bead = nbead - p = np - db = db + 1 - END DO - END IF - RETURN -END SUBROUTINE helium_delta_pos END MODULE helium_methods diff --git a/src/motion/helium_sampling.F b/src/motion/helium_sampling.F index 627fe299a9..6ebb21c8c8 100644 --- a/src/motion/helium_sampling.F +++ b/src/motion/helium_sampling.F @@ -19,25 +19,32 @@ MODULE helium_sampling USE global_types, ONLY: global_environment_type USE helium_common, ONLY: & helium_boxmean_3d, helium_calc_plength, helium_calc_rdf, & - helium_calc_rho, helium_calc_wnumber, helium_eval_expansion, & - helium_pbc, helium_rotate, helium_spline, & - helium_update_transition_matrix - USE helium_interactions, ONLY: helium_bead_solute_e,& + helium_calc_rho, helium_com, helium_eval_expansion, helium_pbc, & + helium_rotate, helium_set_rdf_coord_system, helium_spline, & + helium_total_moment_of_inertia, helium_total_projected_area, & + helium_total_winding_number, helium_update_transition_matrix + USE helium_interactions, ONLY: helium_bead_solute_e_f,& helium_calc_energy,& helium_solute_e_f USE helium_io, ONLY: & - helium_write_accepts, helium_write_coordinates, helium_write_energy, & - helium_write_force, helium_write_line, helium_write_perm, & - helium_write_plength, helium_write_rdf, helium_write_rho, & - helium_write_sdensity, helium_write_wnumber + helium_print_accepts, helium_print_coordinates, helium_print_energy, & + helium_print_force, helium_print_perm, helium_print_plength, & + helium_print_rdf, helium_print_rho, helium_print_vector, & + helium_write_line USE helium_types, ONLY: e_id_total,& helium_solvent_type + USE input_constants, ONLY: & + helium_forces_average, helium_forces_last, helium_mdist_exponential, & + helium_mdist_gaussian, helium_mdist_linear, helium_mdist_quadratic, & + helium_mdist_singlev, helium_mdist_uniform, helium_sampling_ceperley USE input_cp2k_restarts, ONLY: write_restart USE kinds, ONLY: default_string_length,& dp USE machine, ONLY: m_walltime - USE message_passing, ONLY: mp_sum + USE message_passing, ONLY: mp_bcast,& + mp_sum USE parallel_rng_types, ONLY: next_random_number + USE physcon, ONLY: angstrom USE pint_types, ONLY: pint_env_type USE splines_types, ONLY: spline_data_p_type #include "../base/base_uses.f90" @@ -55,6 +62,7 @@ MODULE helium_sampling CONTAINS + ! *************************************************************************** !> \brief Performs MC simulation for helium (only) !> \param helium ... @@ -75,8 +83,6 @@ MODULE helium_sampling LOGICAL :: should_stop TYPE(pint_env_type), POINTER :: pint_env - CPASSERT(ASSOCIATED(helium)) - NULLIFY(pint_env) NULLIFY(helium%logger) @@ -89,10 +95,26 @@ MODULE helium_sampling CALL cp_add_iter_level(helium%logger%iter_info,"MD") CALL cp_iterate(helium%logger%iter_info,iter_nr=helium%first_step) tot_steps = helium%first_step + + ! set the properties accumulated over the whole MC process to 0 + helium%proarea%accu(:) = 0.0_dp + helium%prarea2%accu(:) = 0.0_dp + helium%wnmber2%accu(:) = 0.0_dp + helium%mominer%accu(:) = 0.0_dp + IF (helium%rho_present) THEN + helium%rho_accu(:,:,:,:) = 0.0_dp + END IF + IF (helium%rdf_present) THEN + helium%rdf_accu(:,:,:) = 0.0_dp + END IF + DO step = 1, helium%num_steps tot_steps = tot_steps + 1 - CALL cp_iterate(helium%logger%iter_info,last=(step==helium%num_steps),iter_nr=tot_steps) + CALL cp_iterate(helium%logger%iter_info, & + last=(step==helium%num_steps), & + iter_nr=tot_steps) + !level_name="MD") helium%current_step = tot_steps CALL helium_step(helium,pint_env) @@ -112,6 +134,7 @@ MODULE helium_sampling RETURN END SUBROUTINE helium_do_run + ! *************************************************************************** !> \brief Sample the helium phase space !> \param helium ... @@ -127,7 +150,8 @@ MODULE helium_sampling !> everywhere I should. This leads to some redundancy in the case of !> helium-only calculations. ! ***************************************************************************** - SUBROUTINE helium_sample( helium, pint_env) + SUBROUTINE helium_sample( helium, pint_env ) + TYPE(helium_solvent_type), POINTER :: helium TYPE(pint_env_type), POINTER :: pint_env @@ -135,105 +159,152 @@ MODULE helium_sampling CHARACTER(len=*), PARAMETER :: routineN = 'helium_sample', & routineP = moduleN//':'//routineN - INTEGER :: irot, nslices - LOGICAL :: solute_present - REAL(kind=dp) :: inv_iter_rot, inv_num_pe, & - rnd, rtmp + CHARACTER(len=default_string_length) :: msg_str + INTEGER :: irot, iweight, nslices, & + nsteps, sel_mp_source + REAL(KIND=dp) :: inv_num_pe, inv_xn, rnd, & + rtmp, rweight TYPE(cp_logger_type), POINTER :: logger NULLIFY(logger) logger => cp_get_default_logger() - CPASSERT(ASSOCIATED(helium)) - - solute_present = helium%solute_present - helium%force_avrg(:,:) = 0.0_dp + IF (helium%solute_present) helium%force_avrg(:,:) = 0.0_dp helium%energy_avrg(:) = 0.0_dp - helium%energy_inst(:) = 0.0_dp - helium%wnumber_avrg(:) = 0.0_dp - helium%sdensity_avrg = 0.0_dp helium%plength_avrg(:) = 0.0_dp - helium%rdf_avrg(:) = 0.0_dp helium%num_accepted(:,:) = 0.0_dp ! helium parallelization: each processor gets different RN stream and ! runs independent helium simulation, the properties and forces are ! averaged over parallel helium environments once per step. - ! helium sampling (outer MC loop) - inv_iter_rot = 1.0_dp / REAL(helium%iter_rot,dp) - DO irot = 1, helium%iter_rot + inv_xn = 0.0_dp + SELECT CASE (helium%sampling_method) + CASE (helium_sampling_ceperley) + ! helium sampling (outer MC loop) + DO irot = 1, helium%iter_rot - ! rotate helium beads in imaginary time at random, store current - ! 'rotation state' in helium%relrot wich is within (0, helium%beads-1) - ! (this is needed to sample different fragments of the permutation - ! paths in try_permutations) - rnd = next_random_number(helium%rng_stream_uniform) - nslices = INT(rnd * helium%beads) - CALL helium_rotate(helium,nslices) + ! rotate helium beads in imaginary time at random, store current + ! 'rotation state' in helium%relrot wich is within (0, helium%beads-1) + ! (this is needed to sample different fragments of the permutation + ! paths in try_permutations) + rnd = next_random_number(helium%rng_stream_uniform) + nslices = INT(rnd * helium%beads) + CALL helium_rotate(helium,nslices) - CALL helium_try_permutations(helium,pint_env) + CALL helium_try_permutations(helium,pint_env) - ! calculate instantaneous forces on the solute and He properties - IF (solute_present) CALL helium_solute_e_f(pint_env, helium, rtmp) - CALL helium_calc_energy(helium,pint_env) - CALL helium_calc_wnumber( helium ) - CALL helium_calc_plength( helium) - CALL helium_calc_rdf( helium) - IF (helium%rho_present) CALL helium_calc_rho( helium) + ! calculate & accumulate instantaneous properties for averaging + IF (helium%solute_present) THEN + IF (helium%get_helium_forces == helium_forces_average) THEN + CALL helium_solute_e_f(pint_env, helium, rtmp) + helium%force_avrg(:,:) = helium%force_avrg(:,:) + helium%force_inst(:,:) + END IF + END IF + CALL helium_calc_energy(helium,pint_env) + helium%energy_avrg(:) = helium%energy_avrg(:) + helium%energy_inst(:) + CALL helium_calc_plength( helium ) + helium%plength_avrg(:) = helium%plength_avrg(:) + helium%plength_inst(:) - ! instantaneous force output according to HELIUM%PRINT%FORCES_INST - ! Warning: file I/O here may cost A LOT of cpu time! - ! switched off here to save cpu - !CALL helium_write_force_inst( helium) + ! instantaneous force output according to HELIUM%PRINT%FORCES_INST + ! Warning: file I/O here may cost A LOT of cpu time! + ! switched off here to save cpu + !CALL helium_print_force_inst( helium, error ) - ! collect instantaneous values for averaging - helium%force_avrg(:,:) = & - helium%force_avrg(:,:) + helium%force_inst(:,:) - helium%energy_avrg(:) = helium%energy_avrg(:) + helium%energy_inst(:) - helium%wnumber_avrg(:) = helium%wnumber_avrg(:) + helium%wnumber_inst(:) - helium%sdensity_avrg = helium%sdensity_avrg + helium%sdensity_inst - helium%plength_avrg(:) = helium%plength_avrg(:) + helium%plength_inst(:) - helium%rdf_avrg(:) = helium%rdf_avrg(:) + helium%rdf_inst(:) - IF (helium%rho_present) THEN - helium%rho_avrg(:,:,:,:) = helium%rho_avrg(:,:,:,:) + & - helium%rho_inst(:,:,:,:) * inv_iter_rot + END DO ! outer MC loop + + ! If only the last forces are taken, calculate them for the last outer MC loop configuration + IF ((helium%solute_present).AND.(helium%get_helium_forces == helium_forces_last)) THEN + CALL helium_solute_e_f(pint_env, helium, rtmp) + helium%force_avrg(:,:) = helium%force_inst(:,:) END IF - END DO + ! restore the original alignment of beads in imaginary time + ! (this is useful to make a single bead's position easy to follow + ! in the trajectory, otherwise it's index would change every step) + CALL helium_rotate(helium,-helium%relrot) - ! restore the original alignment of beads in imaginary time - ! (this is useful to make a single bead's position easy to follow - ! in the trajectory, otherwise it's index would change every step) - CALL helium_rotate(helium,-helium%relrot) + inv_xn = 1.0_dp / REAL(helium%iter_rot,dp) - ! actually average the forces and properties over the outer MC loop - helium%force_avrg(:,:) = helium%force_avrg(:,:) * inv_iter_rot - helium%energy_avrg(:) = helium%energy_avrg(:) * inv_iter_rot - helium%wnumber_avrg(:) = helium%wnumber_avrg(:) * inv_iter_rot - helium%sdensity_avrg = helium%sdensity_avrg * inv_iter_rot - helium%plength_avrg(:) = helium%plength_avrg(:) * inv_iter_rot - helium%rdf_avrg(:) = helium%rdf_avrg(:) * inv_iter_rot + CASE DEFAULT + WRITE(msg_str,*) helium%sampling_method + msg_str = "Sampling method ("//TRIM(ADJUSTL(msg_str))//") not supported." + CPABORT(msg_str) + + END SELECT + + + ! actually average the properties over the outer MC loop + IF ((helium%solute_present).AND.(helium%get_helium_forces == helium_forces_average)) THEN + helium%force_avrg(:,:) = helium%force_avrg(:,:) * inv_xn + END IF + helium%energy_avrg(:) = helium%energy_avrg(:) * inv_xn + helium%plength_avrg(:) = helium%plength_avrg(:) * inv_xn + + ! instantaneous properties + helium%proarea%inst(:) = helium_total_projected_area(helium) + helium%prarea2%inst(:) = helium%proarea%inst(:) * helium%proarea%inst(:) + helium%wnumber%inst(:) = helium_total_winding_number(helium) + helium%wnmber2%inst(:) = helium%wnumber%inst(:) * helium%wnumber%inst(:) + helium%mominer%inst(:) = helium_total_moment_of_inertia(helium) + + ! properties accumulated over the whole MC process + helium%proarea%accu(:) = helium%proarea%accu(:) + helium%proarea%inst(:) + helium%prarea2%accu(:) = helium%prarea2%accu(:) + helium%prarea2%inst(:) + helium%wnmber2%accu(:) = helium%wnmber2%accu(:) + helium%wnmber2%inst(:) + helium%mominer%accu(:) = helium%mominer%accu(:) + helium%mominer%inst(:) + IF (helium%rho_present) THEN + CALL helium_calc_rho(helium) + helium%rho_accu(:,:,:,:) = helium%rho_accu(:,:,:,:) + helium%rho_inst(:,:,:,:) + END IF + IF (helium%rdf_present) THEN + CALL helium_set_rdf_coord_system(helium,pint_env) + CALL helium_calc_rdf(helium, helium%rdf_centers) + helium%rdf_accu(:,:,:) = helium%rdf_accu(:,:,:) + helium%rdf_inst(:,:,:) + END IF + + ! running averages (restart-aware) + nsteps = helium%current_step-helium%first_step + iweight = helium%averages_iweight + rweight = REAL(iweight,dp) + rtmp = 1.0_dp / (REAL(nsteps+iweight,dp)) + helium%proarea%ravr(:) = (helium%proarea%accu(:)+rweight*helium%proarea%rstr(:))*rtmp + helium%prarea2%ravr(:) = (helium%prarea2%accu(:)+rweight*helium%prarea2%rstr(:))*rtmp + helium%wnmber2%ravr(:) = (helium%wnmber2%accu(:)+rweight*helium%wnmber2%rstr(:))*rtmp + helium%mominer%ravr(:) = (helium%mominer%accu(:)+rweight*helium%mominer%rstr(:))*rtmp ! average over helium environments sitting at different processors - ! WARNING: do not average winding number, etc. over He environments! +!TODO the following involves message passing, maybe move it to i/o routines? inv_num_pe = 1.0_dp / REAL(logger%para_env%num_pe,dp) - IF (solute_present) CALL mp_sum(helium%force_avrg,logger%para_env%group) + IF (helium%solute_present) THEN + IF (helium%get_helium_forces == helium_forces_average) THEN + CALL mp_sum(helium%force_avrg,logger%para_env%group) + helium%force_avrg(:,:) = helium%force_avrg(:,:) * inv_num_pe + ELSE IF (helium%get_helium_forces == helium_forces_last) THEN + ! create random number from 0 to num pe on IO node + IF (logger%para_env%ionode) THEN + sel_mp_source = INT(next_random_number(helium%rng_stream_uniform)& + *REAL(logger%para_env%num_pe,dp)) + END IF + ! broadcast this number + CALL mp_bcast(sel_mp_source,logger%para_env%source,& + logger%para_env%group) + ! broadcast forces from this environment to all others + CALL mp_bcast(helium%force_avrg,sel_mp_source,logger%para_env%group) + END IF + END IF + CALL mp_sum(helium%energy_avrg,logger%para_env%group) - CALL mp_sum(helium%sdensity_avrg,logger%para_env%group) CALL mp_sum(helium%plength_avrg,logger%para_env%group) - CALL mp_sum(helium%rdf_avrg,logger%para_env%group) CALL mp_sum(helium%num_accepted,logger%para_env%group) - helium%force_avrg(:,:) = helium%force_avrg(:,:) * inv_num_pe helium%energy_avrg(:) = helium%energy_avrg(:) * inv_num_pe - helium%sdensity_avrg = helium%sdensity_avrg * inv_num_pe helium%plength_avrg(:) = helium%plength_avrg(:) * inv_num_pe - helium%rdf_avrg(:) = helium%rdf_avrg(:) * inv_num_pe helium%num_accepted(:,:) = helium%num_accepted(:,:) * inv_num_pe RETURN END SUBROUTINE helium_sample + ! *************************************************************************** !> \brief Perform MC step for helium !> \param helium ... @@ -251,28 +322,74 @@ MODULE helium_sampling CHARACTER(len=default_string_length) :: msgstr, stmp, time_unit INTEGER :: handle - REAL(kind=dp) :: time_start, time_stop, & + REAL(KIND=dp) :: time_start, time_stop, & time_used CALL timeset(routineN,handle) time_start = m_walltime() - CPASSERT(ASSOCIATED(helium)) - ! perform the actual phase space sampling CALL helium_sample( helium, pint_env) - ! write out the averaged properties - CALL helium_write_energy( helium) - CALL helium_write_sdensity( helium) - CALL helium_write_wnumber( helium) - CALL helium_write_plength( helium) - CALL helium_write_rdf( helium) - IF (helium%rho_present) CALL helium_write_rho( helium) - CALL helium_write_perm( helium) - CALL helium_write_accepts( helium) - CALL helium_write_coordinates( helium) - CALL helium_write_force( helium) + ! print properties + CALL helium_print_energy( helium ) + WRITE(stmp,*) helium%apref + CALL helium_print_vector(helium,& + "MOTION%PINT%HELIUM%PRINT%PROJECTED_AREA",& + helium%proarea%inst,& + angstrom*angstrom,& + (/"A_x","A_y","A_z"/),& + "prefactor = "//TRIM(ADJUSTL(stmp))//" [Angstrom^-2]",& + "helium-pa") + CALL helium_print_vector(helium,& + "MOTION%PINT%HELIUM%PRINT%PROJECTED_AREA_2_AVG",& + helium%prarea2%ravr,& + angstrom*angstrom*angstrom*angstrom,& + (/"","",""/),& + "prefactor = "//TRIM(ADJUSTL(stmp))//" [Angstrom^-2]",& + "helium-pa-avg",& + "REWIND",& + .TRUE.) + CALL helium_print_vector(helium,& + "MOTION%PINT%HELIUM%PRINT%MOMENT_OF_INERTIA",& + helium%mominer%inst,& + angstrom*angstrom,& + (/"I_x/m","I_y/m","I_z/m"/),& + "prefactor = "//TRIM(ADJUSTL(stmp))//" [Angstrom^-2]",& + "helium-mi") + CALL helium_print_vector(helium,& + "MOTION%PINT%HELIUM%PRINT%MOMENT_OF_INERTIA_AVG",& + helium%mominer%ravr,& + angstrom*angstrom,& + (/"","",""/),& + "prefactor = "//TRIM(ADJUSTL(stmp))//" [Angstrom^-2]",& + "helium-mi-avg",& + "REWIND",& + .TRUE.) + WRITE(stmp,*) helium%wpref + CALL helium_print_vector(helium,& + "MOTION%PINT%HELIUM%PRINT%WINDING_NUMBER",& + helium%wnumber%inst,& + angstrom,& + (/"W_x","W_y","W_z"/),& + "prefactor = "//TRIM(ADJUSTL(stmp))//" [Angstrom^-2]",& + "helium-wn") + CALL helium_print_vector(helium,& + "MOTION%PINT%HELIUM%PRINT%WINDING_NUMBER_2_AVG",& + helium%wnmber2%ravr,& + angstrom*angstrom,& + (/"","",""/),& + "prefactor = "//TRIM(ADJUSTL(stmp))//" [Angstrom^-2]",& + "helium-wn-avg",& + "REWIND",& + .TRUE.) + CALL helium_print_plength( helium ) + IF (helium%rdf_present) CALL helium_print_rdf( helium ) + IF (helium%rho_present) CALL helium_print_rho( helium ) + CALL helium_print_perm( helium ) + CALL helium_print_accepts( helium ) + CALL helium_print_coordinates( helium ) + CALL helium_print_force( helium ) time_stop = m_walltime() time_used = time_stop - time_start @@ -309,11 +426,13 @@ MODULE helium_sampling RETURN END SUBROUTINE helium_step + ! *************************************************************************** !> \brief ... !> \param helium ... !> \param pint_env - path integral environment !> \par History +!> 2010-06-17 added different distributions for m-sampling [lwalewski] !> 2010-06-17 ratio for m-value added (m-sampling related) [lwalewski] !> \author hforbert ! ***************************************************************************** @@ -324,48 +443,153 @@ MODULE helium_sampling CHARACTER(len=*), PARAMETER :: routineN = 'helium_try_permutations', & routineP = moduleN//':'//routineN - INTEGER :: ncycles, ni, nselected, res - REAL(KIND=dp) :: r, rnd, x + CHARACTER(len=default_string_length) :: err_str, stmp + INTEGER :: cyclen, ni + LOGICAL :: accepted, selected + REAL(KIND=dp) :: r, rnd, x, y, z - IF (helium%maxcycle>1) CALL helium_update_transition_matrix(helium) - helium%work(:,:,:)=helium%pos(:,:,:) + IF (helium%maxcycle>1) CALL helium_update_transition_matrix(helium) - ! the inner MC loop (without rotation in imaginary time) - DO ni = 1, helium%iter_norot + ! consecutive calls to helium_slice_metro_cyclic require that + ! ALL(helium%pos.EQ.helium%work) - see a comment there, + ! besides there is a magic regarding helium%permutation + ! you have been warned + helium%work(:,:,:) = helium%pos(:,:,:) + + ! the inner MC loop (without rotation in imaginary time) + DO ni = 1, helium%iter_norot ! set the probability threshold for m_value: 1/(1+(m-1)/helium%m_ratio) r = 1.0_dp / ( 1.0_dp + (helium%maxcycle-1)/helium%m_ratio ) ! draw permutation length for this trial from the distribution of choice - x = next_random_number(helium%rng_stream_uniform) - IF ( x .LT. r ) THEN - ncycles = helium%m_value - ELSE - DO - x = next_random_number(helium%rng_stream_uniform) - ncycles = INT(helium%maxcycle*x)+1 - IF ( ncycles .NE. helium%m_value ) EXIT - END DO - END IF + ! + SELECT CASE (helium%m_dist_type) - IF (ncycles<1) ncycles = 1 - IF (ncycles>helium%maxcycle) ncycles = helium%maxcycle - helium%num_accepted(1,ncycles) = helium%num_accepted(1,ncycles) + 1 + CASE (helium_mdist_singlev) + x = next_random_number(helium%rng_stream_uniform) + IF ( x .LT. r ) THEN + cyclen = 1 + ELSE + cyclen = helium%m_value + END IF + + CASE (helium_mdist_uniform) + x = next_random_number(helium%rng_stream_uniform) + IF ( x .LT. r ) THEN + cyclen = helium%m_value + ELSE + DO + x = next_random_number(helium%rng_stream_uniform) + cyclen = INT(helium%maxcycle*x)+1 + IF ( cyclen .NE. helium%m_value ) EXIT + END DO + END IF + + CASE (helium_mdist_linear) + x = next_random_number(helium%rng_stream_uniform) + IF ( x .LT. r ) THEN + cyclen = helium%m_value + ELSE + DO + x = next_random_number(helium%rng_stream_uniform) + y = SQRT(2.0_dp*x) + cyclen = INT(helium%maxcycle*y/SQRT(2.0_dp))+1 + IF ( cyclen .NE. helium%m_value ) EXIT + END DO + END IF + + CASE (helium_mdist_quadratic) + x = next_random_number(helium%rng_stream_uniform) + IF ( x .LT. r ) THEN + cyclen = helium%m_value + ELSE + DO + x = next_random_number(helium%rng_stream_uniform) + y = (3.0_dp*x)**(1.0_dp/3.0_dp) + z = 3.0_dp**(1.0_dp/3.0_dp) + cyclen = INT(helium%maxcycle*y/z)+1 + IF ( cyclen .NE. helium%m_value ) EXIT + END DO + END IF + + CASE (helium_mdist_exponential) + x = next_random_number(helium%rng_stream_uniform) + IF ( x .LT. r ) THEN + cyclen = helium%m_value + ELSE + DO + DO + x = next_random_number(helium%rng_stream_uniform) + IF ( x .GE. 0.01_dp ) EXIT + END DO + z = -LOG(0.01_dp) + y = LOG(x)/z+1.0_dp; + cyclen = INT(helium%maxcycle*y)+1 + IF ( cyclen .NE. helium%m_value ) EXIT + END DO + END IF + + CASE (helium_mdist_gaussian) + x = next_random_number(helium%rng_stream_uniform) + IF ( x .LT. r ) THEN + cyclen = 1 + ELSE + DO + x = next_random_number(helium%rng_stream_gaussian) + cyclen = INT(x * 0.75_dp + helium%m_value - 0.5_dp)+1 + IF ( cyclen .NE. 1 ) EXIT + END DO + END IF + + CASE DEFAULT + WRITE(stmp,*) helium%m_dist_type + err_str = "M distribution type unknown (" // TRIM(ADJUSTL(stmp)) // ")" + CPABORT(err_str) + cyclen = 1 + + END SELECT + + IF (cyclen<1) cyclen = 1 + IF (cyclen>helium%maxcycle) cyclen = helium%maxcycle + helium%num_accepted(1,cyclen) = helium%num_accepted(1,cyclen) + 1 ! check, if permutation of this length can be constructed - IF (ncycles == 1) THEN + IF (cyclen == 1) THEN rnd = next_random_number(helium%rng_stream_uniform) helium%ptable(1)=1+INT(rnd*helium%atoms) helium%ptable(2)=-1 helium%pweight=0.0_dp - nselected = 1 + selected = .TRUE. ELSE - nselected = helium_select_permutation(helium,ncycles) + selected = helium_select_permutation(helium,cyclen) END IF - IF (nselected /= 0) THEN - ! the permutation was successfully selected - actually sample this permutation - res = helium_slice_metro_cyclic(helium, pint_env, ncycles) + IF (selected) THEN + ! permutation was successfully selected - actually sample this permutation + accepted = helium_slice_metro_cyclic(helium, pint_env, cyclen) + ELSE + accepted = .FALSE. + END IF + +!if (any(helium%pos .ne. helium%work)) then +! print *, "" +! print *, "pos and work are different!" +! print *, "" +!end if + + IF (accepted) THEN + ! positions changed + IF (helium%solute_present) THEN + ! use COM of the solute, but it did not move here so do nothing to save cpu + ELSE + IF (helium%periodic) THEN + ! use center of the cell, but it did not move here so do nothing to save cpu + ELSE + ! update center of mass + helium%center(:) = helium_com(helium) + END IF + END IF END IF END DO @@ -373,30 +597,33 @@ MODULE helium_sampling RETURN END SUBROUTINE helium_try_permutations -! ***************************************************************************** -!> \brief ... + +! *************************************************************************** +!> \brief Sample path variables for permutation of length !> \param helium ... !> \param pint_env ... -!> \param n ... -!> \retval res 1 - if the MC move was accepted, 0 - otherwise +!> \param cyclen ... +!> \retval res ... !> \author hforbert ! ***************************************************************************** - FUNCTION helium_slice_metro_cyclic(helium,pint_env,n) RESULT(res) + FUNCTION helium_slice_metro_cyclic(helium,pint_env,cyclen) RESULT(res) TYPE(helium_solvent_type), POINTER :: helium TYPE(pint_env_type), POINTER :: pint_env - INTEGER, INTENT(IN) :: n - INTEGER :: res + INTEGER, INTENT(IN) :: cyclen + LOGICAL :: res CHARACTER(len=*), PARAMETER :: routineN = 'helium_slice_metro_cyclic', & routineP = moduleN//':'//routineN - INTEGER :: c, hbeads, i, j, k, l, level, & - m, nb, pk1, pk2, stride + CHARACTER(len=default_string_length) :: err_str, stmp + INTEGER :: c, ifix, j, k, l, level, pk1, & + pk2, stride INTEGER, DIMENSION(:), POINTER :: p, perm - LOGICAL :: nperiodic + LOGICAL :: nperiodic, should_reject REAL(KIND=dp) :: cell_size, ds, dtk, e1, e2, & - pds, prev_ds, r, sigma, tmp, x - REAL(KIND=dp), DIMENSION(3) :: rm1, rm2, tmp1, tmp2, x1 + pds, prev_ds, r, rtmp, sigma, & + x + REAL(KIND=dp), DIMENSION(3) :: bis, rm1, rm2, tmp1, tmp2 REAL(KIND=dp), DIMENSION(:, :, :), & POINTER :: pos, work TYPE(spline_data_p_type), & @@ -404,59 +631,68 @@ MODULE helium_sampling ! trial permutation implicit in p ! since we (momentarily) only use cyclic permutations: -! n = 1 : no permutation, sample p[0] anew -! n = 2 : p[0] -> p[1] -> p[0] -! n = 3 : p[0] -> p[1] -> p[2] -> p[0] -! n = 4 : p[0] -> p[1] -> p[2] -> p[3] -> p[0] +! cyclen = 1 : no permutation, sample p[0] anew +! cyclen = 2 : p[0] -> p[1] -> p[0] +! cyclen = 3 : p[0] -> p[1] -> p[2] -> p[0] +! cyclen = 4 : p[0] -> p[1] -> p[2] -> p[3] -> p[0] - m = helium%bisection - p => helium%ptable - prev_ds = helium%pweight + p => helium%ptable + prev_ds = helium%pweight - helium%num_accepted(2,n) = helium%num_accepted(2,n) + 1 - level = 1 - res = 0 + helium%num_accepted(2,cyclen) = helium%num_accepted(2,cyclen) + 1 + level = 1 + res = .FALSE. -IF (m==0) RETURN - hbeads = helium%beads - nb = helium%atoms - pos => helium%pos - work => helium%work - perm => helium%permutation - uij => helium%uij - cell_size = (0.5_dp*helium%cell_size)**2 - nperiodic = .NOT.helium%periodic + ! nothing to be done + IF (helium%bisection==0) RETURN -!TODO: use CP2k error/failure mechanisms + ! On entry helium_slice_metro_cyclic ASSUMES that work is a copy of pos + ! and constructs the trial move there. If the move is accepted, the + ! changed parts are copied to pos, but if it fails, only the CHANGED parts + ! of work are overwritten by the corresponding parts of pos. So on exit work + ! will AGAIN be a copy of pos (either way accept/reject). This is done here + ! so we do not have to copy around the whole pos array in the caller, and + ! the caller does not need to know which parts of work might have changed. + pos => helium%pos + work => helium%work + perm => helium%permutation + uij => helium%uij + cell_size = (0.5_dp*helium%cell_size)**2 + nperiodic = .NOT.helium%periodic - pds = prev_ds - i = hbeads - m + 1 + pds = prev_ds + ifix = helium%beads - helium%bisection + 1 - ! sanity checks: - IF (i<1) THEN - PRINT *,"slice_metro_cyclic: i<1 test failed: ",i - CPABORT("") - END IF - j = 1 - k = m - DO + ! sanity checks + ! + IF (ifix<1) THEN + WRITE(stmp,*) ifix + err_str = "ifix<1 test failed (ifix=" // TRIM(ADJUSTL(stmp)) // ")" + CPABORT(err_str) + END IF + ! + j = 1 + k = helium%bisection + DO IF (k<2) EXIT j = j * 2 k = k/2 - END DO - IF (j /= m) THEN - PRINT *,"slice_metro_cyclic: m not a power of 2! ",m - CPABORT("") - END IF - IF (m < 2) THEN - PRINT *,"slice_metro_cyclic: m less than 2! ",m - CPABORT("") - END IF + END DO + ! + IF (j /= helium%bisection) THEN + WRITE(stmp,*) helium%bisection + err_str = "helium%bisection not a power of 2 (helium%bisection=" // TRIM(ADJUSTL(stmp)) // ")" + CPABORT(err_str) + END IF + ! + IF (helium%bisection < 2) THEN + WRITE(stmp,*) helium%bisection + err_str = "helium%bisection less than 2 (helium%bisection=" // TRIM(ADJUSTL(stmp)) // ")" + CPABORT(err_str) + END IF -! work(:,:,:) = pos(:,:,:) - - stride = m - DO + stride = helium%bisection + DO IF (stride <= 2) EXIT ! calc new trial positions ! trial action: 0.5*stride*endpointapprox @@ -464,366 +700,398 @@ IF (m==0) RETURN dtk = 0.0_dp ds = 0.0_dp - j = i+stride/2 + j = ifix + stride/2 DO - IF (j>hbeads-stride/2) EXIT - pk1 = j-stride/2 - pk2 = j+stride/2 - ! calculate log(T(s)): - DO k = 1, n - CALL helium_boxmean_3d( helium, pos(:,p(k),pk1), pos(:,p(k),pk2), x1 ) - tmp1(:) = x1(:) - pos(:,p(k),j) - CALL helium_pbc( helium, tmp1 ) - tmp1(:) = tmp1(:) / sigma - dtk = dtk - 0.5_dp * ( tmp1(1)*tmp1(1) + tmp1(2)*tmp1(2) + tmp1(3)*tmp1(3) ) - END DO - ! calculate log(T(sprime)) and sprime itself - DO k = 1, n - CALL helium_boxmean_3d( helium, work(:,p(k),pk1), work(:,p(k),pk2), tmp1 ) - DO c = 1, 3 - x = next_random_number(rng_stream=helium%rng_stream_gaussian,& - variance=1.0_dp) - x = sigma * x - tmp1(c) = tmp1(c) + x - tmp2(c) = x - END DO - CALL helium_pbc( helium, tmp1 ) - CALL helium_pbc( helium, tmp2 ) - work(:,p(k),j) = tmp1(:) - tmp2(:) = tmp2(:) / sigma - dtk = dtk + 0.5_dp * ( tmp2(1)*tmp2(1) + tmp2(2)*tmp2(2) + tmp2(3)*tmp2(3) ) - END DO - j = j + stride - END DO - - j = hbeads - stride/2 + 1 - pk1 = j - stride/2 - DO k = 1, n - CALL helium_boxmean_3d( helium, pos(:,p(k),pk1), pos(:,perm(p(k)),1), x1 ) - tmp1(:) = x1(:) - pos(:,p(k),j) - CALL helium_pbc( helium, tmp1 ) - tmp1(:) = tmp1(:) / sigma - dtk = dtk - 0.5_dp * ( tmp1(1)*tmp1(1) + tmp1(2)*tmp1(2) + tmp1(3)*tmp1(3) ) - END DO - DO k = 1, n - CALL helium_boxmean_3d( helium, work(:,p(k),pk1), work(:,perm(p(1+MOD(k,n))),1), tmp1 ) - DO c = 1, 3 - x = next_random_number(rng_stream=helium%rng_stream_gaussian,& - variance=1.0_dp) + IF (j>helium%beads-stride/2) EXIT + pk1 = j-stride/2 + pk2 = j+stride/2 + ! calculate log(T(s)): + DO k = 1, cyclen + CALL helium_boxmean_3d( helium, pos(:,p(k),pk1), pos(:,p(k),pk2), bis ) + tmp1(:) = bis(:) - pos(:,p(k),j) + CALL helium_pbc( helium, tmp1 ) + tmp1(:) = tmp1(:) / sigma + dtk = dtk - 0.5_dp * ( tmp1(1)*tmp1(1) + tmp1(2)*tmp1(2) + tmp1(3)*tmp1(3) ) + END DO + ! calculate log(T(sprime)) and sprime itself + DO k = 1, cyclen + CALL helium_boxmean_3d( helium, work(:,p(k),pk1), work(:,p(k),pk2), tmp1 ) + DO c = 1, 3 + x = next_random_number(rng_stream=helium%rng_stream_gaussian,variance=1.0_dp) x = sigma * x tmp1(c) = tmp1(c) + x tmp2(c) = x - END DO - CALL helium_pbc( helium, tmp1 ) - CALL helium_pbc( helium, tmp2 ) - work(:,p(k),j) = tmp1(:) - tmp2(:) = tmp2(:) / sigma - dtk = dtk + 0.5_dp * ( tmp2(1)*tmp2(1) + tmp2(2)*tmp2(2) + tmp2(3)*tmp2(3) ) + END DO + CALL helium_pbc( helium, tmp1 ) + CALL helium_pbc( helium, tmp2 ) + work(:,p(k),j) = tmp1(:) + tmp2(:) = tmp2(:) / sigma + dtk = dtk + 0.5_dp * ( tmp2(1)*tmp2(1) + tmp2(2)*tmp2(2) + tmp2(3)*tmp2(3) ) + END DO + j = j + stride + END DO + + j = helium%beads - stride/2 + 1 + pk1 = j - stride/2 + DO k = 1, cyclen + CALL helium_boxmean_3d( helium, pos(:,p(k),pk1), pos(:,perm(p(k)),1), bis ) + tmp1(:) = bis(:) - pos(:,p(k),j) + CALL helium_pbc( helium, tmp1 ) + tmp1(:) = tmp1(:) / sigma + dtk = dtk - 0.5_dp * ( tmp1(1)*tmp1(1) + tmp1(2)*tmp1(2) + tmp1(3)*tmp1(3) ) + END DO + DO k = 1, cyclen + CALL helium_boxmean_3d( helium, work(:,p(k),pk1), work(:,perm(p(1+MOD(k,cyclen))),1), tmp1 ) + DO c = 1, 3 + x = next_random_number(rng_stream=helium%rng_stream_gaussian,variance=1.0_dp) + x = sigma * x + tmp1(c) = tmp1(c) + x + tmp2(c) = x + END DO + CALL helium_pbc( helium, tmp1 ) + CALL helium_pbc( helium, tmp2 ) + work(:,p(k),j) = tmp1(:) + tmp2(:) = tmp2(:) / sigma + dtk = dtk + 0.5_dp * ( tmp2(1)*tmp2(1) + tmp2(2)*tmp2(2) + tmp2(3)*tmp2(3) ) END DO ! ok we got the new positions ! calculate action_k(s)-action_k(sprime) x = 1.0_dp/(helium%tau*helium%hb2m*stride) - j = i + j = ifix DO - IF (j>hbeads-stride/2) EXIT - pk1 = j+stride/2 - DO k = 1, n - tmp1(:) = pos(:,p(k),j) - pos(:,p(k),pk1) - CALL helium_pbc( helium, tmp1 ) - ds = ds + x * ( tmp1(1)*tmp1(1) + tmp1(2)*tmp1(2) + tmp1(3)*tmp1(3) ) - tmp1(:) = work(:,p(k),j) - work(:,p(k),pk1) - CALL helium_pbc( helium, tmp1 ) - ds = ds - x * ( tmp1(1)*tmp1(1) + tmp1(2)*tmp1(2) + tmp1(3)*tmp1(3) ) - ! interaction change - IF (helium%solute_present) THEN - CALL helium_bead_solute_e(pint_env, helium, p(k), pk1, energy=e1) - CALL helium_bead_solute_e(pint_env, helium, p(k), pk1, work(:,p(k),pk1), e2) - ds=ds + (stride/2)*(e1-e2) * helium%tau + IF (j>helium%beads-stride/2) EXIT + pk1 = j+stride/2 + DO k = 1, cyclen + tmp1(:) = pos(:,p(k),j) - pos(:,p(k),pk1) + CALL helium_pbc( helium, tmp1 ) + ds = ds + x * ( tmp1(1)*tmp1(1) + tmp1(2)*tmp1(2) + tmp1(3)*tmp1(3) ) + tmp1(:) = work(:,p(k),j) - work(:,p(k),pk1) + CALL helium_pbc( helium, tmp1 ) + ds = ds - x * ( tmp1(1)*tmp1(1) + tmp1(2)*tmp1(2) + tmp1(3)*tmp1(3) ) + ! interaction change + IF (helium%solute_present) THEN + CALL helium_bead_solute_e_f(pint_env, helium, p(k), pk1, energy=e1) + CALL helium_bead_solute_e_f(pint_env, helium, p(k), pk1, work(:,p(k),pk1), e2) + ds=ds + (stride/2)*(e1-e2) * helium%tau + END IF + DO l = 1, helium%atoms + IF (l /= p(k)) THEN + tmp1(:) = pos(:,p(k),pk1) - pos(:,l,pk1) + CALL helium_pbc( helium, tmp1 ) + r = tmp1(1)*tmp1(1) + tmp1(2)*tmp1(2) + tmp1(3)*tmp1(3) + IF ( (r < cell_size) .OR. nperiodic) THEN + r = SQRT(r) + ds = ds + REAL(stride/2,dp)*helium_spline(uij(1,1)%spline_data,r) + END IF + tmp1(:) = work(:,p(k),pk1) - work(:,l,pk1) + CALL helium_pbc( helium, tmp1 ) + r = tmp1(1)*tmp1(1) + tmp1(2)*tmp1(2) + tmp1(3)*tmp1(3) + IF ( (r < cell_size) .OR. nperiodic) THEN + r = SQRT(r) + ds = ds - REAL(stride/2,dp)*helium_spline(uij(1,1)%spline_data,r) + END IF END IF - DO l = 1, nb - IF (l /= p(k)) THEN - tmp1(:) = pos(:,p(k),pk1) - pos(:,l,pk1) - CALL helium_pbc( helium, tmp1 ) - r = tmp1(1)*tmp1(1) + tmp1(2)*tmp1(2) + tmp1(3)*tmp1(3) - IF ( (r < cell_size) .OR. nperiodic) THEN - r = SQRT(r) - ds = ds + (stride/2)*helium_spline(uij(1,1)%spline_data,r) - END IF - tmp1(:) = work(:,p(k),pk1) - work(:,l,pk1) - CALL helium_pbc( helium, tmp1 ) - r = tmp1(1)*tmp1(1) + tmp1(2)*tmp1(2) + tmp1(3)*tmp1(3) - IF ( (r < cell_size) .OR. nperiodic) THEN - r = SQRT(r) - ds = ds - (stride/2)*helium_spline(uij(1,1)%spline_data,r) - END IF - END IF + END DO + ! counted p[k], p[m] twice. subtract those again + IF (k < cyclen) THEN + DO l = k+1, cyclen + tmp1(:) = pos(:,p(k),pk1) - pos(:,p(l),pk1) + CALL helium_pbc( helium, tmp1 ) + r = tmp1(1)*tmp1(1) + tmp1(2)*tmp1(2) + tmp1(3)*tmp1(3) + IF ( (r < cell_size) .OR. nperiodic) THEN + r = SQRT(r) + ds = ds - REAL(stride/2,dp)*helium_spline(uij(1,1)%spline_data,r) + END IF + tmp1(:) = work(:,p(k),pk1) - work(:,p(l),pk1) + CALL helium_pbc( helium, tmp1 ) + r = tmp1(1)*tmp1(1) + tmp1(2)*tmp1(2) + tmp1(3)*tmp1(3) + IF ( (r < cell_size) .OR. nperiodic) THEN + r = SQRT(r) + ds = ds + REAL(stride/2,dp)*helium_spline(uij(1,1)%spline_data,r) + END IF END DO - ! counted p[k], p[m] twice. subtract those again - IF (k < n) THEN - DO l = k+1, n - tmp1(:) = pos(:,p(k),pk1) - pos(:,p(l),pk1) - CALL helium_pbc( helium, tmp1 ) - r = tmp1(1)*tmp1(1) + tmp1(2)*tmp1(2) + tmp1(3)*tmp1(3) - IF ( (r < cell_size) .OR. nperiodic) THEN - r = SQRT(r) - ds = ds - (stride/2)*helium_spline(uij(1,1)%spline_data,r) - END IF - tmp1(:) = work(:,p(k),pk1) - work(:,p(l),pk1) - CALL helium_pbc( helium, tmp1 ) - r = tmp1(1)*tmp1(1) + tmp1(2)*tmp1(2) + tmp1(3)*tmp1(3) - IF ( (r < cell_size) .OR. nperiodic) THEN - r = SQRT(r) - ds = ds + (stride/2)*helium_spline(uij(1,1)%spline_data,r) - END IF - END DO - END IF - END DO - j = j + stride/2 + END IF + END DO + j = j + stride/2 END DO ! last link - pk1 = hbeads - stride/2 + 1 - DO k = 1, n - tmp1(:) = pos(:,p(k),pk1) - pos(:,perm(p(k)),1) - CALL helium_pbc( helium, tmp1 ) - ds = ds + x * ( tmp1(1)*tmp1(1) + tmp1(2)*tmp1(2) + tmp1(3)*tmp1(3) ) - tmp1(:) = work(:,p(k),pk1) - work(:,perm(p(1+MOD(k,n))),1) - CALL helium_pbc( helium, tmp1 ) - ds = ds - x * ( tmp1(1)*tmp1(1) + tmp1(2)*tmp1(2) + tmp1(3)*tmp1(3) ) + pk1 = helium%beads - stride/2 + 1 + DO k = 1, cyclen + tmp1(:) = pos(:,p(k),pk1) - pos(:,perm(p(k)),1) + CALL helium_pbc( helium, tmp1 ) + ds = ds + x * ( tmp1(1)*tmp1(1) + tmp1(2)*tmp1(2) + tmp1(3)*tmp1(3) ) + tmp1(:) = work(:,p(k),pk1) - work(:,perm(p(1+MOD(k,cyclen))),1) + CALL helium_pbc( helium, tmp1 ) + ds = ds - x * ( tmp1(1)*tmp1(1) + tmp1(2)*tmp1(2) + tmp1(3)*tmp1(3) ) END DO ! ok now accept or reject: - tmp = next_random_number(helium%rng_stream_uniform) -! IF ((dtk+ds-pds < 0.0_dp).AND.(EXP(dtk+ds-pds)1) THEN + END DO + IF (cyclen>1) THEN !k,c,l c = perm(p(1)) - DO k = 1, n - 1 - perm(p(k)) = perm(p(k+1)) + DO k = 1, cyclen-1 + perm(p(k)) = perm(p(k+1)) END DO - perm(p(n)) = c - END IF - DO k = 1, n - DO l = 1, nb - IF (l /= p(k)) THEN - rm1(:)=work(:,p(k),j)-work(:,l,j) - rm2(:)=work(:,perm(p(k)),1)-work(:,perm(l),1) - ds = ds - helium_eval_expansion(helium,rm1,rm2,uij,1) - END IF + perm(p(cyclen)) = c + END IF + DO k = 1, cyclen + DO l = 1, helium%atoms + IF (l /= p(k)) THEN + rm1(:)=work(:,p(k),j)-work(:,l,j) + rm2(:)=work(:,perm(p(k)),1)-work(:,perm(l),1) + ds = ds - helium_eval_expansion(helium,rm1,rm2,uij,1) + END IF END DO ! counted p[k], p[m] twice. subtract those again - IF (k < n) THEN - DO l = k+1, n - rm1(:)=work(:,p(k),j)-work(:,p(l),j) - rm2(:)=work(:,perm(p(k)),1)-work(:,perm(p(l)),1) - ds = ds + helium_eval_expansion(helium,rm1,rm2,uij,1) - END DO + IF (k < cyclen) THEN + DO l = k+1, cyclen + rm1(:)=work(:,p(k),j)-work(:,p(l),j) + rm2(:)=work(:,perm(p(k)),1)-work(:,perm(p(l)),1) + ds = ds + helium_eval_expansion(helium,rm1,rm2,uij,1) + END DO END IF - END DO - ! ok now accept or reject: - tmp = next_random_number(helium%rng_stream_uniform) -! IF ((dtk+ds-pds<0.0_dp).AND.(EXP(dtk+ds-pds)1) THEN - c = perm(p(n)) - DO k = n - 1, 1, -1 - perm(p(k+1)) = perm(p(k)) - END DO - perm(p(1)) = c -END IF - RETURN + END DO + ! ok now accept or reject: + rtmp = next_random_number(helium%rng_stream_uniform) +! IF ((dtk+ds-pds<0.0_dp).AND.(EXP(dtk+ds-pds)1) THEN + c = perm(p(cyclen)) + DO k = cyclen-1, 1, -1 + perm(p(k+1)) = perm(p(k)) + END DO + perm(p(1)) = c + END IF + RETURN END IF - END IF - ! accepted. - ! copy trial over to the real thing -DO c = i, hbeads -DO k = 1, n -pos(:,p(k),c)=work(:,p(k),c) -END DO -END DO -DO k = 1, n -helium%iperm(perm(p(k))) = p(k) -END DO -! pos(:,:,:) = work(:,:,:) + END IF + ! accepted. - helium%num_accepted(level+2,n) = helium%num_accepted(level+2,n) + 1 - res = 1 + ! rejection of the whole move if any of the new positions is farther away + ! from the current center of gravity than HELIUM%DROPLET_RADIUS [lwalewski] + IF (helium%droplet_radius .LT. HUGE(1.0_dp)) THEN + ! cycle through new positions + should_reject = .FALSE. + outer: DO c = ifix, helium%beads + DO k = 1, cyclen + bis(:) = work(:,p(k),c) - helium%center(:) + rtmp = SQRT(bis(1)*bis(1) + bis(2)*bis(2) + bis(3)*bis(3)) + IF (rtmp .GE. helium%droplet_radius) THEN + ! found - this one does not fit within R from the center + should_reject = .TRUE. + EXIT outer + END IF + END DO + END DO outer + IF (should_reject) THEN + ! restore work and perm, then return + DO c = ifix, helium%beads + DO k = 1, cyclen + work(:,p(k),c)=pos(:,p(k),c) + END DO + END DO + IF (cyclen>1) THEN + c = perm(p(cyclen)) + DO k = cyclen-1, 1, -1 + perm(p(k+1)) = perm(p(k)) + END DO + perm(p(1)) = c + END IF + RETURN + END IF + ! Note: after CoM position gets updated according to the new positions + ! some beads may end up outside of the DROPLET_RADIUS range from the new + ! CoM, they should not be very far off, though. + END IF + ! accepted. + + ! copy trial over to the real thing + DO c = ifix, helium%beads + DO k = 1, cyclen + pos(:,p(k),c)=work(:,p(k),c) + END DO + END DO + DO k = 1, cyclen + helium%iperm(perm(p(k))) = p(k) + END DO + helium%num_accepted(level+2,cyclen) = helium%num_accepted(level+2,cyclen) + 1 + res = .TRUE. RETURN END FUNCTION helium_slice_metro_cyclic -! ***************************************************************************** -!> \brief ... + +! *************************************************************************** +!> \brief ... !> \param helium ... !> \param len ... -!> \retval res 1 - if the permutation was successfully selected, 0 - otherwise +!> \retval res ... !> \author hforbert ! ***************************************************************************** FUNCTION helium_select_permutation(helium,len) RESULT(res) TYPE(helium_solvent_type), POINTER :: helium INTEGER, INTENT(IN) :: len - INTEGER :: res + LOGICAL :: res INTEGER :: i, j, k, n INTEGER, DIMENSION(:), POINTER :: iperm, p, perm INTEGER, DIMENSION(:, :), POINTER :: nmatrix REAL(KIND=dp) :: rnd, s1, s2, t - REAL(kind=dp), DIMENSION(:, :), POINTER :: ipmatrix, pmatrix, tmatrix + REAL(KIND=dp), DIMENSION(:, :), POINTER :: ipmatrix, pmatrix, tmatrix s1 = 0.0_dp s2 = 0.0_dp - res = 0 + res = .FALSE. n = helium%atoms tmatrix => helium%tmatrix pmatrix => helium%pmatrix @@ -876,7 +1144,7 @@ END DO s1 = s1 + pmatrix(p(k),perm(p(k+1))) - pmatrix(p(k),perm(p(k))) END DO helium%pweight = s1 - res = 1 + res = .TRUE. RETURN END FUNCTION helium_select_permutation diff --git a/src/motion/helium_types.F b/src/motion/helium_types.F new file mode 100644 index 0000000000..65075f6442 --- /dev/null +++ b/src/motion/helium_types.F @@ -0,0 +1,398 @@ +!-----------------------------------------------------------------------------! +! CP2K: A general program to perform molecular dynamics simulations ! +! Copyright (C) 2000 - 2015 CP2K developers group ! +!-----------------------------------------------------------------------------! + +! ***************************************************************************** +!> \brief Data types representing superfluid helium +!> \author hforbert +!> \date 2009-01-01 +!> \par History +!> extracted helium_solvent_type from pint_types.F [lwalewski] +! ***************************************************************************** +MODULE helium_types + + USE cell_types, ONLY: cell_type + USE cp_log_handling, ONLY: cp_logger_type + USE input_section_types, ONLY: section_vals_type + USE kinds, ONLY: default_string_length,& + dp,& + int_8 + USE parallel_rng_types, ONLY: rng_stream_type + USE splines_types, ONLY: spline_data_p_type +#include "../base/base_uses.f90" + + IMPLICIT NONE + + PRIVATE + + LOGICAL, PRIVATE, PARAMETER :: debug_this_module=.TRUE. + CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'helium_types' + + REAL(KIND=dp), PARAMETER, PUBLIC :: he_mass = 4.00263037059764_dp !< 4He mass in [u] + + !> Energy contributions - symbolic names for indexing energy arrays + INTEGER, PARAMETER, PUBLIC :: & + e_id_total = 1, & + e_id_potential = 2, & + e_id_kinetic = 3, & + e_id_interact = 4, & + e_id_thermo = 5, & + e_id_virial = 6 + + !> Number of energy contributions for static array allocation + INTEGER, PARAMETER, PUBLIC :: e_num_ids = 10 + + !> number of density function identifiers + INTEGER, PARAMETER, PUBLIC :: rho_num = 5 + + !> density function identifier names + INTEGER, PARAMETER, PUBLIC :: & + rho_atom_number = 1, & + rho_projected_area = 2,& + rho_winding_number = 3,& + rho_winding_cycle = 4,& + rho_moment_of_inertia = 5 + + !> number of atom type identifiers + INTEGER, PARAMETER, PUBLIC :: hid_num = 4 + + !> atom type identifier names (for helium-solute interactions) + INTEGER, PARAMETER, PUBLIC :: & + hid_chlorine = 1, & + hid_oxygen = 2,& + hid_hydrogen = 3, & + hid_carbon = 4 + + !> derived data types + PUBLIC :: helium_solvent_type + PUBLIC :: int_arr_ptr + PUBLIC :: real_arr_ptr + + !> functions + PUBLIC :: helium_destroy_int_arr_ptr + PUBLIC :: helium_destroy_real_arr_ptr + + +! *************************************************************************** +!> \brief Vector type useful for averaging +!> \author Lukasz Walewski +!> \date 2014-09-09 +! *************************************************************************** + TYPE helium_vector_type + + !> instantaneous value + REAL(KIND=dp), DIMENSION(3) :: inst + + !> accumulated value + REAL(KIND=dp), DIMENSION(3) :: accu + + !> running average + REAL(KIND=dp), DIMENSION(3) :: ravr + + !> restarted value + REAL(KIND=dp), DIMENSION(3) :: rstr + + END TYPE helium_vector_type + + +! *************************************************************************** +!> \brief data structure for solvent helium +!> \author hforbert +! *************************************************************************** + TYPE helium_solvent_type + + INTEGER :: id_nr !< identification number of this data structure + INTEGER :: ref_count !< reference count of this data structure + TYPE(section_vals_type), POINTER :: input !< input data structure (the whole tree) + TYPE(cp_logger_type), POINTER :: logger + + INTEGER :: num_env !< number of He environments in runtime + INTEGER :: num_env_restart !< number of He environments in restart file + + INTEGER :: atoms !< number of atoms + INTEGER :: beads !< number of beads per atom (needs to be an integer multiple of the solute's number of beads) + INTEGER :: bead_ratio !< ratio of helium beads to system beads + REAL(KIND=dp) :: density !< helium density for free bulk in box + + ! some useful constants + ! + REAL(KIND=dp) :: hb2m !< hbar squared over m for 4He in CP2k units + REAL(KIND=dp) :: tau !< 1/(k_B T p) with T - He temperature, p - number of beads + REAL(KIND=dp) :: wpref !< prefactor for calculating superfluid fraction from <(M*W)^2> + REAL(KIND=dp) :: apref !< prefactor for calculating superfluid fraction from + + ! PBC related + ! + LOGICAL :: periodic !< true if bulk liquid helium in periodic box + INTEGER :: cell_shape !< unit cell shape for PBC calculations + REAL(KIND=dp) :: cell_size !< size of the periodic box (helium only) + REAL(KIND=dp) :: cell_size_inv !< 1/cell_size (inverse) + REAL(KIND=dp), DIMENSION(3,3) :: cell_m !< the unit cell vectors' matrix + REAL(KIND=dp), DIMENSION(3,3) :: cell_m_inv !< invrse of the unit cell vectors' matrix + REAL(KIND=dp), DIMENSION(3) :: origin !< origin of the cell (first voxel position) + REAL(KIND=dp) :: droplet_radius !< radius of the droplet + + REAL(KIND=dp), DIMENSION(3) :: center !< COM of solute (if present) or center of periodic cell (if periodic) or COM of helium + + ! sampling parameters + INTEGER :: sampling_method + + INTEGER :: iter_norot !< number of iterations to try for a given imaginary time slice rotation (num inner MC loop iters) + INTEGER :: iter_rot !< number of rotations to try (total number of iterations is iter_norot*iter_rot) (num outer MC loop iters) + ! + INTEGER :: maxcycle !< maximum cyclic permutation change to attempt + INTEGER :: m_dist_type !< distribution from which the cycle length m is sampled + INTEGER :: m_value !< cycle length sampled with different probability than other lengths + REAL(KIND=dp) :: m_ratio !< probability ratio betw m_value and other possible values of m + ! + INTEGER :: relrot !< relative rotation in imaginary time wrt normal system/starting configuration + INTEGER :: bisection !< power of 2 number for bisection algorithm + INTEGER :: bisctlog2 !< log2(bisection) + + REAL(KIND=dp) :: e_corr !< potential correction energy due to finite box + INTEGER :: pdx !< pair density expansion max exponent + + ! MC step counters + ! + INTEGER :: num_steps !< number of iterations in the current run + INTEGER :: first_step !< first step, restarted from MOTION%PINT%ITERATION (default value: 0) + INTEGER :: last_step + INTEGER :: current_step !< first_step + number of steps performed so far + + ! helium variables + ! + REAL(KIND=dp), DIMENSION(:,:,:), POINTER :: pos !< position of the helium atoms DIM(3,atoms,beads) + REAL(KIND=dp), DIMENSION(:,:,:), POINTER :: work !< same dimensions as pos + ! + INTEGER, DIMENSION(:), POINTER :: permutation !< current permutation state DIM(atoms) + INTEGER, DIMENSION(:), POINTER :: iperm !< inverse of the current permutation state DIM(atoms) + INTEGER, DIMENSION(:), POINTER :: ptable !< proposed cyclic permutation, DIM(max_cycle) + INTEGER(KIND=int_8) :: accepts !< number of accepted new configurations + ! + REAL(KIND=dp), DIMENSION(:,:), POINTER :: tmatrix !< ? permutation probability related + REAL(KIND=dp), DIMENSION(:,:), POINTER :: pmatrix !< ? permutation probability related [use might change/new ones added/etc] + REAL(KIND=dp) :: pweight !< ? permutation probability related + REAL(KIND=dp), DIMENSION(:,:), POINTER :: ipmatrix + INTEGER, DIMENSION(:,:), POINTER :: nmatrix + + TYPE (spline_data_p_type), DIMENSION(:,:), POINTER :: uij !< pair density matrix coefficients (action) + TYPE (spline_data_p_type), DIMENSION(:,:), POINTER :: eij !< pair density matrix coefficients (energy) + + ! calculated properties + ! + REAL(KIND=dp), DIMENSION(e_num_ids) :: energy_inst !< energy contributions (instantaneous) + REAL(KIND=dp), DIMENSION(e_num_ids) :: energy_avrg !< energy contributions (averaged) + TYPE(helium_vector_type) :: wnumber !< winding number + TYPE(helium_vector_type) :: wnmber2 !< winding number squared + TYPE(helium_vector_type) :: proarea !< projected area + TYPE(helium_vector_type) :: prarea2 !< projected area squared + TYPE(helium_vector_type) :: mominer !< moment of inertia + INTEGER :: averages_iweight !< weight for restarted averages + LOGICAL :: averages_restarted !< flag indicating whether the averages have been restarted + + ! + INTEGER :: rdf_nbin !< number of bins for RDF + INTEGER :: rdf_iweight !< weight for restarted RDF + INTEGER :: rho_iweight !< weight for restarted RHO + INTEGER :: rdf_num !< number of RDF estimators + INTEGER :: rdf_num_ctr !< number of centers for RDF calc + REAL(KIND=dp) :: rdf_delr !< delta r for RDF + REAL(KIND=dp) :: rdf_maxr !< maximum r for RDF + REAL(KIND=dp), DIMENSION(:), POINTER :: rdf_centers !< positions of RDF centers + REAL(KIND=dp), DIMENSION(:,:,:), POINTER :: rdf_inst !< RDF (instantaneous/tmp array) + REAL(KIND=dp), DIMENSION(:,:,:), POINTER :: rdf_rstr !< RDF (restarted) + REAL(KIND=dp), DIMENSION(:,:,:), POINTER :: rdf_accu !< RDF (accumulated for one run) + LOGICAL :: rdf_present + ! + INTEGER :: rho_nbin + INTEGER :: rho_num_act !< actual number of density estimators + INTEGER :: rho_num_min_len_wdg !< number of optional estimators based on winding cycles + INTEGER :: rho_num_min_len_non!< number of optional estimators based on non-winding cycles + INTEGER :: rho_num_min_len_all!< number of optional estimators based on all cycles + INTEGER, DIMENSION(:), POINTER :: rho_min_len_wdg_vals !< minimum lengths of winding cycles + INTEGER, DIMENSION(:), POINTER :: rho_min_len_non_vals !< minimum lengths of non-winding cycles + INTEGER, DIMENSION(:), POINTER :: rho_min_len_all_vals !< minimum lengths of all cycles + REAL(KIND=dp) :: rho_delr, rho_maxr + REAL(KIND=dp), DIMENSION(:,:,:,:), POINTER :: rho_inst + REAL(KIND=dp), DIMENSION(:,:,:,:), POINTER :: rho_rstr + REAL(KIND=dp), DIMENSION(:,:,:,:), POINTER :: rho_accu + LOGICAL :: rho_present + REAL(KIND=dp), DIMENSION(:,:,:), POINTER :: rho_incr !< increment for density bining + + TYPE(density_properties_type), DIMENSION(:), POINTER :: rho_property + + REAL(KIND=dp), DIMENSION(:,:), POINTER :: num_accepted !< average number of accepted permutations of a given length + !! on a given Levy level, plus one additional level which + !! counts # of trials, REAL(BISCTLOG2+2, MAX_PERM_CYCLE) + !! num_accepted(1,l) - # of trials for perm length l + !! num_accepted(2,l) - # of selected perms of length l + !! num_accepted(3,l) - # of perms of length l accepted at level 1 + !! average over He environments/processors + REAL(KIND=dp), DIMENSION(:), POINTER :: plength_avrg !< permutation length probability distribution DIM(atoms) + REAL(KIND=dp), DIMENSION(:), POINTER :: plength_inst !< instantaneous permutation length probability DIM(atoms) + INTEGER, DIMENSION(:), POINTER :: atom_plength !< length of the permutation cycle the atom belongs to DIM(atoms) + + TYPE(rng_stream_type), POINTER :: rng_stream_uniform !< random number stream with uniform distribution + TYPE(rng_stream_type), POINTER :: rng_stream_gaussian !< random number stream with gaussian distribution + + ! variables related to solvated molecular system + ! + LOGICAL :: solute_present !< switch the interactions with the solute on or off + INTEGER :: solute_atoms !< number of solute atoms (pint_env%ndim/3) + INTEGER :: solute_beads !< number of solute beads (pint_env%p) + INTEGER :: get_helium_forces !< parameter to determine whether the average or last MC force should be taken to MD + CHARACTER(LEN=2), DIMENSION(:), POINTER :: solute_element !< element names of solute atoms (pint_env%ndim/3) + TYPE(int_arr_ptr), DIMENSION(:), POINTER :: solute_i !< indices of solute atoms sorted by atomic kinds + TYPE(cell_type), POINTER :: solute_cell !< dimensions of the solvated system cell (a,b,c) (not needed now and should be removed at some point) + REAL(KIND=dp), DIMENSION(:,:), POINTER :: force_avrg !< averaged forces exerted by He solvent on the solute DIM(p,ndim) + REAL(KIND=dp), DIMENSION(:,:), POINTER :: force_inst !< instantaneous forces exerted by He on the solute (p,ndim) + CHARACTER(LEN=2), DIMENSION(:), POINTER :: ename + INTEGER, DIMENSION(:), POINTER :: eid + INTEGER :: enum + INTEGER :: solute_interaction + + LOGICAL :: interaction_pot_scan !< wheather to perform solute-helium interaction scan + + ! temporary arrays for optimization + ! + INTEGER, DIMENSION(:), POINTER :: itmp_atoms_1d !< DIM(atoms) - same as permutation + INTEGER, DIMENSION(:), POINTER :: itmp_atoms_np_1d !< DIM(atoms*num_env) + REAL(KIND=dp), DIMENSION(:), POINTER :: rtmp_3_np_1d !< DIM(3*num_env) + REAL(KIND=dp), DIMENSION(:), POINTER :: rtmp_p_ndim_1d !< DIM(p*ndim) + REAL(KIND=dp), DIMENSION(:), POINTER :: rtmp_p_ndim_np_1d !< DIM(p*ndim*num_env) + REAL(KIND=dp), DIMENSION(:), POINTER :: rtmp_3_atoms_beads_1d !< DIM(3*atoms*beads) + REAL(KIND=dp), DIMENSION(:), POINTER :: rtmp_3_atoms_beads_np_1d + REAL(KIND=dp), DIMENSION(:,:), POINTER :: rtmp_p_ndim_2d !< DIM(p,ndim) + LOGICAL, DIMENSION(:,:,:), POINTER :: ltmp_3_atoms_beads_3d !< DIM(3,atoms,beads) - same as pos + LOGICAL, DIMENSION(:), POINTER :: ltmp_atoms_1d !< DIM(atoms) - for unpacking the permutation + + END TYPE helium_solvent_type + + +! *************************************************************************** +!> \brief Container type for properties of a helium density function +!> \author Lukasz Walewski +!> \date 2014-09-09 +! *************************************************************************** + TYPE density_properties_type + + !> name of this density function + CHARACTER(len=default_string_length) :: name + + !> flag indicating whether this function should be calculated + LOGICAL :: is_calculated + + !> number of components that this function is composed of + INTEGER :: num_components + + !> suffixes for the filenames storing components of this function + CHARACTER(len=default_string_length), DIMENSION(:), POINTER :: filename_suffix + + !> component names + CHARACTER(len=default_string_length), DIMENSION(:), POINTER :: component_name + + !> indices locating the components of this function in the global density arrays + INTEGER, DIMENSION(:), POINTER :: component_index + + END TYPE density_properties_type + + +! *************************************************************************** +!> \brief A pointer to an integer array, data type to be used in arrays of +!> pointers. +!> \author Lukasz Walewski +!> \date 2013-12-11 +! *************************************************************************** + TYPE int_arr_ptr + INTEGER, DIMENSION(:), POINTER :: iap + END TYPE int_arr_ptr + + +! *************************************************************************** +!> \brief A pointer to a real array, data type to be used in arrays of +!> pointers. +!> \author Lukasz Walewski +!> \date 2013-12-11 +! *************************************************************************** + TYPE real_arr_ptr + REAL(KIND=dp), DIMENSION(:), POINTER :: rap + END TYPE real_arr_ptr + + + CONTAINS + + +! *************************************************************************** +!> \brief Deallocate all arrays pointed to by the pointers stored in the +!> integer pointer array +!> \param int_arr_p ... +!> \date 2013-12-12 +!> \author Lukasz Walewski +! ***************************************************************************** + SUBROUTINE helium_destroy_int_arr_ptr(int_arr_p) + + TYPE(int_arr_ptr), DIMENSION(:), POINTER :: int_arr_p + + CHARACTER(len=*), PARAMETER :: routineN = 'helium_destroy_int_arr_ptr', & + routineP = moduleN//':'//routineN + + INTEGER :: ip + +! deallocate memory used by each component of the pointer array + + DO ip = 1, SIZE(int_arr_p) + IF (ASSOCIATED(int_arr_p(ip)%iap)) THEN + DEALLOCATE(int_arr_p(ip)%iap) + END IF + END DO + + ! deallocate the memory used for pointer array + IF (ASSOCIATED(int_arr_p)) THEN + DEALLOCATE(int_arr_p) + END IF + + RETURN + END SUBROUTINE helium_destroy_int_arr_ptr + + +! *************************************************************************** +!> \brief Deallocate all arrays pointed to by the pointers stored in the +!> real pointer array +!> \param real_arr_p ... +!> \date 2013-12-12 +!> \author Lukasz Walewski +! ***************************************************************************** + SUBROUTINE helium_destroy_real_arr_ptr(real_arr_p) + + TYPE(real_arr_ptr), DIMENSION(:), & + POINTER :: real_arr_p + + CHARACTER(len=*), PARAMETER :: routineN = 'helium_destroy_real_arr_ptr', & + routineP = moduleN//':'//routineN + + INTEGER :: ip + +! do not attempt deallocation on null pointer + + IF (.NOT.ASSOCIATED(real_arr_p)) THEN + RETURN + END IF + + ! deallocate memory used by each component of the pointer array + DO ip = 1, SIZE(real_arr_p) + IF (ASSOCIATED(real_arr_p(ip)%rap)) THEN + DEALLOCATE(real_arr_p(ip)%rap) + END IF + END DO + + ! deallocate the memory used for pointer array itself + IF (ASSOCIATED(real_arr_p)) THEN + DEALLOCATE(real_arr_p) + END IF + + RETURN + END SUBROUTINE helium_destroy_real_arr_ptr + + +END MODULE helium_types diff --git a/src/motion/input_cp2k_restarts.F b/src/motion/input_cp2k_restarts.F index 871f7a616a..96170a895c 100644 --- a/src/motion/input_cp2k_restarts.F +++ b/src/motion/input_cp2k_restarts.F @@ -1053,17 +1053,14 @@ CONTAINS routineP = moduleN//':'//routineN CHARACTER(LEN=default_string_length) :: err_str, stmp - INTEGER :: handle, i, itmp, iweight, & + INTEGER :: handle, itmp, iweight, & msglen, nsteps, offset, reqlen INTEGER, DIMENSION(:), POINTER :: int_msg_gather - LOGICAL :: explicit, lbf - REAL(kind=dp) :: bf, bu, rtmp + LOGICAL :: lbf + REAL(kind=dp) :: bf, bu, invproc REAL(kind=dp), DIMENSION(3, 2) :: bg, cg, ig REAL(kind=dp), DIMENSION(:), POINTER :: real_msg, real_msg_gather - REAL(kind=dp), DIMENSION(:, :, :), & - POINTER :: message TYPE(cp_logger_type), POINTER :: logger - TYPE(section_vals_type), POINTER :: tmpsec CALL timeset(routineN,handle) @@ -1085,15 +1082,16 @@ CONTAINS ! ! save coordinates ! - ! allocate the buffer to be passed and fill it with local coords at each proc + ! allocate the buffer to be passed and fill it with local coords at each + ! proc NULLIFY(real_msg) - msglen = SIZE(helium%pos) + msglen = SIZE(helium%pos(:,:,1:helium%beads)) ALLOCATE(real_msg(msglen)) - real_msg(:) = PACK( helium%pos, .TRUE. ) + real_msg(:) = PACK( helium%pos(:,:,1:helium%beads), .TRUE. ) ! allocate the buffer for message passing NULLIFY(real_msg_gather) - msglen = SIZE(helium%pos) * logger%para_env%num_pe + msglen = SIZE(helium%pos(:,:,1:helium%beads)) * logger%para_env%num_pe ALLOCATE(real_msg_gather(msglen)) ! pass the message from all processors to logger%para_env%source @@ -1113,7 +1111,7 @@ CONTAINS ! DEALLOCATE since this array is only used locally DEALLOCATE(real_msg) - + ! ! save permutation state ! @@ -1137,6 +1135,89 @@ CONTAINS ! "The val becomes the owner of the array" - from section_vals_val_set docu NULLIFY(int_msg_gather) + ! + ! save averages + ! + ! update the weighting factor + itmp = helium%averages_iweight + IF ( itmp .LT. 0 ) THEN + itmp = helium%current_step-helium%first_step + ELSE + itmp = itmp + helium%current_step-helium%first_step + END IF + CALL section_vals_val_set(helium%input, & + "MOTION%PINT%HELIUM%AVERAGES%IWEIGHT", & + i_val=itmp) + + ! allocate the buffer for message passing + NULLIFY(real_msg_gather) + msglen = 3 * logger%para_env%num_pe + ALLOCATE(real_msg_gather(msglen)) + + ! gather projected area from all processors + CALL mp_gather( helium%proarea%ravr, & + real_msg_gather, & + logger%para_env%source, & + logger%para_env%group ) + + ! update it in the global input structure + CALL section_vals_val_set( helium%input, & + "MOTION%PINT%HELIUM%AVERAGES%PROJECTED_AREA", & + r_vals_ptr=real_msg_gather) + + ! allocate the buffer for message passing + NULLIFY(real_msg_gather) + msglen = 3 * logger%para_env%num_pe + ALLOCATE(real_msg_gather(msglen)) + + ! gather projected area squared from all processors + CALL mp_gather( helium%prarea2%ravr, & + real_msg_gather, & + logger%para_env%source, & + logger%para_env%group ) + + ! update it in the global input structure + CALL section_vals_val_set( helium%input, & + "MOTION%PINT%HELIUM%AVERAGES%PROJECTED_AREA_2", & + r_vals_ptr=real_msg_gather) + + ! allocate the buffer for message passing + NULLIFY(real_msg_gather) + msglen = 3 * logger%para_env%num_pe + ALLOCATE(real_msg_gather(msglen)) + + ! gather winding number squared from all processors + CALL mp_gather( helium%wnmber2%ravr, & + real_msg_gather, & + logger%para_env%source, & + logger%para_env%group ) + + ! update it in the global input structure + CALL section_vals_val_set( helium%input, & + "MOTION%PINT%HELIUM%AVERAGES%WINDING_NUMBER_2", & + r_vals_ptr=real_msg_gather) + + ! allocate the buffer for message passing + NULLIFY(real_msg_gather) + msglen = 3 * logger%para_env%num_pe + ALLOCATE(real_msg_gather(msglen)) + + ! gather moment of inertia from all processors + CALL mp_gather( helium%mominer%ravr, & + real_msg_gather, & + logger%para_env%source, & + logger%para_env%group ) + + ! update it in the global input structure + CALL section_vals_val_set( helium%input, & + "MOTION%PINT%HELIUM%AVERAGES%MOMENT_OF_INERTIA", & + r_vals_ptr=real_msg_gather) + + ! NULLIFY, but do not DEALLOCATE! - a new pointer to this array is silently + ! assigned in section_vals_val_set - this memory will be used later on! + ! "The val becomes the owner of the array" - from section_vals_val_set docu + NULLIFY(real_msg_gather) + ! ! save RNG state ! @@ -1228,70 +1309,73 @@ CONTAINS NULLIFY(real_msg_gather) END IF + ! + ! save the RDFs + ! + IF (helium%rdf_present) THEN + + ! work on the temporary array so that accumulated data remains intact + helium%rdf_inst(:,:,:) = helium%rdf_accu(:,:,:) + + ! average over processors / helium environments + CALL mp_sum(helium%rdf_inst,logger%para_env%group) + itmp = logger%para_env%num_pe + invproc = 1.0_dp / REAL(itmp,dp) + helium%rdf_inst(:,:,:) = helium%rdf_inst(:,:,:) * invproc + + nsteps = helium%current_step-helium%first_step + helium%rdf_inst(:,:,:) = helium%rdf_inst(:,:,:) / REAL(nsteps,dp) + iweight = helium%rdf_iweight + ! average over the old and the current density (observe the weights!) + helium%rdf_inst(:,:,:) = nsteps * helium%rdf_inst(:,:,:) + & + iweight * helium%rdf_rstr(:,:,:) + helium%rdf_inst(:,:,:) = helium%rdf_inst(:,:,:) / REAL(nsteps + iweight,dp) + ! update in the global input structure + NULLIFY(real_msg) + msglen = SIZE(helium%rdf_inst) + ALLOCATE(real_msg(msglen)) + real_msg(:) = PACK( helium%rdf_inst, .TRUE. ) + CALL section_vals_val_set(& + helium%input, & + "MOTION%PINT%HELIUM%AVERAGES%RDF", & + r_vals_ptr=real_msg) + NULLIFY(real_msg) + + END IF + ! ! save the densities ! IF (helium%rho_present) THEN - ! make sure that the section is explicitly present in the input structure - NULLIFY(tmpsec) - tmpsec => section_vals_get_subs_vals(helium%input, & - "MOTION%PINT%HELIUM%RHO") - CALL section_vals_get(tmpsec,explicit=explicit) - IF ( .NOT. explicit ) THEN - CALL section_vals_add_values(tmpsec) - END IF - ! work on the temporary array so that accumulated data remains intact - helium%rho_inst(:,:,:,:) = helium%rho_avrg(:,:,:,:) + helium%rho_inst(:,:,:,:) = helium%rho_accu(:,:,:,:) - ! average all the density estimators over helium environments - DO i = 1, helium%rho_num - NULLIFY(message) - message => helium%rho_inst(i,1::1,1::1,1::1) - CALL mp_sum(message,logger%para_env%group) - END DO + ! average over processors / helium environments + CALL mp_sum(helium%rho_inst,logger%para_env%group) itmp = logger%para_env%num_pe - CPASSERT(itmp>0) - rtmp = 1.0_dp / REAL(itmp,dp) - helium%rho_inst(:,:,:,:) = helium%rho_inst(:,:,:,:) * rtmp + invproc = 1.0_dp / REAL(itmp,dp) + helium%rho_inst(:,:,:,:) = helium%rho_inst(:,:,:,:) * invproc - ! average over steps performed so far in this run nsteps = helium%current_step-helium%first_step - CPASSERT(nsteps>0) - rtmp = 1.0_dp / REAL(nsteps,dp) - helium%rho_inst(:,:,:,:) = helium%rho_inst(:,:,:,:) * rtmp - - iweight = helium%rho_iweight - rtmp = 1.0_dp / REAL(nsteps+iweight,dp) - IF ( helium%rho_restart ) THEN - ! average over the old and the current density (observe the weights!) - helium%rho_inst(:,:,:,:) = nsteps * helium%rho_inst(:,:,:,:) + & - iweight * helium%rho_rstr(:,:,:,:) - helium%rho_inst(:,:,:,:) = helium%rho_inst(:,:,:,:) * rtmp - END IF + helium%rho_inst(:,:,:,:) = helium%rho_inst(:,:,:,:) / REAL(nsteps,dp) + iweight = helium%averages_iweight + ! average over the old and the current density (observe the weights!) + helium%rho_inst(:,:,:,:) = nsteps * helium%rho_inst(:,:,:,:) + & + iweight * helium%rho_rstr(:,:,:,:) + helium%rho_inst(:,:,:,:) = helium%rho_inst(:,:,:,:) / REAL(nsteps + iweight,dp) ! update the densities in the global input structure NULLIFY(real_msg) msglen = SIZE(helium%rho_inst) ALLOCATE(real_msg(msglen)) real_msg(:) = PACK( helium%rho_inst, .TRUE. ) - CALL section_vals_val_set(helium%input, & - "MOTION%PINT%HELIUM%RHO%CUBE_DATA%_DEFAULT_KEYWORD_", & - r_vals_ptr=real_msg) + CALL section_vals_val_set( & + helium%input, & + "MOTION%PINT%HELIUM%AVERAGES%RHO", & + r_vals_ptr=real_msg) NULLIFY(real_msg) - ! update the weighting factor - itmp = helium%rho_iweight - IF ( itmp .LT. 0 ) THEN - itmp = helium%current_step-helium%first_step - ELSE - itmp = itmp + helium%current_step-helium%first_step - END IF - CALL section_vals_val_set(helium%input, & - "MOTION%PINT%HELIUM%RHO%IWEIGHT", & - i_val=itmp) - END IF CALL timestop(handle) diff --git a/src/motion/pint_methods.F b/src/motion/pint_methods.F index 8469d63e74..3e70f46270 100644 --- a/src/motion/pint_methods.F +++ b/src/motion/pint_methods.F @@ -26,6 +26,8 @@ MODULE pint_methods cp_to_string USE cp_output_handling, ONLY: cp_add_iter_level,& cp_iterate,& + cp_print_key_finished_output,& + cp_print_key_unit_nr,& cp_rm_iter_level USE cp_para_types, ONLY: cp_para_env_type USE cp_subsys_types, ONLY: cp_subsys_get,& @@ -43,6 +45,8 @@ MODULE pint_methods gle_init,& gle_thermo_create USE global_types, ONLY: global_environment_type + USE helium_interactions, ONLY: helium_intpot_scan + USE helium_io, ONLY: helium_write_cubefile USE helium_methods, ONLY: helium_create,& helium_init,& helium_release @@ -62,7 +66,8 @@ MODULE pint_methods USE kinds, ONLY: default_path_length,& default_string_length,& dp - USE machine, ONLY: m_walltime + USE machine, ONLY: m_flush,& + m_walltime USE mathconstants, ONLY: twopi USE mathlib, ONLY: gcd USE parallel_rng_types, ONLY: GAUSSIAN,& @@ -339,6 +344,7 @@ CONTAINS pint_env%uv_new(pint_env%p,pint_env%ndim), & pint_env%uf(pint_env%p,pint_env%ndim), & pint_env%uf_h(pint_env%p,pint_env%ndim), & + pint_env%centroid(pint_env%ndim), & pint_env%rtmp_ndim(pint_env%ndim), & pint_env%rtmp_natom(pint_env%ndim/3), & STAT=stat) @@ -354,6 +360,7 @@ CONTAINS pint_env%uv_new = 0._dp pint_env%uf = 0._dp pint_env%uf_h = 0._dp + pint_env%centroid(:) = 0.0_dp pint_env%rtmp_ndim= 0._dp pint_env%rtmp_natom= 0._dp pint_env%time_per_step = 0.0_dp @@ -610,6 +617,7 @@ CONTAINS DEALLOCATE(pint_env%uv_new) DEALLOCATE(pint_env%uf) DEALLOCATE(pint_env%uf_h) + DEALLOCATE(pint_env%centroid) DEALLOCATE(pint_env%rtmp_ndim) DEALLOCATE(pint_env%rtmp_natom) DEALLOCATE(pint_env%propagator) @@ -731,13 +739,13 @@ CONTAINS CHARACTER(len=*), PARAMETER :: routineN = 'do_pint_run', & routineP = moduleN//':'//routineN - INTEGER, PARAMETER :: helium_only_mid = 1, & - solute_only_mid = 2, & - solute_with_helium_mid = 3 + INTEGER, PARAMETER :: helium_only_mid = 1, int_pot_scan_mid = 4, & + solute_only_mid = 2, solute_with_helium_mid = 3 + CHARACTER(len=default_string_length) :: stmp INTEGER :: handle, mode LOGICAL :: explicit, helium_only, & - solvent_present + int_pot_scan, solvent_present TYPE(helium_solvent_type), POINTER :: helium TYPE(pint_env_type), POINTER :: pint_env TYPE(section_vals_type), POINTER :: helium_section @@ -770,13 +778,31 @@ CONTAINS helium_only = .FALSE. END IF - ! pick the mode of operation + ! check wheather to perform solute-helium interaction pot scan + IF (solvent_present) THEN + CALL section_vals_val_get(helium_section,"INTERACTION_POT_SCAN",& + l_val=int_pot_scan) + ELSE + int_pot_scan = .FALSE. + END IF + + ! input consistency check + IF (helium_only .AND. int_pot_scan) THEN + stmp = "Options HELIUM_ONLY and INTERACTION_POT_SCAN are exclusive" + CPABORT(stmp) + END IF + + ! select mode of operation mode = 0 IF (solvent_present) THEN IF (helium_only) THEN mode = helium_only_mid ELSE - mode = solute_with_helium_mid + IF (int_pot_scan) THEN + mode = int_pot_scan_mid + ELSE + mode = solute_with_helium_mid + END IF END IF ELSE mode = solute_only_mid @@ -799,6 +825,17 @@ CONTAINS CALL pint_do_run(pint_env,globenv) CALL pint_release(pint_env) + CASE (int_pot_scan_mid) + CALL pint_create(pint_env,input,input_declaration,para_env) +! TODO only initialization of positions is necessary, but rep_env_calc_e_f called +! from within pint_init_f does something to the replica environments which can not be +! avoided (has something to do with f_env_add_defaults) so leaving for now.. + CALL pint_init(pint_env) + CALL helium_create(helium,input,solute=pint_env) + CALL pint_run_scan(pint_env, globenv, helium) + CALL helium_release(helium) + CALL pint_release(pint_env) + CASE (solute_with_helium_mid) CALL pint_create(pint_env,input,input_declaration,para_env) ! init pint wihtout helium forces (they are not yet initialized) @@ -1491,6 +1528,19 @@ CONTAINS CALL cp_iterate(pint_env%logger%iter_info,iter_nr=pint_env%first_step) pint_env%iter = pint_env%first_step + IF (PRESENT(helium)) THEN + IF (ASSOCIATED(helium)) THEN + ! set the properties accumulated over the whole MC process to 0 + helium%proarea%accu(:) = 0.0_dp + helium%prarea2%accu(:) = 0.0_dp + helium%wnmber2%accu(:) = 0.0_dp + helium%mominer%accu(:) = 0.0_dp + IF (helium%rho_present) THEN + helium%rho_accu(:,:,:,:) = 0.0_dp + END IF + END IF + END IF + ! write the properties at 0-th step CALL pint_calc_energy(pint_env) CALL pint_write_ener(pint_env) @@ -1539,6 +1589,73 @@ CONTAINS RETURN END SUBROUTINE pint_do_run + ! *************************************************************************** + !> \brief Performs a scan of the helium-solute interaction energy + !> \author Lukasz Walewski + !> \date 2013-11-26 + ! *************************************************************************** +! ***************************************************************************** +!> \brief ... +!> \param pint_env ... +!> \param globenv ... +!> \param helium ... +! ***************************************************************************** + SUBROUTINE pint_run_scan(pint_env, globenv, helium) + TYPE(pint_env_type), POINTER :: pint_env + TYPE(global_environment_type), POINTER :: globenv + TYPE(helium_solvent_type), POINTER :: helium + + CHARACTER(len=*), PARAMETER :: routineN = 'pint_run_scan', & + routineP = moduleN//':'//routineN + + CHARACTER(len=default_string_length) :: comment + INTEGER :: unit_nr + REAL(kind=dp), DIMENSION(:, :, :), & + POINTER :: DATA + TYPE(section_vals_type), POINTER :: print_key + + NULLIFY(pint_env%logger, print_key) + pint_env%logger => cp_get_default_logger() + print_key => section_vals_get_subs_vals(helium%input, & + "MOTION%PINT%HELIUM%PRINT%RHO") + + ! perform the actual scan wrt the COM of the solute + helium%rho_inst(1,:,:,:) = 0.0_dp + CALL helium_intpot_scan(pint_env, helium) + + ! output the interaction potential into a cubefile + IF (pint_env%logger%para_env%ionode) THEN + + unit_nr=cp_print_key_unit_nr( & + pint_env%logger, & + print_key, & + middle_name="helium-pot", & + extension=".cube", & + file_position="REWIND", & + do_backup=.FALSE.) + + comment = "Solute - helium interaction potential" + NULLIFY(DATA) + DATA => helium%rho_inst(1,:,:,:) + CALL helium_write_cubefile( & + unit_nr, & + comment, & + helium%center-0.5_dp*(helium%rho_maxr-helium%rho_delr), & + helium%rho_delr, & + helium%rho_nbin, & + DATA ) + + CALL m_flush(unit_nr) + CALL cp_print_key_finished_output(unit_nr,pint_env%logger,print_key) + + END IF + + ! output solute positions + CALL pint_write_centroids(pint_env) + CALL pint_write_trajectory(pint_env) + + RETURN + END SUBROUTINE pint_run_scan ! *************************************************************************** !> \brief Does an MD step (and nrespa harmonic evaluations) diff --git a/src/motion/pint_public.F b/src/motion/pint_public.F index d77e614887..724d73606a 100644 --- a/src/motion/pint_public.F +++ b/src/motion/pint_public.F @@ -27,6 +27,7 @@ MODULE pint_public PUBLIC :: pint_com_pos PUBLIC :: pint_levy_walk + PUBLIC :: pint_calc_centroid CONTAINS @@ -268,4 +269,35 @@ MODULE pint_public RETURN END SUBROUTINE pint_levy_walk + ! *************************************************************************** + !> \brief Calculate the centroid + !> \param pint_env path integral environment + !> \date 2013-02-10 + !> \author lwalewski + ! *************************************************************************** +! ***************************************************************************** +!> \brief ... +!> \param pint_env ... +! ***************************************************************************** + SUBROUTINE pint_calc_centroid(pint_env) + + TYPE(pint_env_type), POINTER :: pint_env + + CHARACTER(len=*), PARAMETER :: routineN = 'pint_calc_centroid', & + routineP = moduleN//':'//routineN + + INTEGER :: ia, ib + REAL(KIND=dp) :: invp + + invp = 1.0_dp / pint_env%p + pint_env%centroid(:) = 0.0_dp + DO ia = 1, pint_env%ndim + DO ib = 1, pint_env%p + pint_env%centroid(ia) = pint_env%centroid(ia) + pint_env%x(ib,ia) + END DO + pint_env%centroid(ia) = pint_env%centroid(ia) * invp + END DO + + END SUBROUTINE pint_calc_centroid + END MODULE pint_public diff --git a/src/motion/pint_types.F b/src/motion/pint_types.F index 72fd8d0de4..aec14cb8e6 100644 --- a/src/motion/pint_types.F +++ b/src/motion/pint_types.F @@ -122,7 +122,7 @@ MODULE pint_types REAL(KIND=dp), DIMENSION(:), POINTER :: mass,e_pot_bead REAL(KIND=dp), DIMENSION(:,:), POINTER :: x,v,f,mass_beads,& mass_fict,ux,ux_t,uv,uv_t,uv_new,uf,uf_h, external_f - + REAL(KIND=dp), DIMENSION(:), POINTER :: centroid REAL(KIND=dp), DIMENSION(:,:,:), POINTER :: tx,tv,tv_t,tv_old,tv_new,tf REAL(KIND=dp), DIMENSION(:), POINTER :: Q ! dim p, make it (p,ndim)? REAL(KIND=dp), DIMENSION(:), POINTER :: rtmp_ndim, rtmp_natom diff --git a/src/start/input_cp2k.F b/src/start/input_cp2k.F index b40949c822..a1560cd677 100644 --- a/src/start/input_cp2k.F +++ b/src/start/input_cp2k.F @@ -599,6 +599,11 @@ CONTAINS default_l_val=.FALSE.) CALL section_add_keyword(section,keyword) CALL keyword_release(keyword) + CALL keyword_create(keyword, name="RESTART_HELIUM_AVERAGES",& + description="Restarts average properties from PINT%HELIUM%AVERAGES.",& + type_of_var=logical_t,lone_keyword_l_val=.TRUE.,default_l_val=.FALSE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) END SUBROUTINE create_ext_restart_section diff --git a/src/start/input_cp2k_motion.F b/src/start/input_cp2k_motion.F index fe5bfedf49..60405349d6 100644 --- a/src/start/input_cp2k_motion.F +++ b/src/start/input_cp2k_motion.F @@ -27,9 +27,14 @@ MODULE input_cp2k_motion default_minimization_method_id, default_ts_method_id, do_mc_gemc_npt, & do_mc_gemc_nvt, do_mc_traditional, do_mc_virial, fmt_id_pdb, & fmt_id_xyz, gaussian, helium_cell_shape_cube, & - helium_cell_shape_octahedron, integrate_exact, integrate_numeric, & - ls_2pnt, ls_3pnt, ls_fit, ls_gold, ls_none, matrix_init_cholesky, & - matrix_init_diagonal, numerical, propagator_pimd, propagator_rpmd, & + helium_cell_shape_octahedron, helium_forces_average, & + helium_forces_last, helium_mdist_exponential, helium_mdist_gaussian, & + helium_mdist_linear, helium_mdist_quadratic, helium_mdist_singlev, & + helium_mdist_uniform, helium_sampling_ceperley, & + helium_solute_intpot_mwater, helium_solute_intpot_none, & + integrate_exact, integrate_numeric, ls_2pnt, ls_3pnt, ls_fit, ls_gold, & + ls_none, matrix_init_cholesky, matrix_init_diagonal, numerical, & + perm_cycle, perm_plain, propagator_pimd, propagator_rpmd, & transformation_normal, transformation_stage USE input_cp2k_constraints, ONLY: create_constraint_section USE input_cp2k_free_energy, ONLY: create_fe_section @@ -51,6 +56,7 @@ MODULE input_cp2k_motion section_release,& section_type USE input_val_types, ONLY: integer_t,& + logical_t,& real_t USE kinds, ONLY: dp USE string_utilities, ONLY: s2a @@ -1922,15 +1928,14 @@ CONTAINS routineP = moduleN//':'//routineN TYPE(keyword_type), POINTER :: keyword - TYPE(section_type), POINTER :: print_key, subsection, & - subsubsection + TYPE(section_type), POINTER :: print_key, subsection CPASSERT(.NOT.ASSOCIATED(section)) CALL section_create(section,name="HELIUM",& description="The section that controls optional helium solvent"// & " environment (highly experimental, not for general use yet)",& - n_keywords=11, n_subsections=4, repeats=.FALSE.) + n_keywords=28, n_subsections=9, repeats=.FALSE.) NULLIFY(keyword) CALL keyword_create(keyword, name="_SECTION_PARAMETERS_",& @@ -1947,6 +1952,14 @@ CONTAINS CALL section_add_keyword(section,keyword) CALL keyword_release(keyword) + CALL keyword_create(keyword, name="INTERACTION_POT_SCAN",& + description="Scan solute-helium interaction potential, "//& + "cubefile parameters set in subsection RHO",& + repeats=.FALSE., default_l_val=.FALSE.,& + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) + CALL keyword_create(keyword, name="NUM_ENV", & description="Number of independent helium environments"// & " (only for restarts, do not set explicitly)",& @@ -1960,6 +1973,29 @@ CONTAINS CALL section_add_keyword(section,keyword) CALL keyword_release(keyword) + CALL keyword_create(keyword, name="GET_FORCES",& + description="Get average MC forces or last MC forces to propagate MD",& + usage="GET_FORCES (AVERAGE|LAST)",& + default_i_val=helium_forces_average,& + enum_c_vals=s2a("AVERAGE","LAST"),& + enum_i_vals=(/helium_forces_average,helium_forces_last/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) + + CALL keyword_create(keyword, name="SOLUTE_INTERACTION", & + description="Interaction potential between helium and the solute",& + usage="SOLUTE_INTERACTION (NONE | MWATER)",& + default_i_val=helium_solute_intpot_none,& + enum_c_vals=s2a("NONE", "MWATER"),& + enum_i_vals=(/& + helium_solute_intpot_none, & + helium_solute_intpot_mwater/), & + enum_desc=s2a(& + "No interaction with solute", & + "Test interaction with wrong Water")) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) + CALL keyword_create(keyword, name="NATOMS", & description="Number of helium atoms",& repeats=.FALSE., default_i_val=64) @@ -1972,15 +2008,19 @@ CONTAINS CALL section_add_keyword(section,keyword) CALL keyword_release(keyword) - CALL keyword_create(keyword, name="INOROT", & - description="Number of MC iterations at the same time slice(s)",& - repeats=.FALSE., default_i_val=10000) + CALL keyword_create(keyword, name="N_INNER", & + variants=s2a("INOROT"),& + description="Number of MC iterations at the same time slice(s) "//& + "(number of inner MC loop iterations)",& + repeats=.FALSE., default_i_val=6600) CALL section_add_keyword(section,keyword) CALL keyword_release(keyword) - CALL keyword_create(keyword, name="IROT", & - description="how often to reselect the time slice(s) to work on",& - repeats=.FALSE., default_i_val=10000) + CALL keyword_create(keyword, name="N_OUTER", & + variants=s2a("IROT"),& + description="how often to reselect the time slice(s) to work on "//& + "(number of outer MC loop iterations)",& + repeats=.FALSE., default_i_val=300) CALL section_add_keyword(section,keyword) CALL keyword_release(keyword) @@ -1997,12 +2037,42 @@ CONTAINS CALL section_add_keyword(section,keyword) CALL keyword_release(keyword) + CALL keyword_create(keyword, name="SAMPLING_METHOD",& + description="Choose between Ceperley or other not implemented algorithms",& + usage="SAMPLING_METHOD (CEPERLEY)",& + default_i_val=helium_sampling_ceperley,& + enum_c_vals=s2a("CEPERLEY"),& + enum_i_vals=(/helium_sampling_ceperley/)) + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) + NULLIFY(subsection) CALL section_create(subsection,name="M-SAMPLING",& description="Permutation cycle length sampling settings",& - n_keywords=2, n_subsections=0, repeats=.FALSE.) + n_keywords=3, n_subsections=0, repeats=.FALSE.) + CALL keyword_create(keyword, name="DISTRIBUTION-TYPE", & + description="Distribution from which the cycle length m is sampled",& + usage="DISTRIBUTION-TYPE (SINGLEV|UNIFORM|LINEAR|QUADRATIC|EXPONENTIAL|GAUSSIAN)",& + default_i_val=helium_mdist_uniform,& + enum_c_vals=s2a(& + "SINGLEV",& + "UNIFORM",& + "LINEAR",& + "QUADRATIC",& + "EXPONENTIAL",& + "GAUSSIAN"),& + enum_i_vals=(/& + helium_mdist_singlev,& + helium_mdist_uniform,& + helium_mdist_linear,& + helium_mdist_quadratic,& + helium_mdist_exponential,& + helium_mdist_gaussian/)) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) CALL keyword_create(keyword, name="M-VALUE", & - description="Value of m treated in a special way",& + description="Value of m treated in a special way "//& + "(specific behavior depends on the distribution type chosen)",& repeats=.FALSE.,& default_i_val=1) CALL section_add_keyword(subsection,keyword) @@ -2039,6 +2109,14 @@ CONTAINS CALL section_add_keyword(section,keyword) CALL keyword_release(keyword) + CALL keyword_create(keyword, name="DROPLET_RADIUS", & + description="Reject a move if any of the new positions does not lie within"//& + " this range from the center of gravity",& + repeats=.FALSE.,type_of_var=real_t,default_r_val=HUGE(1.0_dp),& + unit_str="angstrom") + CALL section_add_keyword(section,keyword) + CALL keyword_release(keyword) + CALL keyword_create(keyword, name="DENSITY", & description="trial density of helium for determining the helium "//& "box size",& @@ -2062,27 +2140,42 @@ CONTAINS CALL keyword_release(keyword) CALL section_create(subsection,name="RDF",& - description="Radial distribution function generation settings",& - n_keywords=2, n_subsections=0, repeats=.FALSE.) + description="Radial distribution settings",& + n_keywords=4, n_subsections=0, repeats=.FALSE.) + + CALL keyword_create(keyword, name="_SECTION_PARAMETERS_",& + description="Whether or not to actually calculate this property",& + default_l_val=.FALSE.,lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL keyword_create(keyword, name="MAXR", & description="Maximum RDF range, defaults to unit cell size",& repeats=.FALSE.,type_of_var=real_t,& unit_str="angstrom") CALL section_add_keyword(subsection,keyword) CALL keyword_release(keyword) + CALL keyword_create(keyword, name="NBIN", & description="Number of bins",& repeats=.FALSE.,& - default_i_val=700) + default_i_val=250) CALL section_add_keyword(subsection,keyword) CALL keyword_release(keyword) + + CALL keyword_create(keyword, name="CENTERS_FILE_NAME",& + description="Calculate RDFs wrt centers read from a file",& + repeats=.FALSE., default_lc_val="centers.xyz") + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,subsection) CALL section_release(subsection) NULLIFY(subsection) CALL section_create(subsection,name="RHO",& - description="Density distribution settings",& - n_keywords=2, n_subsections=0, repeats=.FALSE.) + description="Spatial distribution settings",& + n_keywords=10, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword, name="_SECTION_PARAMETERS_",& description="Whether or not to actually calculate densities "//& "(requires significant amount of memory, depending on the value of NBIN)",& @@ -2090,33 +2183,80 @@ CONTAINS CALL section_add_keyword(subsection,keyword) CALL keyword_release(keyword) CALL keyword_create(keyword, name="NBIN", & - description="Number of bins",& + description="Number of grid points in each direction for density binning",& repeats=.FALSE.,& default_i_val=100) CALL section_add_keyword(subsection,keyword) CALL keyword_release(keyword) - CALL keyword_create(keyword, name="IWEIGHT", & - description="Weight the restarted density should be given " // & - "(number of MC steps used to average the restarted density, " // & - "negative value - the same weight as the run-time density, " // & - "usually should not be changed)",& - repeats=.FALSE.,& - default_i_val=-1) + ! + CALL keyword_create(keyword, name="MIN_CYCLE_LENGTHS_WDG",& + description="Density of winding paths "// & + "not shorter than the given length", & + repeats=.FALSE.,usage=" .. ",& + type_of_var=integer_t, n_var=-1) CALL section_add_keyword(subsection,keyword) CALL keyword_release(keyword) - - NULLIFY(subsubsection) - CALL section_create(subsubsection,name="CUBE_DATA",& - description="Density data used for restarts",& - n_keywords=1, n_subsections=0, repeats=.FALSE.) - CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_",& - description="Cubefile data", & - repeats=.TRUE., usage="{Real} ...",& - type_of_var=real_t, n_var=-1) - CALL section_add_keyword(subsubsection,keyword) + ! + CALL keyword_create(keyword, name="MIN_CYCLE_LENGTHS_NON",& + description="Density of non-winding paths "// & + "not shorter than the given length", & + repeats=.FALSE.,usage=" .. ",& + type_of_var=integer_t, n_var=-1) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + ! + CALL keyword_create(keyword, name="MIN_CYCLE_LENGTHS_ALL",& + description="Density of all paths "// & + "not shorter than the given length", & + repeats=.FALSE.,usage=" .. ",& + type_of_var=integer_t, n_var=-1) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + ! + CALL keyword_create(keyword, name="ATOM_NUMBER",& + description="Atom number density",& + repeats=.FALSE.,& + type_of_var=logical_t,& + default_l_val=.TRUE.,& + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + ! + CALL keyword_create(keyword, name="PROJECTED_AREA_2",& + description="Projected area squared density, A*A(r)",& + repeats=.FALSE.,& + type_of_var=logical_t,& + default_l_val=.FALSE.,& + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + ! + CALL keyword_create(keyword, name="WINDING_NUMBER_2",& + description="Winding number squared density, W*W(r)",& + repeats=.FALSE.,& + type_of_var=logical_t,& + default_l_val=.FALSE.,& + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + ! + CALL keyword_create(keyword, name="WINDING_CYCLE_2",& + description="Winding number squared density, W^2(r)",& + repeats=.FALSE.,& + type_of_var=logical_t,& + default_l_val=.FALSE.,& + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + ! + CALL keyword_create(keyword, name="MOMENT_OF_INERTIA",& + description="Moment of inertia density",& + repeats=.FALSE.,& + type_of_var=logical_t,& + default_l_val=.FALSE.,& + lone_keyword_l_val=.TRUE.) + CALL section_add_keyword(subsection,keyword) CALL keyword_release(keyword) - CALL section_add_subsection(subsection,subsubsection) - CALL section_release(subsubsection) CALL section_add_subsection(section,subsection) CALL section_release(subsection) @@ -2131,21 +2271,70 @@ CONTAINS n_keywords=1, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_",& description="Specify particle index permutation for every "// & - "helium atom",repeats=.TRUE.,usage="{Integer} ...",& + "helium atom",repeats=.TRUE.,usage=" .. ",& type_of_var=integer_t, n_var=-1) CALL section_add_keyword(subsection,keyword) CALL keyword_release(keyword) CALL section_add_subsection(section,subsection) CALL section_release(subsection) + CALL section_create(subsection,name="AVERAGES",& + description="Average properties (used for restarts)",& + n_keywords=7, n_subsections=0, repeats=.FALSE.) + CALL keyword_create(keyword, name="PROJECTED_AREA",& + description="Projected area vector for all environments", & + repeats=.TRUE.,usage=" .. ",& + type_of_var=real_t, n_var=-1) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL keyword_create(keyword, name="PROJECTED_AREA_2",& + description="Projected area vector squared for all environments", & + repeats=.TRUE.,usage=" .. ",& + type_of_var=real_t, n_var=-1) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL keyword_create(keyword, name="WINDING_NUMBER_2",& + description="Winding number vector squared for all environments", & + repeats=.TRUE.,usage=" .. ",& + type_of_var=real_t, n_var=-1) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL keyword_create(keyword, name="MOMENT_OF_INERTIA",& + description="Moment of inertia vector for all environments", & + repeats=.TRUE.,usage=" .. ",& + type_of_var=real_t, n_var=-1) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL keyword_create(keyword, name="RDF",& + description="Radial distributions averaged over all environments", & + repeats=.TRUE.,usage=" .. ",& + type_of_var=real_t, n_var=-1) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL keyword_create(keyword, name="RHO",& + description="Spatial distributions averaged over all environments", & + repeats=.TRUE.,usage=" .. ",& + type_of_var=real_t, n_var=-1) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL keyword_create(keyword, name="IWEIGHT", & + description="Weight for the restarted quantities " // & + "(number of MC steps used to calculate the accumulated averages)", & + repeats=.FALSE.,& + default_i_val=0) + CALL section_add_keyword(subsection,keyword) + CALL keyword_release(keyword) + CALL section_add_subsection(section,subsection) + CALL section_release(subsection) + CALL section_create(subsection,name="FORCE",& description="Forces exerted by the helium on the solute system"//& " (used for restarts)",& - n_keywords=0, n_subsections=0, repeats=.FALSE.) + n_keywords=1, n_subsections=0, repeats=.FALSE.) CALL keyword_create(keyword, name="_DEFAULT_KEYWORD_", & description="Number of real values should be 3 * "//& " * ", repeats=.TRUE., & - usage="{Real} ...", type_of_var=real_t, & + usage=" .. ", type_of_var=real_t, & n_var=-1) CALL section_add_keyword(subsection,keyword) CALL keyword_release(keyword) @@ -2167,7 +2356,7 @@ CONTAINS CALL section_create(subsection,name="PRINT",& description="The section that controls the output of the helium code",& - n_keywords=1, n_subsections=0, repeats=.FALSE.) + n_keywords=15, n_subsections=0, repeats=.FALSE.) ! ************************************************************************* !> Printkeys for properites output @@ -2180,38 +2369,35 @@ CONTAINS ! Properties printed at LOW print level ! CALL cp_print_key_section_create(print_key,"ENERGY",& - description="Controls the output of the helium energies"//& + description="Controls the output of helium energies"//& " (averaged over MC step)", & print_level=low_print_level,common_iter_levels=1) CALL section_add_subsection(subsection,print_key) CALL section_release(print_key) - - CALL cp_print_key_section_create(print_key,"SDENSITY",& - description="Controls the output of the helium superfluid density",& + ! + CALL cp_print_key_section_create(print_key,"PROJECTED_AREA_2_AVG",& + description="Controls the output of the average projected area squared vector",& + print_level=low_print_level,common_iter_levels=1) + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) + ! + CALL cp_print_key_section_create(print_key,"WINDING_NUMBER_2_AVG",& + description="Controls the output of the average winding number vector squared",& + print_level=low_print_level,common_iter_levels=1) + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) + ! + CALL cp_print_key_section_create(print_key,"MOMENT_OF_INERTIA_AVG",& + description="Controls the output of the average moment of inertia vector",& print_level=low_print_level,common_iter_levels=1) CALL section_add_subsection(subsection,print_key) CALL section_release(print_key) + ! Properties printed at MEDIUM print level ! - CALL cp_print_key_section_create(print_key,"COORDINATES",& - description="Controls the output of helium coordinates",& - print_level=medium_print_level,common_iter_levels=1) - CALL keyword_create(keyword, name="FORMAT",& - description="Output file format for the coordinates",& - usage="FORMAT (PDB|XYZ)",& - default_i_val=fmt_id_pdb,& - enum_c_vals=s2a("PDB","XYZ"),& - enum_i_vals= (/fmt_id_pdb,fmt_id_xyz/),& - enum_desc=s2a( "Bead coordinates and connectivity is written in PDB format",& - "Only bead coordinates are written in XYZ format")) - CALL section_add_keyword(print_key,keyword) - CALL keyword_release(keyword) - CALL section_add_subsection(subsection,print_key) - CALL section_release(print_key) - CALL cp_print_key_section_create(print_key,"RDF",& - description="Controls the output of the helium radial distribution function",& + description="Controls the output of helium radial distribution functions",& print_level=medium_print_level,common_iter_levels=1) CALL section_add_subsection(subsection,print_key) CALL section_release(print_key) @@ -2230,7 +2416,25 @@ CONTAINS CALL keyword_release(keyword) CALL section_add_subsection(subsection,print_key) CALL section_release(print_key) - + ! + CALL cp_print_key_section_create(print_key,"PROJECTED_AREA",& + description="Controls the output of the projected area vector",& + print_level=medium_print_level,common_iter_levels=1) + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) + ! + CALL cp_print_key_section_create(print_key,"WINDING_NUMBER",& + description="Controls the output of the winding number vector",& + print_level=medium_print_level,common_iter_levels=1) + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) + ! + CALL cp_print_key_section_create(print_key,"MOMENT_OF_INERTIA",& + description="Controls the output of the moment of inertia vector",& + print_level=medium_print_level,common_iter_levels=1) + CALL section_add_subsection(subsection,print_key) + CALL section_release(print_key) + ! CALL cp_print_key_section_create(print_key,"PLENGTH",& description="Controls the output of the helium permutation length",& print_level=medium_print_level,common_iter_levels=1) @@ -2239,15 +2443,37 @@ CONTAINS ! Properties printed at HIGH print level ! - CALL cp_print_key_section_create(print_key,"ACCEPTS",& - description="Controls the output of the helium acceptance data",& + CALL cp_print_key_section_create(print_key,"COORDINATES",& + description="Controls the output of helium coordinates",& print_level=high_print_level,common_iter_levels=1) + CALL keyword_create(keyword, name="FORMAT",& + description="Output file format for the coordinates",& + usage="FORMAT (PDB|XYZ)",& + default_i_val=fmt_id_pdb,& + enum_c_vals=s2a("PDB","XYZ"),& + enum_i_vals= (/fmt_id_pdb,fmt_id_xyz/),& + enum_desc=s2a( "Bead coordinates and connectivity is written in PDB format",& + "Only bead coordinates are written in XYZ format")) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL section_add_subsection(subsection,print_key) CALL section_release(print_key) - + ! CALL cp_print_key_section_create(print_key,"PERM",& description="Controls the output of the helium permutation state",& print_level=high_print_level,common_iter_levels=1) + CALL keyword_create(keyword, name="FORMAT",& + description="Output format for the permutation",& + usage="FORMAT (CYCLE|PLAIN)",& + default_i_val=perm_cycle,& + enum_c_vals=s2a("CYCLE","PLAIN"),& + enum_i_vals= (/perm_cycle,perm_plain/),& + enum_desc=s2a( & + "Cycle notation with winding cycles enclosed"//& + " in '[...]' and non-winding ones enclosed in '(...)'",& + "Plain permutation output, i.e. P(1) ... P(N)")) + CALL section_add_keyword(print_key,keyword) + CALL keyword_release(keyword) CALL section_add_subsection(subsection,print_key) CALL section_release(print_key) @@ -2259,14 +2485,14 @@ CONTAINS ! Properties printed at DEBUG print level ! - CALL cp_print_key_section_create(print_key,"FORCES_INST",& - description="Controls the output of the instantaneous helium forces on the solute",& + CALL cp_print_key_section_create(print_key,"ACCEPTS",& + description="Controls the output of the helium acceptance data",& print_level=debug_print_level,common_iter_levels=1) CALL section_add_subsection(subsection,print_key) CALL section_release(print_key) - - CALL cp_print_key_section_create(print_key,"WNUMBER",& - description="Controls the output of the helium winding number",& + ! + CALL cp_print_key_section_create(print_key,"FORCES_INST",& + description="Controls the output of the instantaneous helium forces on the solute",& print_level=debug_print_level,common_iter_levels=1) CALL section_add_subsection(subsection,print_key) CALL section_release(print_key) diff --git a/tests/Pimd/TEST_FILES b/tests/Pimd/TEST_FILES index 0f3579f81d..9f660c965c 100644 --- a/tests/Pimd/TEST_FILES +++ b/tests/Pimd/TEST_FILES @@ -12,6 +12,7 @@ he32_only.inp 40 he32_only_restart.inp 40 2e-14 water-in-helium.inp 9 7e-14 water-in-helium-restart.inp 9 7e-14 +water-in-helium-lastforce.inp 9 7e-14 w512_pint_nose.inp 9 8e-14 9.5780711530210407 w512_pint_gle.inp 9 3e-13 -3.5646497002020765 w512_pint_pile.inp 9 3e-12 0.70661010702892924 diff --git a/tests/Pimd/water-in-helium-lastforce.inp b/tests/Pimd/water-in-helium-lastforce.inp new file mode 100644 index 0000000000..0eefa2eec7 --- /dev/null +++ b/tests/Pimd/water-in-helium-lastforce.inp @@ -0,0 +1,67 @@ +&GLOBAL + PROJECT_NAME water-in-helium-lastforce + RUN_TYPE PINT + PRINT_LEVEL MEDIUM +&END GLOBAL + +&MOTION + &PINT + P 4 + PROC_PER_REPLICA 1 + NUM_STEPS 5 + DT 0.5 + NRESPA 2 + TEMP 7.5 + T_TOL 0.0 + TRANSFORMATION NORMAL + &NOSE + NNOS 3 + &END NOSE + &HELIUM + SOLUTE_INTERACTION MWATER + POTENTIAL_FILE_NAME lj-test-pot.dat + GET_FORCES LAST + NATOMS 32 + NBEADS 16 + INOROT 200 + IROT 100 + BISECTION 8 + MAX_PERM_CYCLE 4 + PERIODIC T + CELL_SHAPE OCTAHEDRON + &END HELIUM + &END PINT +&END MOTION + +&FORCE_EVAL + METHOD FIST + &MM + &POISSON + &EWALD + GMAX 25 + &END EWALD + &END POISSON + &FORCEFIELD + PARM_FILE_NAME ../Fist/sample_pot/water.pot + PARMTYPE CHM + &CHARGE + ATOM OT + CHARGE -0.8476 + &END CHARGE + &CHARGE + ATOM HT + CHARGE 0.4238 + &END CHARGE + &END FORCEFIELD + &END MM + &SUBSYS + &CELL + ABC 8.0 8.0 8.0 + PERIODIC NONE + &END CELL + &TOPOLOGY + COORD_FILE_NAME ../Fist/sample_pdb/water_1.pdb + COORD_FILE_FORMAT PDB + &END TOPOLOGY + &END SUBSYS +&END FORCE_EVAL diff --git a/tests/Pimd/water-in-helium-restart.inp b/tests/Pimd/water-in-helium-restart.inp index d474701628..937cac1f06 100644 --- a/tests/Pimd/water-in-helium-restart.inp +++ b/tests/Pimd/water-in-helium-restart.inp @@ -20,6 +20,7 @@ NNOS 3 &END NOSE &HELIUM + SOLUTE_INTERACTION MWATER POTENTIAL_FILE_NAME lj-test-pot.dat NATOMS 32 NBEADS 16 diff --git a/tests/Pimd/water-in-helium.inp b/tests/Pimd/water-in-helium.inp index 5101683104..e818359d21 100644 --- a/tests/Pimd/water-in-helium.inp +++ b/tests/Pimd/water-in-helium.inp @@ -18,6 +18,7 @@ NNOS 3 &END NOSE &HELIUM + SOLUTE_INTERACTION MWATER POTENTIAL_FILE_NAME lj-test-pot.dat NATOMS 32 NBEADS 16