ICODE-ADC/lammps
4
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'develop' into collected-small-changes

Browse Source
This commit is contained in:
Axel Kohlmeyer
2022-12-19 19:45:04 -05:00
parent 219b971caf 5deb6df2ad
commit 457746dadc
10 changed files with 2591 additions and 178 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
unittest/fortran/CMakeLists.txt
View File

@ -86,6 +86,10 @@ if(CMAKE_Fortran_COMPILER)
target_link_libraries(test_fortran_neighlist PRIVATE flammps lammps GTest::GMockMain)
add_test(NAME FortranNeighlist COMMAND test_fortran_neighlist)
add_executable(test_fortran_fixexternal wrap_fixexternal.cpp test_fortran_fixexternal.f90)
target_link_libraries(test_fortran_fixexternal PRIVATE flammps lammps GTest::GMockMain)
add_test(NAME FortranFixExternal COMMAND test_fortran_fixexternal)
else()
message(STATUS "Skipping Tests for the LAMMPS Fortran Module: no Fortran compiler")
endif()

424
unittest/fortran/test_fortran_fixexternal.f90 Normal file
View File

@ -0,0 +1,424 @@
MODULE ext_stuff
USE, INTRINSIC :: ISO_Fortran_ENV, ONLY : error_unit
USE, INTRINSIC :: ISO_C_BINDING, ONLY : c_double, c_int, c_int64_t, c_loc
USE LIBLAMMPS
IMPLICIT NONE
INTEGER, PARAMETER :: vec_length = 8
REAL(c_double), SAVE :: direction = 1.0_c_double
REAL(c_double), DIMENSION(:,:), POINTER, SAVE :: f3 => NULL(), f4 => NULL()
CONTAINS
SUBROUTINE f_lammps_reverse_direction() BIND(C)
direction = -direction
END SUBROUTINE f_lammps_reverse_direction
SUBROUTINE f_callback_ss(instance, timestep, id, x, f)
CLASS(*), INTENT(INOUT) :: instance
INTEGER(c_int) :: timestep
INTEGER(c_int), DIMENSION(:), INTENT(IN) :: id
REAL(c_double), DIMENSION(:,:), INTENT(IN) :: x
REAL(c_double), DIMENSION(:,:), INTENT(OUT) :: f
REAL(c_double), DIMENSION(SIZE(id)) :: e
REAL(c_double), DIMENSION(6,SIZE(id)) :: v
WHERE (id == 1)
f(1,:) = 1.0_c_double
f(2,:) = -1.0_c_double
f(3,:) = 1.25_c_double
e = 1.0_c_double
v(1,:) = 1.0_c_double
v(2,:) = 2.0_c_double
v(3,:) = -1.0_c_double
v(4,:) = -2.0_c_double
v(5,:) = 3.0_c_double
v(6,:) = -3.0_c_double
ELSEWHERE
f(1,:) = -1.0_c_double
f(2,:) = +1.0_c_double
f(3,:) = -1.25_c_double
e = 10.0_c_double
v(1,:) = 10.0_c_double
v(2,:) = 20.0_c_double
v(3,:) = -10.0_c_double
v(4,:) = -20.0_c_double
v(5,:) = 30.0_c_double
v(6,:) = -30.0_c_double
END WHERE
SELECT TYPE (instance)
CLASS IS (lammps)
CALL instance%fix_external_set_energy_peratom('ext1', e)
CALL instance%fix_external_set_virial_peratom('ext1', v)
CLASS DEFAULT
WRITE(error_unit,*) 'UMM...this should never happen.'
STOP 1
END SELECT
END SUBROUTINE f_callback_ss
SUBROUTINE f_callback_sb(instance, timestep, id, x, f)
CLASS(*), INTENT(INOUT) :: instance
INTEGER(c_int64_t) :: timestep
INTEGER(c_int), DIMENSION(:), INTENT(IN) :: id
REAL(c_double), DIMENSION(:,:), INTENT(IN) :: x
REAL(c_double), DIMENSION(:,:), INTENT(OUT) :: f
REAL(c_double), DIMENSION(SIZE(id)) :: e
REAL(c_double), DIMENSION(6,SIZE(id)) :: v
WHERE (id == 1_c_int)
f(1,:) = 1.0_c_double
f(2,:) = -1.0_c_double
f(3,:) = 1.25_c_double
e = 1.0_c_double
v(1,:) = 1.0_c_double
v(2,:) = 2.0_c_double
v(3,:) = -1.0_c_double
v(4,:) = -2.0_c_double
v(5,:) = 3.0_c_double
v(6,:) = -3.0_c_double
ELSEWHERE
f(1,:) = -1.0_c_double
f(2,:) = +1.0_c_double
f(3,:) = -1.25_c_double
e = 10.0_c_double
v(1,:) = 10.0_c_double
v(2,:) = 20.0_c_double
v(3,:) = -10.0_c_double
v(4,:) = -20.0_c_double
v(5,:) = 30.0_c_double
v(6,:) = -30.0_c_double
END WHERE
SELECT TYPE (instance)
CLASS IS (lammps)
CALL instance%fix_external_set_energy_peratom('ext1', e)
CALL instance%fix_external_set_virial_peratom('ext1', v)
CLASS DEFAULT
WRITE(error_unit,*) 'UMM...this should never happen.'
STOP 1
END SELECT
END SUBROUTINE f_callback_sb
SUBROUTINE f_callback_bb(instance, timestep, id, x, f)
CLASS(*), INTENT(INOUT) :: instance
INTEGER(c_int64_t) :: timestep
INTEGER(c_int64_t), DIMENSION(:), INTENT(IN) :: id
REAL(c_double), DIMENSION(:,:), INTENT(IN) :: x
REAL(c_double), DIMENSION(:,:), INTENT(OUT) :: f
REAL(c_double), DIMENSION(SIZE(id)) :: e
REAL(c_double), DIMENSION(6,SIZE(id)) :: v
WHERE (id == 1_c_int64_t)
f(1,:) = 1.0_c_double
f(2,:) = -1.0_c_double
f(3,:) = 1.25_c_double
e = 1.0_c_double
v(1,:) = 1.0_c_double
v(2,:) = 2.0_c_double
v(3,:) = -1.0_c_double
v(4,:) = -2.0_c_double
v(5,:) = 3.0_c_double
v(6,:) = -3.0_c_double
ELSEWHERE
f(1,:) = -1.0_c_double
f(2,:) = +1.0_c_double
f(3,:) = -1.25_c_double
e = 10.0_c_double
v(1,:) = 10.0_c_double
v(2,:) = 20.0_c_double
v(3,:) = -10.0_c_double
v(4,:) = -20.0_c_double
v(5,:) = 30.0_c_double
v(6,:) = -30.0_c_double
END WHERE
SELECT TYPE (instance)
CLASS IS (lammps)
CALL instance%fix_external_set_energy_peratom('ext1', e)
CALL instance%fix_external_set_virial_peratom('ext1', v)
CLASS DEFAULT
WRITE(error_unit,*) 'UMM...this should never happen.'
STOP 1
END SELECT
END SUBROUTINE f_callback_bb
SUBROUTINE f_callback2_ss(entity, timestep, id, x, f)
CLASS(*), INTENT(INOUT), target :: entity
INTEGER(c_int) :: timestep
INTEGER(c_int), DIMENSION(:), INTENT(IN) :: id
REAL(c_double), DIMENSION(:,:), INTENT(IN) :: x
REAL(c_double), DIMENSION(:,:), INTENT(OUT) :: f
SELECT TYPE (entity)
TYPE IS (REAL(c_double))
WHERE (id == 1_c_int)
f(1,:) = SIGN(1.0_c_double, entity) * 2.0_c_double
f(2,:) = SIGN(1.0_c_double, entity) * (-2.0_c_double)
f(3,:) = SIGN(1.0_c_double, entity) * 2.5_c_double
ELSEWHERE
f(1,:) = SIGN(1.0_c_double, entity) * (-2.0_c_double)
f(2,:) = SIGN(1.0_c_double, entity) * 2.0_c_double
f(3,:) = SIGN(1.0_c_double, entity) * (-2.5_c_double)
END WHERE
CLASS DEFAULT
WRITE(error_unit,'(A)') 'ERROR: Failed to resolve "entity" in&
& f_callback2_ss'
STOP 1
END SELECT
END SUBROUTINE f_callback2_ss
SUBROUTINE f_callback2_sb(entity, timestep, id, x, f)
CLASS(*), INTENT(INOUT), target :: entity
INTEGER(c_int64_t) :: timestep
INTEGER(c_int), DIMENSION(:), INTENT(IN) :: id
REAL(c_double), DIMENSION(:,:), INTENT(IN) :: x
REAL(c_double), DIMENSION(:,:), INTENT(OUT) :: f
SELECT TYPE (entity)
TYPE IS (REAL(c_double))
WHERE (id == 1_c_int)
f(1,:) = SIGN(1.0_c_double, entity) * 2.0_c_double
f(2,:) = SIGN(1.0_c_double, entity) * (-2.0_c_double)
f(3,:) = SIGN(1.0_c_double, entity) * 2.5_c_double
ELSEWHERE
f(1,:) = SIGN(1.0_c_double, entity) * (-2.0_c_double)
f(2,:) = SIGN(1.0_c_double, entity) * 2.0_c_double
f(3,:) = SIGN(1.0_c_double, entity) * (-2.5_c_double)
END WHERE
CLASS DEFAULT
WRITE(error_unit,'(A)') 'ERROR: Failed to resolve "entity" in&
& f_callback2_sb'
STOP 1
END SELECT
END SUBROUTINE f_callback2_sb
SUBROUTINE f_callback2_bb(entity, timestep, id, x, f)
CLASS(*), INTENT(INOUT), target :: entity
INTEGER(c_int64_t) :: timestep
INTEGER(c_int64_t), DIMENSION(:), INTENT(IN) :: id
REAL(c_double), DIMENSION(:,:), INTENT(IN) :: x
REAL(c_double), DIMENSION(:,:), INTENT(OUT) :: f
SELECT TYPE (entity)
TYPE IS (REAL(c_double))
WHERE (id == 1_c_int64_t)
f(1,:) = SIGN(1.0_c_double, entity) * 2.0_c_double
f(2,:) = SIGN(1.0_c_double, entity) * (-2.0_c_double)
f(3,:) = SIGN(1.0_c_double, entity) * 2.5_c_double
ELSEWHERE
f(1,:) = SIGN(1.0_c_double, entity) * (-2.0_c_double)
f(2,:) = SIGN(1.0_c_double, entity) * 2.0_c_double
f(3,:) = SIGN(1.0_c_double, entity) * (-2.5_c_double)
END WHERE
CLASS DEFAULT
WRITE(error_unit,'(A)') 'ERROR: Failed to resolve "entity" in&
& f_callback2_sb'
STOP 1
END SELECT
END SUBROUTINE f_callback2_bb
END MODULE ext_stuff
FUNCTION f_lammps_with_args() BIND(C)
USE, INTRINSIC :: ISO_C_BINDING, ONLY: c_ptr
USE liblammps
USE keepstuff, ONLY: lmp
IMPLICIT NONE
TYPE(c_ptr) :: f_lammps_with_args
CHARACTER(len=12), DIMENSION(12), PARAMETER :: args = &
[ CHARACTER(len=12) :: 'liblammps', '-log', 'none', &
'-echo','screen','-nocite','-var','zpos','1.5','-var','x','2']
lmp = lammps(args)
f_lammps_with_args = lmp%handle
END FUNCTION f_lammps_with_args
SUBROUTINE f_lammps_close() BIND(C)
USE, INTRINSIC :: ISO_C_BINDING, ONLY: c_null_ptr
USE liblammps
USE keepstuff, ONLY: lmp
IMPLICIT NONE
CALL lmp%close()
lmp%handle = c_null_ptr
END SUBROUTINE f_lammps_close
SUBROUTINE f_lammps_setup_fix_external_callback() BIND(C)
USE LIBLAMMPS
USE keepstuff, ONLY : lmp, demo_input, cont_input, pair_input
USE ext_stuff, ONLY : vec_length
IMPLICIT NONE
CALL lmp%commands_list(demo_input)
CALL lmp%commands_list(cont_input)
CALL lmp%commands_list(pair_input)
CALL lmp%command('neigh_modify exclude group all all')
CALL lmp%command('fix ext1 all external pf/callback 1 1')
CALL lmp%command('fix ext2 all external pf/callback 1 1')
CALL lmp%fix_external_set_vector_length('ext2', vec_length)
END SUBROUTINE f_lammps_setup_fix_external_callback
SUBROUTINE f_lammps_setup_fix_external_array() BIND(C)
USE LIBLAMMPS
USE keepstuff, ONLY : lmp, demo_input, cont_input, pair_input
USE ext_stuff, ONLY : f3, f4
IMPLICIT NONE
CALL lmp%commands_list(demo_input)
CALL lmp%commands_list(cont_input)
CALL lmp%commands_list(pair_input)
CALL lmp%command('neigh_modify exclude group all all')
CALL lmp%command('fix ext3 all external pf/array 1')
CALL lmp%command('fix ext4 all external pf/array 1')
CALL lmp%command('thermo_style custom step pxx pe etotal')
CALL lmp%command('thermo_modify norm no')
CALL lmp%command('thermo 100')
f3 = lmp%fix_external_get_force('ext3')
f4 = lmp%fix_external_get_force('ext4')
END SUBROUTINE f_lammps_setup_fix_external_array
SUBROUTINE f_lammps_set_fix_external_callbacks() BIND(C)
USE, INTRINSIC :: ISO_C_BINDING, ONLY : c_int
USE LIBLAMMPS
USE keepstuff, ONLY : lmp
USE ext_stuff
IMPLICIT NONE
INTEGER :: size_bigint, size_tagint, nlocal
nlocal = lmp%extract_setting('nlocal')
size_bigint = lmp%extract_setting('bigint')
size_tagint = lmp%extract_setting('tagint')
IF (size_bigint == 4_c_int .AND. size_tagint == 4_c_int) THEN
CALL lmp%set_fix_external_callback('ext1', f_callback_ss, lmp)
CALL lmp%set_fix_external_callback('ext2', f_callback2_ss, direction)
ELSE IF (size_bigint == 8_c_int .AND. size_tagint == 8_c_int) THEN
CALL lmp%set_fix_external_callback('ext1', f_callback_bb, lmp)
CALL lmp%set_fix_external_callback('ext2', f_callback2_bb, direction)
ELSE
CALL lmp%set_fix_external_callback('ext1', f_callback_sb, lmp)
CALL lmp%set_fix_external_callback('ext2', f_callback2_sb, direction)
END IF
END SUBROUTINE f_lammps_set_fix_external_callbacks
SUBROUTINE f_lammps_get_force (i, ptr) BIND(C)
USE, INTRINSIC :: ISO_C_BINDING, ONLY : c_int, c_double, c_ptr, C_F_POINTER
USE LIBLAMMPS
USE keepstuff, ONLY : lmp
IMPLICIT NONE
INTEGER(c_int), INTENT(IN), VALUE :: i
TYPE(c_ptr), INTENT(IN), VALUE :: ptr
REAL(c_double), DIMENSION(:,:), POINTER :: force => NULL()
REAL(c_double), DIMENSION(:), POINTER :: f => NULL()
CALL C_F_POINTER(ptr, f, [3])
force = lmp%extract_atom('f')
f = force(:,i)
END SUBROUTINE f_lammps_get_force
SUBROUTINE f_lammps_find_forces() BIND(C)
USE, INTRINSIC :: ISO_C_BINDING, ONLY : c_double, c_int, c_int64_t
USE LIBLAMMPS
USE keepstuff, ONLY : lmp
USE ext_stuff, ONLY : f3, f4
IMPLICIT NONE
INTEGER(c_int) :: size_tagint
INTEGER(c_int), DIMENSION(:), POINTER :: id
INTEGER(c_int64_t), DIMENSION(:), POINTER :: tag
f3(:,:) = 0.0_c_double
f4(:,:) = 0.0_c_double
size_tagint = lmp%extract_setting('tagint')
IF (size_tagint == 4_c_int) THEN
id = lmp%extract_atom('id')
WHERE (id == 1_c_int)
f3(1,:) = 4.0_c_double
f3(2,:) = -4.0_c_double
f3(3,:) = 6.0_c_double
f4(1,:) = 10.0_c_double
f4(2,:) = -10.0_c_double
f4(3,:) = 12.0_c_double
ELSEWHERE
f3(1,:) = 5.0_c_double
f3(2,:) = -5.0_c_double
f3(3,:) = 7.0_c_double
f4(1,:) = 11.0_c_double
f4(2,:) = -11.0_c_double
f4(3,:) = 13.0_c_double
END WHERE
ELSE
tag = lmp%extract_atom('id')
WHERE (tag == 1_c_int64_t)
f3(1,:) = 4.0_c_double
f3(2,:) = -4.0_c_double
f3(3,:) = 6.0_c_double
f4(1,:) = 10.0_c_double
f4(2,:) = -10.0_c_double
f4(3,:) = 12.0_c_double
ELSEWHERE
f3(1,:) = 5.0_c_double
f3(2,:) = -5.0_c_double
f3(3,:) = 7.0_c_double
f4(1,:) = 11.0_c_double
f4(2,:) = -11.0_c_double
f4(3,:) = 13.0_c_double
END WHERE
END IF
END SUBROUTINE f_lammps_find_forces
SUBROUTINE f_lammps_add_energy() BIND(C)
USE, INTRINSIC :: ISO_C_BINDING, ONLY : c_double
USE LIBLAMMPS
USE keepstuff, ONLY : lmp
IMPLICIT NONE
CALL lmp%fix_external_set_energy_global('ext3', -20.2_c_double);
END SUBROUTINE f_lammps_add_energy
SUBROUTINE f_lammps_set_virial() BIND(C)
USE, INTRINSIC :: ISO_C_BINDING, ONLY : c_double
USE LIBLAMMPS
USE keepstuff, ONLY : lmp
IMPLICIT NONE
CALL lmp%fix_external_set_virial_global('ext4', [1.0_c_double, &
2.0_c_double, 2.5_c_double, -1.0_c_double, -2.25_c_double, -3.02_c_double])
END SUBROUTINE f_lammps_set_virial
FUNCTION f_lammps_find_peratom_energy(i) RESULT(energy) BIND(C)
USE, INTRINSIC :: ISO_C_BINDING, ONLY : c_int, c_double
USE LIBLAMMPS
USE keepstuff, ONLY : lmp
IMPLICIT NONE
INTEGER(c_int), INTENT(IN), VALUE :: i
REAL(c_double) :: energy
REAL(c_double), DIMENSION(:), POINTER :: e
e = lmp%extract_compute('peratom', lmp%style%atom, lmp%type%vector)
energy = e(i)
END FUNCTION f_lammps_Find_peratom_energy
SUBROUTINE f_lammps_find_peratom_virial(v, i) BIND(C)
USE, INTRINSIC :: ISO_C_BINDING, ONLY : c_int, c_double
USE LIBLAMMPS
USE keepstuff, ONLY : lmp
IMPLICIT NONE
REAL(c_double), DIMENSION(6) :: v
INTEGER(c_int), INTENT(IN), VALUE :: i
REAL(c_double), DIMENSION(:,:), POINTER :: virial
virial = lmp%extract_compute('vperatom', lmp%style%atom, lmp%type%array)
v = virial(:,i)
END SUBROUTINE f_lammps_find_peratom_virial
SUBROUTINE f_lammps_fixexternal_set_vector() BIND(C)
USE, INTRINSIC :: ISO_C_BINDING, ONLY : c_double
USE LIBLAMMPS
USE keepstuff, ONLY : lmp
USE ext_stuff, ONLY : vec_length
IMPLICIT NONE
REAL(c_double), DIMENSION(vec_length) :: v
INTEGER :: i
DO i = 1, vec_length
v(i) = REAL(i, c_double)
CALL lmp%fix_external_set_vector('ext2', i, v(i))
END DO
END SUBROUTINE f_lammps_fixexternal_set_vector

