From 5f9956405a1b86112be8db24402f9e9bfdabd147 Mon Sep 17 00:00:00 2001 From: Karl Hammond Date: Tue, 29 Nov 2022 15:37:15 -0600 Subject: [PATCH] Updated docs and wrote unit tests for lmp_set_fix_external_callback; fixed typos --- doc/src/Fortran.rst | 46 +++- fortran/lammps.f90 | 46 ++-- unittest/fortran/CMakeLists.txt | 4 + unittest/fortran/test_fortran_fixexternal.f90 | 220 ++++++++++++++++++ unittest/fortran/wrap_fixexternal.cpp | 75 ++++++ 5 files changed, 363 insertions(+), 28 deletions(-) create mode 100644 unittest/fortran/test_fortran_fixexternal.f90 create mode 100644 unittest/fortran/wrap_fixexternal.cpp diff --git a/doc/src/Fortran.rst b/doc/src/Fortran.rst index 12d39e8af7..813a52a44b 100644 --- a/doc/src/Fortran.rst +++ b/doc/src/Fortran.rst @@ -409,7 +409,7 @@ of the contents of the :f:mod:`LIBLAMMPS` Fortran interface to LAMMPS. USE LIBLAMMPS USE MPI_F08 TYPE(lammps) :: lmp - lmp = lammps(MPI_COMM_SELF%MPI_VAL) + lmp = lammps(comm=MPI_COMM_SELF%MPI_VAL) END PROGRAM testmpi .. f:type:: lammps_style @@ -773,8 +773,8 @@ Procedures Bound to the :f:type:`lammps` Derived Type Note that this function actually does not return a pointer, but rather associates the pointer on the left side of the assignment to point to internal LAMMPS data. Pointers must be of the correct type, kind, and - rank (e.g., ``INTEGER(c_int), DIMENSION(:)`` for "type", "mask", or "tag"; - ``INTEGER(c_int64_t), DIMENSION(:)`` for "tag" if LAMMPS was compiled + rank (e.g., ``INTEGER(c_int), DIMENSION(:)`` for "type", "mask", or "id"; + ``INTEGER(c_int64_t), DIMENSION(:)`` for "id" if LAMMPS was compiled with the ``-DLAMMPS_BIGBIG`` flag; ``REAL(c_double), DIMENSION(:,:)`` for "x", "v", or "f"; and so forth). The pointer being associated with LAMMPS data is type-, kind-, and rank-checked at run-time. @@ -2118,7 +2118,7 @@ Procedures Bound to the :f:type:`lammps` Derived Type ABSTRACT INTERFACE SUBROUTINE external_callback(caller, timestep, ids, x, fexternal) USE, INTRINSIC :: ISO_C_BINDING, ONLY : c_int, c_double, c_int64_t - CLASS(*), INTENT(IN) :: caller + CLASS(*), INTENT(INOUT) :: caller INTEGER(c_bigint), INTENT(IN) :: timestep INTEGER(c_tagint), DIMENSION(:), INTENT(IN) :: ids REAL(c_double), DIMENSION(:,:), INTENT(IN) :: x @@ -2135,6 +2135,8 @@ Procedures Bound to the :f:type:`lammps` Derived Type calling function) and will be available as the first argument to the callback function. It can be your LAMMPS instance, which you might need if the callback function needs access to the library interface. + The argument must be a scalar; to pass non-scalar data, wrap those data in + a derived type and pass an instance of the derived type to *caller*. The array *ids* is an array of length *nlocal* (as accessed from the :cpp:class:`Atom` class or through :f:func:`extract_global`). The arrays @@ -2155,7 +2157,41 @@ Procedures Bound to the :f:type:`lammps` Derived Type :p callback: subroutine :doc:`fix external ` should call :ptype callback: external :p class(*) caller [optional]: object you wish to pass to the callback - procedure + procedure (must be a scalar; see note) + + .. note:: + + The interface for your callback function must match types precisely + with the abstract interface block given above. **The compiler probably + will not be able to check this for you.** In particular, the first + argument ("caller") must be of type ``CLASS(*)`` or you will probably + get a segmentation fault or at least a misinterpretation of whatever is + in memory there. You can resolve the object using the ``SELECT TYPE`` + construct. An example callback function (assuming LAMMPS was compiled + with ``-DLAMMPS_SMALLBIG``) that applies something akin to Hooke's Law + (with each atom having a different *k* value) is shown below. + + .. code-block:: Fortran + + TYPE shield + REAL(c_double), DIMENSION(:), ALLOCATABLE :: k + ! assume k gets allocated to dimension(3,nlocal) at some point + END TYPE shield + + SUBROUTINE my_callback(caller, timestep, ids, x, fexternal) + CLASS(*), INTENT(INOUT) :: caller + INTEGER(c_int), INTENT(IN) :: timestep + INTEGER(c_int64_t), INTENT(IN) :: ids + REAL(c_double), INTENT(IN) :: x(:,:) + REAL(c_double), INTENT(OUT) :: fexternal(:,:) + + SELECT TYPE (caller) + TYPE IS (shield) + fexternal = - caller%k * x + CLASS DEFAULT + WRITE(error_unit,*) 'UH OH...' + END SELECT + END SUBROUTINE my_callback -------- diff --git a/fortran/lammps.f90 b/fortran/lammps.f90 index eb32dcd266..b6e4d5f56b 100644 --- a/fortran/lammps.f90 +++ b/fortran/lammps.f90 @@ -55,7 +55,7 @@ MODULE LIBLAMMPS LAMMPS_DOUBLE_2D = 3, & ! two-dimensional 64-bit double array LAMMPS_INT64 = 4, & ! 64-bit integer (or array) LAMMPS_INT64_2D = 5, & ! two-dimensional 64-bit integer array - LAMMPS_STRING = 6, & ! C-String + LAMMPS_STRING = 6, & ! string LMP_STYLE_GLOBAL = 0, & ! request global compute/fix/etc. data LMP_STYLE_ATOM = 1, & ! request per-atom compute/fix/etc. data LMP_STYLE_LOCAL = 2, & ! request local compute/fix/etc. data @@ -64,7 +64,7 @@ MODULE LIBLAMMPS LMP_TYPE_ARRAY = 2, & ! request array LMP_SIZE_VECTOR = 3, & ! request size of vector LMP_SIZE_ROWS = 4, & ! request rows (actually columns) - LMP_SIZE_COLS = 5, & ! request colums (actually rows) + LMP_SIZE_COLS = 5, & ! request columns (actually rows) LMP_ERROR_WARNING = 0, & ! call Error::warning() LMP_ERROR_ONE = 1, & ! call Error::one() (from this MPI rank) LMP_ERROR_ALL = 2, & ! call Error::all() (from all MPI ranks) @@ -268,7 +268,7 @@ MODULE LIBLAMMPS ABSTRACT INTERFACE SUBROUTINE external_callback_smallsmall(caller, timestep, ids, x, fexternal) IMPORT :: c_int, c_double - CLASS(*), INTENT(IN) :: caller + CLASS(*), INTENT(INOUT) :: caller INTEGER(c_int), INTENT(IN) :: timestep INTEGER(c_int), DIMENSION(:), INTENT(IN) :: ids REAL(c_double), DIMENSION(:,:), INTENT(IN) :: x @@ -276,7 +276,7 @@ MODULE LIBLAMMPS END SUBROUTINE external_callback_smallsmall SUBROUTINE external_callback_smallbig(caller, timestep, ids, x, fexternal) IMPORT :: c_int, c_double, c_int64_t - CLASS(*), INTENT(IN) :: caller + CLASS(*), INTENT(INOUT) :: caller INTEGER(c_int64_t), INTENT(IN) :: timestep INTEGER(c_int), DIMENSION(:), INTENT(IN) :: ids REAL(c_double), DIMENSION(:,:), INTENT(IN) :: x @@ -284,7 +284,7 @@ MODULE LIBLAMMPS END SUBROUTINE external_callback_smallbig SUBROUTINE external_callback_bigbig(caller, timestep, ids, x, fexternal) IMPORT :: c_double, c_int64_t - CLASS(*), INTENT(IN) :: caller + CLASS(*), INTENT(INOUT) :: caller INTEGER(c_int64_t), INTENT(IN) :: timestep INTEGER(c_int64_t), DIMENSION(:), INTENT(IN) :: ids REAL(c_double), DIMENSION(:,:), INTENT(IN) :: x @@ -836,28 +836,28 @@ CONTAINS INTEGER(c_int) :: i, c_comm, argc IF (PRESENT(args)) THEN - ! convert fortran argument list to c style - argc = SIZE(args) - ALLOCATE(argv(argc)) - DO i=1, argc - argv(i) = f2c_string(args(i)) - END DO + ! convert fortran argument list to c style + argc = SIZE(args) + ALLOCATE(argv(argc)) + DO i=1, argc + argv(i) = f2c_string(args(i)) + END DO ELSE - argc = 1 - ALLOCATE(argv(1)) - argv(1) = f2c_string("liblammps") + argc = 1 + ALLOCATE(argv(1)) + argv(1) = f2c_string("liblammps") ENDIF IF (PRESENT(comm)) THEN - c_comm = comm - lmp_open%handle = lammps_open(argc, argv, c_comm) + c_comm = comm + lmp_open%handle = lammps_open(argc, argv, c_comm) ELSE - lmp_open%handle = lammps_open_no_mpi(argc, argv, c_null_ptr) + lmp_open%handle = lammps_open_no_mpi(argc, argv, c_null_ptr) END IF ! Clean up allocated memory DO i=1, argc - CALL lammps_free(argv(i)) + CALL lammps_free(argv(i)) END DO DEALLOCATE(argv) @@ -883,10 +883,10 @@ CONTAINS CALL lammps_close(self%handle) IF (PRESENT(finalize)) THEN - IF (finalize) THEN - CALL lammps_kokkos_finalize() - CALL lammps_mpi_finalize() - END IF + IF (finalize) THEN + CALL lammps_kokkos_finalize() + CALL lammps_mpi_finalize() + END IF END IF END SUBROUTINE lmp_close @@ -1054,7 +1054,7 @@ CONTAINS length = 3 CASE DEFAULT length = 1 - ! string cases doesn't use "length" + ! string cases do not use "length" END SELECT Cname = f2c_string(name) diff --git a/unittest/fortran/CMakeLists.txt b/unittest/fortran/CMakeLists.txt index f66b333db1..d12b274765 100644 --- a/unittest/fortran/CMakeLists.txt +++ b/unittest/fortran/CMakeLists.txt @@ -104,6 +104,10 @@ if(CMAKE_Fortran_COMPILER) target_link_libraries(test_fortran_neighlist PRIVATE flammps lammps MPI::MPI_Fortran 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 MPI::MPI_Fortran GTest::GMockMain) + add_test(NAME FortranFixExternal COMMAND test_fortran_fixexternal) + else() message(STATUS "Skipping Tests for the LAMMPS Fortran Module: no Fortran compiler") endif() diff --git a/unittest/fortran/test_fortran_fixexternal.f90 b/unittest/fortran/test_fortran_fixexternal.f90 new file mode 100644 index 0000000000..1da8909627 --- /dev/null +++ b/unittest/fortran/test_fortran_fixexternal.f90 @@ -0,0 +1,220 @@ +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 + + REAL(c_double), SAVE :: direction = 1.0_c_double + +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 + + WHERE (id == 1) + f(1,:) = 1.0_c_double + f(2,:) = -1.0_c_double + f(3,:) = 1.25_c_double + ELSEWHERE + f(1,:) = -1.0_c_double + f(2,:) = +1.0_c_double + f(3,:) = -1.25_c_double + END WHERE + 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 + + WHERE (id == 1_c_int) + f(1,:) = 1.0_c_double + f(2,:) = -1.0_c_double + f(3,:) = 1.25_c_double + ELSEWHERE + f(1,:) = -1.0_c_double + f(2,:) = +1.0_c_double + f(3,:) = -1.25_c_double + END WHERE + 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 + + WHERE (id == 1_c_int64_t) + f(1,:) = 1.0_c_double + f(2,:) = -1.0_c_double + f(3,:) = 1.25_c_double + ELSEWHERE + f(1,:) = -1.0_c_double + f(2,:) = +1.0_c_double + f(3,:) = -1.25_c_double + END WHERE + 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 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() BIND(C) + USE LIBLAMMPS + USE keepstuff, ONLY : lmp, demo_input, cont_input, pair_input + 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') +END SUBROUTINE f_lammps_setup_fix_external + +SUBROUTINE f_lammps_set_fix_external_callbacks() BIND(C) + USE 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) + 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) + CALL lmp%set_fix_external_callback('ext2', f_callback2_bb, direction) + ELSE + CALL lmp%set_fix_external_callback('ext1', f_callback_sb) + 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 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 diff --git a/unittest/fortran/wrap_fixexternal.cpp b/unittest/fortran/wrap_fixexternal.cpp new file mode 100644 index 0000000000..282b95a299 --- /dev/null +++ b/unittest/fortran/wrap_fixexternal.cpp @@ -0,0 +1,75 @@ + +// unit tests for gathering and scattering data from a LAMMPS instance through +// the Fortran wrapper + +#include "lammps.h" +#include "library.h" +#include +#include +#include +#include + +#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(); +void f_lammps_set_fix_external_callbacks(); +void f_lammps_get_force(int, double*); +void f_lammps_reverse_direction(); +} + +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(); + 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); +};