92
unittest/fortran/test_fortran_gather_scatter.f90
View File

@ -24,13 +24,16 @@ END SUBROUTINE f_lammps_close
SUBROUTINE f_lammps_setup_gather_scatter() BIND(C)
USE LIBLAMMPS
USE keepstuff, ONLY : lmp, big_input, cont_input, more_input
USE keepstuff, ONLY : lmp, big_input, cont_input, more_input, pair_input
IMPLICIT NONE
CALL lmp%command('atom_modify map array')
CALL lmp%commands_list(big_input)
CALL lmp%commands_list(cont_input)
CALL lmp%commands_list(more_input)
CALL lmp%commands_list(pair_input)
CALL lmp%command('mass 1 1.0')
CALL lmp%command("compute pe all pe/atom")
END SUBROUTINE f_lammps_setup_gather_scatter
FUNCTION f_lammps_gather_atoms_mask(i) BIND(C)
@ -262,3 +265,90 @@ FUNCTION f_lammps_test_gather_bonds_big() BIND(C) RESULT(success)
success = 0_c_int
END IF
END FUNCTION f_lammps_test_gather_bonds_big
FUNCTION f_lammps_gather_pe_atom(i) BIND(C)
USE, INTRINSIC :: ISO_C_BINDING, ONLY : c_int, c_double
USE LIBLAMMPS
USE keepstuff, ONLY : lmp
IMPLICIT NONE
INTEGER(c_int), INTENT(IN), VALUE :: i
REAL(c_double) :: f_lammps_gather_pe_atom
REAL(c_double), DIMENSION(:), ALLOCATABLE :: pe_atom
CALL lmp%gather('c_pe', 1_c_int, pe_atom)
f_lammps_gather_pe_atom = pe_atom(i)
END FUNCTION f_lammps_gather_pe_atom
FUNCTION f_lammps_gather_pe_atom_concat(i) BIND(C)
USE, INTRINSIC :: ISO_C_BINDING, ONLY : c_int, c_double
USE LIBLAMMPS
USE keepstuff, ONLY : lmp
IMPLICIT NONE
INTEGER(c_int), INTENT(IN), VALUE :: i
REAL(c_double) :: f_lammps_gather_pe_atom_concat
REAL(c_double), DIMENSION(:), ALLOCATABLE :: pe_atom
INTEGER(c_int), DIMENSION(:), ALLOCATABLE :: tag
INTEGER :: j
CALL lmp%gather_concat('id', 1_c_int, tag)
CALL lmp%gather_concat('c_pe', 1_c_int, pe_atom)
DO j = 1, SIZE(tag)
IF (tag(j) == i) THEN
f_lammps_gather_pe_atom_concat = pe_atom(j)
EXIT
END IF
END DO
f_lammps_gather_pe_atom_concat = pe_atom(i)
END FUNCTION f_lammps_gather_pe_atom_concat
SUBROUTINE f_lammps_gather_pe_atom_subset(ids, pe) BIND(C)
USE, INTRINSIC :: ISO_C_BINDING, ONLY : c_int, c_double
USE LIBLAMMPS
USE keepstuff, ONLY : lmp
IMPLICIT NONE
INTEGER(c_int), INTENT(IN) :: ids(2)
REAL(c_double), INTENT(OUT) :: pe(2)
REAL(c_double), DIMENSION(:), ALLOCATABLE :: pe_atom
INTEGER(c_int) :: natoms
natoms = NINT(lmp%get_natoms(), c_int)
CALL lmp%gather_subset('c_pe', 1, ids, pe_atom)
pe(1:natoms) = pe_atom
END SUBROUTINE f_lammps_gather_pe_atom_subset
SUBROUTINE f_lammps_scatter_compute() BIND(C)
USE, INTRINSIC :: ISO_C_BINDING, ONLY : c_int, c_double
USE LIBLAMMPS
USE keepstuff, ONLY : lmp
IMPLICIT NONE
REAL(c_double), DIMENSION(:), ALLOCATABLE :: pe_atom
REAL(c_double) :: swap
CALL lmp%gather('c_pe', 1_c_int, pe_atom)
! swap the computed energy of atoms 1 and 3
swap = pe_atom(1)
pe_atom(1) = pe_atom(3)
pe_atom(3) = swap
CALL lmp%scatter('c_pe', pe_atom) ! push the swap back to LAMMPS
END SUBROUTINE f_lammps_scatter_compute
SUBROUTINE f_lammps_scatter_subset_compute() BIND(C)
USE, INTRINSIC :: ISO_C_BINDING, ONLY : c_int, c_double
USE LIBLAMMPS
USE keepstuff, ONLY : lmp
IMPLICIT NONE
INTEGER(c_int), PARAMETER :: ids(2) = [3,1]
REAL(c_double), DIMENSION(:), ALLOCATABLE :: pe_atom
REAL(c_double) :: swap
CALL lmp%gather_subset('c_pe', 1_c_int, ids, pe_atom)
! swap the computed energy of atoms 1 and 3
swap = pe_atom(1)
pe_atom(1) = pe_atom(2)
pe_atom(2) = swap
CALL lmp%scatter_subset('c_pe', ids, pe_atom) ! push the swap back to LAMMPS
END SUBROUTINE f_lammps_scatter_subset_compute

194
unittest/fortran/wrap_fixexternal.cpp Normal file
View File

@ -0,0 +1,194 @@
// unit tests for gathering and scattering data from a LAMMPS instance through
// the Fortran wrapper
#include "lammps.h"
#include "library.h"
#include <cstdint>
#include <cstdlib>
#include <mpi.h>
#include <string>
#include "gtest/gtest.h"
// prototypes for Fortran reverse wrapper functions
extern "C" {
void *f_lammps_with_args();
void f_lammps_close();
void f_lammps_setup_fix_external_callback();
void f_lammps_setup_fix_external_array();
void f_lammps_set_fix_external_callbacks();
void f_lammps_get_force(int, double*);
void f_lammps_reverse_direction();
void f_lammps_find_forces();
void f_lammps_add_energy();
void f_lammps_set_virial();
double f_lammps_find_peratom_energy(int);
void f_lammps_find_peratom_virial(double[6], int);
void f_lammps_fixexternal_set_vector();
}
using namespace LAMMPS_NS;
class LAMMPS_fixexternal : public ::testing::Test {
protected:
LAMMPS_NS::LAMMPS *lmp;
LAMMPS_fixexternal() = default;
~LAMMPS_fixexternal() override = default;
void SetUp() override
{
::testing::internal::CaptureStdout();
lmp = (LAMMPS_NS::LAMMPS *)f_lammps_with_args();
std::string output = ::testing::internal::GetCapturedStdout();
EXPECT_STREQ(output.substr(0, 8).c_str(), "LAMMPS (");
}
void TearDown() override
{
::testing::internal::CaptureStdout();
f_lammps_close();
std::string output = ::testing::internal::GetCapturedStdout();
EXPECT_STREQ(output.substr(0, 16).c_str(), "Total wall time:");
lmp = nullptr;
}
};
TEST_F(LAMMPS_fixexternal, callback)
{
f_lammps_setup_fix_external_callback();
f_lammps_set_fix_external_callbacks();
lammps_command(lmp, "run 0");
double f[3];
f_lammps_get_force(1,f);
EXPECT_DOUBLE_EQ(f[0], 3.0);
EXPECT_DOUBLE_EQ(f[1], -3.0);
EXPECT_DOUBLE_EQ(f[2], 3.75);
f_lammps_get_force(2,f);
EXPECT_DOUBLE_EQ(f[0], -3.0);
EXPECT_DOUBLE_EQ(f[1], 3.0);
EXPECT_DOUBLE_EQ(f[2], -3.75);
f_lammps_reverse_direction();
f_lammps_set_fix_external_callbacks();
lammps_command(lmp, "run 0");
f_lammps_get_force(1,f);
EXPECT_DOUBLE_EQ(f[0], -1.0);
EXPECT_DOUBLE_EQ(f[1], 1.0);
EXPECT_DOUBLE_EQ(f[2], -1.25);
f_lammps_get_force(2,f);
EXPECT_DOUBLE_EQ(f[0], 1.0);
EXPECT_DOUBLE_EQ(f[1], -1.0);
EXPECT_DOUBLE_EQ(f[2], 1.25);
};
TEST_F(LAMMPS_fixexternal, array)
{
f_lammps_setup_fix_external_array();
double **f;
f = (double**) lammps_extract_atom(lmp, "f");
f_lammps_find_forces();
lammps_command(lmp, "run 0");
EXPECT_DOUBLE_EQ(f[0][0], 14.0);
EXPECT_DOUBLE_EQ(f[0][1], -14.0);
EXPECT_DOUBLE_EQ(f[0][2], 18.0);
EXPECT_DOUBLE_EQ(f[1][0], 16.0);
EXPECT_DOUBLE_EQ(f[1][1], -16.0);
EXPECT_DOUBLE_EQ(f[1][2], 20.0);
};
TEST_F(LAMMPS_fixexternal, energy_global)
{
f_lammps_setup_fix_external_array();
double energy;
f_lammps_add_energy();
lammps_command(lmp, "run 0");
energy = lammps_get_thermo(lmp, "etotal");
EXPECT_DOUBLE_EQ(energy, -20.2);
};
TEST_F(LAMMPS_fixexternal, virial_global)
{
f_lammps_setup_fix_external_array();
double virial[6], volume;
f_lammps_set_virial();
lammps_command(lmp, "run 0");
volume = lammps_get_thermo(lmp, "vol");
virial[0] = lammps_get_thermo(lmp, "pxx");
virial[1] = lammps_get_thermo(lmp, "pyy");
virial[2] = lammps_get_thermo(lmp, "pzz");
virial[3] = lammps_get_thermo(lmp, "pxy");
virial[4] = lammps_get_thermo(lmp, "pxz");
virial[5] = lammps_get_thermo(lmp, "pyz");
EXPECT_DOUBLE_EQ(virial[0], 1.0/volume);
EXPECT_DOUBLE_EQ(virial[1], 2.0/volume);
EXPECT_DOUBLE_EQ(virial[2], 2.5/volume);
EXPECT_DOUBLE_EQ(virial[3], -1.0/volume);
EXPECT_DOUBLE_EQ(virial[4], -2.25/volume);
EXPECT_DOUBLE_EQ(virial[5], -3.02/volume);
};
TEST_F(LAMMPS_fixexternal, energy_peratom)
{
f_lammps_setup_fix_external_callback();
f_lammps_set_fix_external_callbacks();
lammps_command(lmp, "compute peratom all pe/atom");
double energy;
lammps_command(lmp, "run 0");
int nlocal = lammps_extract_setting(lmp, "nlocal");
for (int i = 1; i <= nlocal; i++)
{
energy = f_lammps_find_peratom_energy(i);
if (i == 1)
EXPECT_DOUBLE_EQ(energy, 1.0);
else
EXPECT_DOUBLE_EQ(energy, 10.0);
}
};
TEST_F(LAMMPS_fixexternal, virial_peratom)
{
f_lammps_setup_fix_external_callback();
f_lammps_set_fix_external_callbacks();
lammps_command(lmp, "compute vperatom all stress/atom NULL");
double virial[6];
lammps_command(lmp, "run 0");
int nlocal = lammps_extract_setting(lmp, "nlocal");
for (int i = 1; i <= nlocal; i++)
{
f_lammps_find_peratom_virial(virial, i);
if (i == 1)
{
EXPECT_DOUBLE_EQ(virial[0], -1.0);
EXPECT_DOUBLE_EQ(virial[1], -2.0);
EXPECT_DOUBLE_EQ(virial[2], 1.0);
EXPECT_DOUBLE_EQ(virial[3], 2.0);
EXPECT_DOUBLE_EQ(virial[4], -3.0);
EXPECT_DOUBLE_EQ(virial[5], 3.0);
}
else
{
EXPECT_DOUBLE_EQ(virial[0], -10.0);
EXPECT_DOUBLE_EQ(virial[1], -20.0);
EXPECT_DOUBLE_EQ(virial[2], 10.0);
EXPECT_DOUBLE_EQ(virial[3], 20.0);
EXPECT_DOUBLE_EQ(virial[4], -30.0);
EXPECT_DOUBLE_EQ(virial[5], 30.0);
}
}
};
TEST_F(LAMMPS_fixexternal, vector)
{
f_lammps_setup_fix_external_callback();
f_lammps_set_fix_external_callbacks();
f_lammps_fixexternal_set_vector();
lammps_command(lmp, "run 0");
double *v;
for (int i = 0; i < 8; i++)
{
v = (double*) lammps_extract_fix(lmp, "ext2", LMP_STYLE_GLOBAL,
LMP_TYPE_VECTOR, i, 1);
EXPECT_DOUBLE_EQ(i+1, *v);
std::free(v);
}
};

116
unittest/fortran/wrap_gather_scatter.cpp
View File

@ -3,6 +3,7 @@
#include "lammps.h"
#include "library.h"
#include "atom.h"
#include <cstdint>
#include <cstdlib>
#include <mpi.h>
@ -26,6 +27,11 @@ void f_lammps_scatter_atoms_positions();
void f_lammps_setup_gather_bonds();
int f_lammps_test_gather_bonds_small();
int f_lammps_test_gather_bonds_big();
double f_lammps_gather_pe_atom(int);
double f_lammps_gather_pe_atom_concat(int);
void f_lammps_gather_pe_atom_subset(int*, double*);
void f_lammps_scatter_compute();
void f_lammps_scatter_subset_compute();
}
using namespace LAMMPS_NS;
@ -216,3 +222,113 @@ TEST_F(LAMMPS_gather_scatter, gather_bonds)
EXPECT_EQ(f_lammps_test_gather_bonds_small(), 1);
#endif
};
TEST_F(LAMMPS_gather_scatter, gather_compute)
{
#ifdef LAMMPS_BIGBIG
GTEST_SKIP();
#else
f_lammps_setup_gather_scatter();
lammps_command(lmp, "run 0");
int natoms = lmp->atom->natoms;
int *tag = lmp->atom->tag;
double *pe = (double*) lammps_extract_compute(lmp, "pe", LMP_STYLE_ATOM,
LMP_TYPE_VECTOR);
for (int i = 0; i < natoms; i++)
EXPECT_DOUBLE_EQ(f_lammps_gather_pe_atom(tag[i]), pe[i]);
#endif
};
TEST_F(LAMMPS_gather_scatter, gather_compute_concat)
{
#ifdef LAMMPS_BIGBIG
GTEST_SKIP();
#else
f_lammps_setup_gather_scatter();
lammps_command(lmp, "run 0");
int natoms = lmp->atom->natoms;
int *tag = lmp->atom->tag;
double *pe = (double*) lammps_extract_compute(lmp, "pe", LMP_STYLE_ATOM,
LMP_TYPE_VECTOR);
for (int i = 0; i < natoms; i++)
EXPECT_DOUBLE_EQ(f_lammps_gather_pe_atom(tag[i]), pe[i]);
#endif
};
TEST_F(LAMMPS_gather_scatter, gather_compute_subset)
{
#ifdef LAMMPS_BIGBIG
GTEST_SKIP();
#else
f_lammps_setup_gather_scatter();
lammps_command(lmp, "run 0");
int ids[2] = {3, 1};
int *tag = lmp->atom->tag;
double pe[2] = {0.0, 0.0};
int nlocal = lammps_extract_setting(lmp, "nlocal");
double *pa_pe = (double*) lammps_extract_compute(lmp, "pe", LMP_STYLE_ATOM,
LMP_TYPE_VECTOR);
for (int i = 0; i < nlocal; i++) {
if(tag[i] == ids[0]) pe[0] = pa_pe[i];
if(tag[i] == ids[1]) pe[1] = pa_pe[i];
}
double ftn_pe[2];
f_lammps_gather_pe_atom_subset(ids, ftn_pe);
EXPECT_DOUBLE_EQ(ftn_pe[0], pe[0]);
EXPECT_DOUBLE_EQ(ftn_pe[1], pe[1]);
#endif
};
TEST_F(LAMMPS_gather_scatter, scatter_compute)
{
#ifdef LAMMPS_BIGBIG
GTEST_SKIP();
#else
f_lammps_setup_gather_scatter();
int natoms = lmp->atom->natoms;
double *pe = new double[natoms];
lammps_command(lmp, "run 0");
lammps_gather(lmp, "c_pe", 1, 1, pe);
double *old_pe = new double[natoms];
for (int i = 0; i < natoms; i++)
old_pe[i] = pe[i];
EXPECT_DOUBLE_EQ(pe[0], old_pe[0]);
EXPECT_DOUBLE_EQ(pe[1], old_pe[1]);
EXPECT_DOUBLE_EQ(pe[2], old_pe[2]);
f_lammps_scatter_compute();
lammps_gather(lmp, "c_pe", 1, 1, pe);
EXPECT_DOUBLE_EQ(pe[0], old_pe[2]);
EXPECT_DOUBLE_EQ(pe[1], old_pe[1]);
EXPECT_DOUBLE_EQ(pe[2], old_pe[0]);
delete[] old_pe;
delete[] pe;
#endif
};
TEST_F(LAMMPS_gather_scatter, scatter_subset_compute)
{
#ifdef LAMMPS_BIGBIG
GTEST_SKIP();
#else
f_lammps_setup_gather_scatter();
int natoms = lmp->atom->natoms;
double *pe = new double[natoms];
lammps_command(lmp, "run 0");
lammps_gather(lmp, "c_pe", 1, 1, pe);
double *old_pe = new double[natoms];
for (int i = 0; i < natoms; i++)
old_pe[i] = pe[i];
EXPECT_DOUBLE_EQ(pe[0], old_pe[0]);
EXPECT_DOUBLE_EQ(pe[1], old_pe[1]);
EXPECT_DOUBLE_EQ(pe[2], old_pe[2]);
f_lammps_scatter_subset_compute();
lammps_gather(lmp, "c_pe", 1, 1, pe);
EXPECT_DOUBLE_EQ(pe[0], old_pe[2]);
EXPECT_DOUBLE_EQ(pe[1], old_pe[1]);
EXPECT_DOUBLE_EQ(pe[2], old_pe[0]);
delete[] old_pe;
delete[] pe;
#endif
};