diff --git a/fortran/lammps.f90 b/fortran/lammps.f90 index 7ab6255f90..9f49a1fcb5 100644 --- a/fortran/lammps.f90 +++ b/fortran/lammps.f90 @@ -65,7 +65,10 @@ MODULE LIBLAMMPS LMP_ERROR_ONE = 1, & ! call Error::one() (from this MPI rank) LMP_ERROR_ALL = 2, & ! call Error::all() (from all MPI ranks) LMP_ERROR_WORLD = 4, & ! error on comm->world - LMP_ERROR_UNIVERSE = 8 ! error on comm->universe + LMP_ERROR_UNIVERSE = 8, & ! error on comm->universe + LMP_VAR_EQUAL = 0, & ! equal-style variables (and compatible) + LMP_VAR_ATOM = 1, & ! atom-style variables (and compatible) + LMP_VAR_STRING = 2 ! string variables (and compatible) ! "Constants" to use with extract_compute and friends TYPE lammps_style @@ -97,11 +100,14 @@ MODULE LIBLAMMPS PROCEDURE :: extract_global => lmp_extract_global PROCEDURE :: extract_atom => lmp_extract_atom PROCEDURE :: extract_compute => lmp_extract_compute -! + PROCEDURE :: extract_fix => lmp_extract_fix + PROCEDURE :: extract_variable => lmp_extract_variable +! PROCEDURE :: version => lmp_version - PROCEDURE :: is_running => lmp_is_running ! PROCEDURE :: flush_buffers => lmp_flush_buffers + PROCEDURE :: is_running => lmp_is_running +! force_timeout PROCEDURE :: has_error => lmp_has_error PROCEDURE :: get_last_error_message => lmp_get_last_error_message END TYPE lammps @@ -118,10 +124,16 @@ MODULE LIBLAMMPS ENUMERATOR :: DATA_STRING END ENUM + ! Base class for receiving LAMMPS data (to reduce code duplication) + TYPE lammps_data_baseclass + INTEGER(c_int) :: datatype = -1_c_int + ! in case we need to call the Error class in an assignment + CLASS(lammps), POINTER, PRIVATE :: lammps_instance => NULL() + END TYPE lammps_data_baseclass + ! Derived type for receiving LAMMPS data (in lieu of the ability to type cast - ! pointers) - TYPE lammps_data - INTEGER(c_int) :: datatype + ! pointers). Used for extract_compute, extract_atom + TYPE, EXTENDS(lammps_data_baseclass) :: lammps_data INTEGER(c_int), POINTER :: i32 => NULL() INTEGER(c_int), DIMENSION(:), POINTER :: i32_vec => NULL() INTEGER(c_int64_t), POINTER :: i64 => NULL() @@ -132,6 +144,26 @@ MODULE LIBLAMMPS CHARACTER(LEN=:), ALLOCATABLE :: str END TYPE lammps_data + ! Derived type for holding LAMMPS fix data + ! Done this way because fix global data are not pointers, but computed + ! on-the-fly, whereas per-atom and local data are pointers to the actual + ! array. Doing it this way saves the user from having to explicitly + ! deallocate all of the pointers. + TYPE, EXTENDS(lammps_data_baseclass) :: lammps_fix_data + REAL(c_double) :: r64 + REAL(c_double), DIMENSION(:), POINTER :: r64_vec => NULL() + REAL(c_double), DIMENSION(:,:), POINTER :: r64_mat => NULL() + END TYPE lammps_fix_data + + ! Derived type for holding LAMMPS variable data + ! Done this way because extract_variable calculates variable values, it does + ! not return pointers to LAMMPS data. + TYPE, EXTENDS(lammps_data_baseclass) :: lammps_variable_data + REAL(c_double) :: r64 + REAL(c_double), DIMENSION(:), ALLOCATABLE :: r64_vec + CHARACTER(LEN=:), ALLOCATABLE :: str + END TYPE lammps_variable_data + ! This overloads the assignment operator (=) so that assignments of the ! form ! nlocal = extract_global('nlocal') @@ -144,6 +176,10 @@ MODULE LIBLAMMPS assign_double_to_lammps_data, assign_doublevec_to_lammps_data, & assign_doublemat_to_lammps_data, & assign_string_to_lammps_data + ! We handle fix data (slightly) differently + MODULE PROCEDURE assign_double_to_lammps_fix_data, & + assign_doublevec_to_lammps_fix_data, & + assign_doublemat_to_lammps_fix_data END INTERFACE ! interface definitions for calling functions in library.cpp @@ -312,9 +348,27 @@ MODULE LIBLAMMPS TYPE(c_ptr) :: lammps_extract_compute END FUNCTION lammps_extract_compute - !(generic) lammps_extract_fix + FUNCTION lammps_extract_fix(handle, id, style, type, nrow, ncol) BIND(C) + IMPORT :: c_ptr, c_int + IMPLICIT NONE + TYPE(c_ptr), INTENT(IN), VALUE :: handle, id + INTEGER(c_int), INTENT(IN), VALUE :: style, type, nrow, ncol + TYPE(c_ptr) :: lammps_extract_fix + END FUNCTION lammps_extract_fix - !(generic) lammps_extract_variable + FUNCTION lammps_extract_variable_datatype(handle,name) BIND(C) + IMPORT :: c_ptr, c_int + IMPLICIT NONE + TYPE(c_ptr), INTENT(IN), VALUE :: handle, name + INTEGER(c_int) :: lammps_extract_variable_datatype + END FUNCTION lammps_extract_variable_datatype + + FUNCTION lammps_extract_variable(handle, name, group) BIND(C) + IMPORT :: c_ptr, c_int + IMPLICIT NONE + TYPE(c_ptr), INTENT(IN), VALUE :: handle, name, group + TYPE(c_ptr) :: lammps_extract_variable + END FUNCTION lammps_extract_variable !INTEGER (c_int) lammps_set_variable @@ -647,7 +701,7 @@ CONTAINS ! the assignment is actually overloaded so as to bind the pointers to ! lammps data based on the information available from LAMMPS FUNCTION lmp_extract_global(self, name) RESULT (global_data) - CLASS(lammps), INTENT(IN) :: self + CLASS(lammps), INTENT(IN), TARGET :: self CHARACTER(LEN=*), INTENT(IN) :: name TYPE(lammps_data) :: global_data @@ -674,6 +728,7 @@ CONTAINS Cptr = lammps_extract_global(self%handle, Cname) CALL lammps_free(Cname) + global_data%lammps_instance => self SELECT CASE (datatype) CASE (LAMMPS_INT) IF ( length == 1 ) THEN @@ -704,7 +759,7 @@ CONTAINS length = c_strlen(Cptr) CALL C_F_POINTER(Cptr, Fptr, [length]) ALLOCATE ( CHARACTER(LEN=length) :: global_data%str ) - FORALL ( I=1:length ) + FORALL ( i=1:length ) global_data%str(i:i) = Fptr(i) END FORALL CASE DEFAULT @@ -717,7 +772,7 @@ CONTAINS ! the assignment is actually overloaded so as to bind the pointers to ! lammps data based on the information available from LAMMPS FUNCTION lmp_extract_atom (self, name) RESULT (peratom_data) - CLASS(lammps), INTENT(IN) :: self + CLASS(lammps), INTENT(IN), TARGET :: self CHARACTER(LEN=*), INTENT(IN) :: name TYPE(lammps_data) :: peratom_data @@ -748,6 +803,7 @@ CONTAINS nrows = 1 END SELECT + peratom_data%lammps_instance => self SELECT CASE (datatype) CASE (LAMMPS_INT) peratom_data%datatype = DATA_INT_1D @@ -772,16 +828,10 @@ CONTAINS CASE (-1) CALL lmp_error(self, LMP_ERROR_ALL + LMP_ERROR_WORLD, & 'per-atom property ' // name // 'not found in extract_setting') -! WRITE(ERROR_UNIT,'(A)') 'ERROR: per-atom property "' // name // & -! '" not found.' -! STOP 2 CASE DEFAULT WRITE(error_msg,'(A,I0,A)') 'return value ', datatype, & ' from lammps_extract_atom_datatype not known [Fortran/extract_atom]' CALL lmp_error(self, LMP_ERROR_ALL + LMP_ERROR_WORLD, error_msg) -! WRITE(ERROR_UNIT,'(A,I0,A)') 'ERROR: return value ', datatype, & -! ' from lammps_extract_atom_datatype not known' -! STOP 1 END SELECT END FUNCTION lmp_extract_atom @@ -789,12 +839,11 @@ CONTAINS ! the assignment operator is overloaded so as to bind the pointers to ! lammps data based on the information available from LAMMPS FUNCTION lmp_extract_compute (self, id, style, type) RESULT (compute_data) - CLASS(lammps), INTENT(IN) :: self + CLASS(lammps), INTENT(IN), TARGET :: self CHARACTER(LEN=*), INTENT(IN) :: id INTEGER(c_int), INTENT(IN) :: style, type TYPE(lammps_data) :: compute_data - INTEGER(c_int) :: datatype TYPE(c_ptr) :: Cid, Cptr, Ctemp INTEGER :: nrows, ncols, length INTEGER(c_int), POINTER :: temp @@ -809,6 +858,7 @@ CONTAINS END IF ! Remember that rows and columns in C are transposed in Fortran! + compute_data%lammps_instance => self SELECT CASE (type) CASE (LMP_TYPE_SCALAR) compute_data%datatype = DATA_DOUBLE @@ -847,14 +897,161 @@ CONTAINS CALL C_F_POINTER(Ccomputeptr(1), compute_data%r64_mat, [nrows, ncols]) CASE DEFAULT CALL lmp_error(self, LMP_ERROR_ALL + LMP_ERROR_WORLD, & - 'unknown type value passed to extract_compute') - !WRITE(ERROR_UNIT,'(A,I0,A)') 'ERROR: unknown type value ', type, & - ! 'passed to extract_compute' - !STOP 1 + 'unknown type value passed to extract_compute [Fortran API]') END SELECT CALL lammps_free(Cid) END FUNCTION lmp_extract_compute + FUNCTION lmp_extract_fix(self, id, style, type, nrow, ncol) RESULT (fix_data) + CLASS(lammps), INTENT(IN), TARGET :: self + CHARACTER(LEN=*), INTENT(IN) :: id + INTEGER(c_int), INTENT(IN) :: style, type + INTEGER(c_int), INTENT(IN), OPTIONAL :: nrow, ncol + TYPE(lammps_fix_data) :: fix_data + + TYPE(c_ptr) :: Cid, Cptr, Ctemp + TYPE(c_ptr), DIMENSION(:), POINTER :: Cfixptr + INTEGER(c_int) :: Cnrow, Cncol + REAL(c_double), POINTER :: Fptr + INTEGER :: nrows, ncols + INTEGER(c_int), POINTER :: temp + + ! We transpose ncol and nrow so the array appears to be transposed for + ! global data, as it would be if we could access the C++ array directly + Cnrow = -1 + Cncol = -1 + IF ( PRESENT(nrow) ) THEN + IF ( .NOT. PRESENT(ncol) ) THEN + ! Presumably the argument that's there is the vector length + Cnrow = nrow - 1_c_int + Cncol = -1_c_int + ELSE + ! Otherwise, the array is transposed, so...reverse the indices + Cncol = nrow - 1_c_int + END IF + END IF + + IF ( PRESENT(ncol) ) Cnrow = ncol - 1_c_int + + Cid = f2c_string(id) + Cptr = lammps_extract_fix(self%handle, Cid, style, type, Cnrow, Cncol) + IF ( .NOT. C_ASSOCIATED(Cptr) ) THEN + CALL lmp_error(self, LMP_ERROR_ALL + LMP_ERROR_WORLD, & + 'Pointer from LAMMPS is NULL for fix id "' // id & + // '" [Fortran/extract_fix]') + END IF + + fix_data%lammps_instance => self + SELECT CASE (style) + CASE (LMP_STYLE_GLOBAL) + fix_data%datatype = DATA_DOUBLE + CALL C_F_POINTER(Cptr, Fptr) + fix_data%r64 = Fptr + CALL lammps_free(Cptr) + CASE (LMP_STYLE_ATOM, LMP_STYLE_LOCAL) + SELECT CASE (type) + CASE (LMP_TYPE_SCALAR) + CALL lmp_error(self, LMP_ERROR_ALL + LMP_ERROR_WORLD, & + 'There is no such thing as a per-atom or local scalar& + & [Fortran/extract_fix]') + CASE (LMP_TYPE_VECTOR) + fix_data%datatype = DATA_DOUBLE_1D + IF ( STYLE == LMP_STYLE_ATOM ) THEN + nrows = self%extract_setting('nmax') + ELSE + Ctemp = lammps_extract_fix(self%handle, Cid, style, & + LMP_SIZE_VECTOR, 0_c_int,0_c_int) + CALL C_F_POINTER(Ctemp, temp) + nrows = temp + END IF + CALL C_F_POINTER(Cptr, fix_data%r64_vec, [nrows]) + CASE (LMP_TYPE_ARRAY) + fix_data%datatype = DATA_DOUBLE_2D + IF ( STYLE == LMP_STYLE_ATOM ) THEN + ! Fortran array is transposed relative to C + ncols = self%extract_setting('nmax') + Ctemp = lammps_extract_fix(self%handle, Cid, style, & + LMP_SIZE_COLS, 0_c_int,0_c_int) + CALL C_F_POINTER(Ctemp, temp) + nrows = temp + ELSE + ! Fortran array is transposed relative to C + Ctemp = lammps_extract_fix(self%handle, Cid, style, & + LMP_SIZE_COLS, 0_c_int,0_c_int) + CALL C_F_POINTER(Ctemp, temp) + nrows = temp + Ctemp = lammps_extract_fix(self%handle, Cid, style, & + LMP_SIZE_ROWS, 0_c_int,0_c_int) + CALL C_F_POINTER(Ctemp, temp) + ncols = temp + END IF + ! First, we dereference the void** to point to a void* pointer + CALL C_F_POINTER(Cptr, Cfixptr, [ncols]) + ! Cfixptr(1) now points to the first element of the array + CALL C_F_POINTER(Cfixptr(1), fix_data%r64_mat, [nrows, ncols]) + CASE DEFAULT + CALL lmp_error(self, LMP_ERROR_ALL + LMP_ERROR_WORLD, & + 'unknown type value passed to extract_fix [Fortran API]') + END SELECT + CASE DEFAULT + CALL lmp_error(self, LMP_ERROR_ALL + LMP_ERROR_WORLD, & + 'unknown style value passed to extract_fix [Fortran API]') + END SELECT + CALL lammps_free(Cid) + END FUNCTION lmp_extract_fix + + ! equivalent function to lammps_extract_variable + FUNCTION lmp_extract_variable(self, name, group) RESULT (variable_data) + CLASS(lammps), INTENT(IN), TARGET :: self + CHARACTER(LEN=*), INTENT(IN) :: name + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: group + TYPE(lammps_variable_data) :: variable_data + + TYPE(c_ptr) :: Cptr, Cname, Cgroup + INTEGER :: length, i + CHARACTER(KIND=c_char, LEN=1), DIMENSION(:), POINTER :: Cstring + INTEGER(c_int) :: datatype + REAL(c_double), POINTER :: double + REAL(c_double), DIMENSION(:), POINTER :: double_vec + + Cname = f2c_string(name) + IF ( PRESENT(group) ) THEN + Cgroup = f2c_string(group) + ELSE + Cgroup = c_null_ptr + END IF + datatype = lammps_extract_variable_datatype(self%handle, Cname) + Cptr = lammps_extract_variable(self%handle, Cname, Cgroup) + CALL lammps_free(Cname) + CALL lammps_free(Cgroup) + + SELECT CASE (datatype) + CASE (LMP_VAR_EQUAL) + variable_data%datatype = DATA_DOUBLE + CALL C_F_POINTER(Cptr, double) + variable_data%r64 = double + CALL lammps_free(Cptr) + CASE (LMP_VAR_ATOM) + variable_data%datatype = DATA_DOUBLE_1D + length = lmp_extract_setting(self, 'nlocal') + CALL C_F_POINTER(Cptr, double_vec, [length]) + variable_data%r64_vec = double_vec + CALL lammps_free(Cptr) + CASE (LMP_VAR_STRING) + variable_data%datatype = DATA_STRING + length = c_strlen(Cptr) + CALL C_F_POINTER(Cptr, Cstring, [length]) + ALLOCATE ( CHARACTER(LEN=length) :: variable_data%str ) + FORALL ( i=1:length ) + variable_data%str(i:i) = Cstring(i) + END FORALL + CASE DEFAULT + CALL lmp_error(self, LMP_ERROR_ALL + LMP_ERROR_WORLD, & + 'Unknown variable type returned from & + &lammps_extract_variable_datatype [Fortran/extract_variable]') + END SELECT + END FUNCTION lmp_extract_variable + ! equivalent function to lammps_version() INTEGER FUNCTION lmp_version(self) CLASS(lammps), INTENT(IN) :: self @@ -873,7 +1070,7 @@ CONTAINS SUBROUTINE lmp_flush_buffers(self) CLASS(lammps), INTENT(IN) :: self - call lammps_flush_buffers(self%handle) + CALL lammps_flush_buffers(self%handle) END SUBROUTINE lmp_flush_buffers ! equivalent function to lammps_has_error @@ -891,14 +1088,16 @@ CONTAINS CHARACTER(LEN=*), INTENT(OUT) :: buffer INTEGER, INTENT(OUT), OPTIONAL :: status INTEGER(c_int) :: length, Cstatus, i - TYPE(c_ptr) :: Cbuffer + TYPE(c_ptr) :: Cptr + CHARACTER(KIND=c_char, LEN=1), DIMENSION(:), POINTER :: Cbuffer buffer = '' IF ( lmp_has_error(self) ) THEN length = LEN(buffer) - Cbuffer = f2cstring(buffer) - Cstatus = lammps_get_last_error_message(self%handle, Cbuffer, length) - length = MIN(LEN(buffer), c_strlen(Cbuffer)) + Cptr = f2c_string(buffer) + Cstatus = lammps_get_last_error_message(self%handle, Cptr, length) + length = MIN(LEN(buffer), c_strlen(Cptr)) + CALL C_F_POINTER(Cptr, Cbuffer, [length]) FORALL ( i=1:length ) buffer(i:i) = Cbuffer(i) END FORALL @@ -923,7 +1122,7 @@ CONTAINS IF ( rhs%datatype == DATA_INT ) THEN lhs => rhs%i32 ELSE - CALL assignment_error(rhs%datatype, 'scalar int') + CALL assignment_error(rhs, 'scalar int') END IF END SUBROUTINE assign_int_to_lammps_data @@ -934,7 +1133,7 @@ CONTAINS IF ( rhs%datatype == DATA_INT64 ) THEN lhs => rhs%i64 ELSE - CALL assignment_error(rhs%datatype, 'scalar long int') + CALL assignment_error(rhs, 'scalar long int') END IF END SUBROUTINE assign_int64_to_lammps_data @@ -945,7 +1144,7 @@ CONTAINS IF ( rhs%datatype == DATA_INT_1D ) THEN lhs => rhs%i32_vec ELSE - CALL assignment_error(rhs%datatype, 'vector of ints') + CALL assignment_error(rhs, 'vector of ints') END IF END SUBROUTINE assign_intvec_to_lammps_data @@ -956,7 +1155,7 @@ CONTAINS IF ( rhs%datatype == DATA_INT64_1D ) THEN lhs => rhs%i64_vec ELSE - CALL assignment_error(rhs%datatype, 'vector of long ints') + CALL assignment_error(rhs, 'vector of long ints') END IF END SUBROUTINE assign_int64vec_to_lammps_data @@ -967,7 +1166,7 @@ CONTAINS IF ( rhs%datatype == DATA_DOUBLE ) THEN lhs => rhs%r64 ELSE - CALL assignment_error(rhs%datatype, 'scalar double') + CALL assignment_error(rhs, 'scalar double') END IF END SUBROUTINE assign_double_to_lammps_data @@ -978,7 +1177,7 @@ CONTAINS IF ( rhs%datatype == DATA_DOUBLE_1D ) THEN lhs => rhs%r64_vec ELSE - CALL assignment_error(rhs%datatype, 'vector of doubles') + CALL assignment_error(rhs, 'vector of doubles') END IF END SUBROUTINE assign_doublevec_to_lammps_data @@ -989,7 +1188,7 @@ CONTAINS IF ( rhs%datatype == DATA_DOUBLE_2D ) THEN lhs => rhs%r64_mat ELSE - CALL assignment_error(rhs%datatype, 'matrix of doubles') + CALL assignment_error(rhs, 'matrix of doubles') END IF END SUBROUTINE assign_doublemat_to_lammps_data @@ -1000,17 +1199,81 @@ CONTAINS IF ( rhs%datatype == DATA_STRING ) THEN lhs = rhs%str ELSE - CALL assignment_error(rhs%datatype, 'string') + CALL assignment_error(rhs, 'string') END IF END SUBROUTINE assign_string_to_lammps_data - SUBROUTINE assignment_error (type1, type2) - INTEGER (c_int) :: type1 - CHARACTER (LEN=*) :: type2 - INTEGER, PARAMETER :: ERROR_CODE = 1 + ! ---------------------------------------------------------------------- + ! functions to assign user-space pointers to LAMMPS *fix* data + ! ---------------------------------------------------------------------- + SUBROUTINE assign_double_to_lammps_fix_data (lhs, rhs) + REAL(c_double), INTENT(OUT) :: lhs + CLASS(lammps_fix_data), INTENT(IN) :: rhs + + IF ( rhs%datatype == DATA_DOUBLE ) THEN + lhs = rhs%r64 + ELSE + CALL assignment_error(rhs, 'scalar double') + END IF + END SUBROUTINE assign_double_to_lammps_fix_data + + SUBROUTINE assign_doublevec_to_lammps_fix_data (lhs, rhs) + REAL(c_double), DIMENSION(:), INTENT(OUT), POINTER :: lhs + CLASS(lammps_fix_data), INTENT(IN) :: rhs + + IF ( rhs%datatype == DATA_DOUBLE_1D ) THEN + lhs => rhs%r64_vec + ELSE + CALL assignment_error(rhs, 'vector of doubles') + END IF + END SUBROUTINE assign_doublevec_to_lammps_fix_data + + SUBROUTINE assign_doublemat_to_lammps_fix_data (lhs, rhs) + REAL(c_double), DIMENSION(:,:), INTENT(OUT), POINTER :: lhs + CLASS(lammps_fix_data), INTENT(IN) :: rhs + + IF ( rhs%datatype == DATA_DOUBLE_2D ) THEN + lhs => rhs%r64_mat + ELSE + CALL assignment_error(rhs, 'matrix of doubles') + END IF + END SUBROUTINE assign_doublemat_to_lammps_fix_data + + ! ---------------------------------------------------------------------- + ! functions to assign user-space pointers to LAMMPS *variable* data + ! ---------------------------------------------------------------------- + SUBROUTINE assign_double_to_lammps_variable_data (lhs, rhs) + REAL(c_double), INTENT(OUT) :: lhs + CLASS(lammps_variable_data), INTENT(IN) :: rhs + + IF ( rhs%datatype == DATA_DOUBLE ) THEN + lhs = rhs%r64 + ELSE + CALL assignment_error(rhs, 'scalar double') + END IF + END SUBROUTINE assign_double_to_lammps_variable_data + + SUBROUTINE assign_doublevec_to_lammps_variable_data (lhs, rhs) + REAL(c_double), DIMENSION(:), INTENT(OUT), POINTER :: lhs + CLASS(lammps_variable_data), INTENT(IN) :: rhs + + IF ( rhs%datatype == DATA_DOUBLE_1D ) THEN + lhs = rhs%r64_vec + ELSE + CALL assignment_error(rhs, 'vector of doubles') + END IF + END SUBROUTINE assign_doublevec_to_lammps_variable_data + + ! ---------------------------------------------------------------------- + ! Generic function to catch all errors in assignments of LAMMPS data to + ! user-space variables/pointers + ! ---------------------------------------------------------------------- + SUBROUTINE assignment_error (type1, str2) + CLASS(lammps_data_baseclass), INTENT(IN) :: type1 + CHARACTER (LEN=*), INTENT(IN) :: str2 CHARACTER (LEN=:), ALLOCATABLE :: str1 - SELECT CASE (type1) + SELECT CASE (type1%datatype) CASE (DATA_INT) str1 = 'scalar int' CASE (DATA_INT_1D) @@ -1032,11 +1295,8 @@ CONTAINS CASE DEFAULT str1 = 'that type' END SELECT - !CALL lmp_error(self, LMP_ERROR_ALL + LMP_ERROR_WORLD, 'cannot associate ' & - ! // str1 // ' with ' // type2 // ' [Fortran API]') - WRITE (ERROR_UNIT,'(A)') 'ERROR (Fortran API): cannot associate ' & - // str1 // ' with ' // type2 - STOP ERROR_CODE + CALL lmp_error(type1%lammps_instance, LMP_ERROR_ALL + LMP_ERROR_WORLD, & + 'cannot associate ' // str1 // ' with ' // str2 // ' [Fortran API]') END SUBROUTINE assignment_error ! ---------------------------------------------------------------------- diff --git a/python/lammps/constants.py b/python/lammps/constants.py index 26bb92626a..6a7fda85a8 100644 --- a/python/lammps/constants.py +++ b/python/lammps/constants.py @@ -42,6 +42,7 @@ LMP_ERROR_UNIVERSE = 8 LMP_VAR_EQUAL = 0 LMP_VAR_ATOM = 1 +LMP_VAR_STRING = 2 # ------------------------------------------------------------------------- diff --git a/src/library.cpp b/src/library.cpp index 16381a089d..d5e309ce33 100644 --- a/src/library.cpp +++ b/src/library.cpp @@ -2130,6 +2130,47 @@ void *lammps_extract_variable(void *handle, const char *name, const char *group) /* ---------------------------------------------------------------------- */ +/** Get data type of a LAMMPS variable + * +\verbatim embed:rst + +This function returns an integer that encodes the data type of the variable +with the specified name. See :cpp:enum:`_LMP_VAR_CONST` for valid values. +Callers of :cpp:func:`lammps_extract_variable` can use this information to +decide how to cast the (void*) pointer and access the data. + +..versionadded:: TBD + +\endverbatim + * + * \param handle pointer to a previously created LAMMPS instance + * \param name string with the name of the extracted variable + * \return integer constant encoding the data type of the property + * or -1 if not found. + **/ + +int lammps_extract_variable_datatype(void *handle, const char *name) +{ + auto lmp = (LAMMPS*) handle; + + BEGIN_CAPTURE + { + int ivar = lmp->input->variable->find(name); + if ( ivar < 0 ) return -1; + + if (lmp->input->variable->equalstyle(ivar)) + return LMP_VAR_EQUAL; + else if (lmp->input->variable->atomstyle(ivar)) + return LMP_VAR_ATOM; + else + return LMP_VAR_STRING; + } + END_CAPTURE + return -1; +} + +/* ---------------------------------------------------------------------- */ + /** Set the value of a string-style variable. * * This function assigns a new value from the string str to the diff --git a/src/library.h b/src/library.h index 1eec57898e..d0616cd6c4 100644 --- a/src/library.h +++ b/src/library.h @@ -40,7 +40,8 @@ /** Data type constants for extracting data from atoms, computes and fixes * - * Must be kept in sync with the equivalent constants in lammps/constants.py */ + * Must be kept in sync with the equivalent constants in lammps/constants.py + * and fortran/lammps.f90 */ enum _LMP_DATATYPE_CONST { LAMMPS_INT = 0, /*!< 32-bit integer (array) */ @@ -54,7 +55,8 @@ enum _LMP_DATATYPE_CONST { /** Style constants for extracting data from computes and fixes. * - * Must be kept in sync with the equivalent constants in lammps/constants.py */ + * Must be kept in sync with the equivalent constants in lammps/constants.py + * and fortran/lammps.f90 */ enum _LMP_STYLE_CONST { LMP_STYLE_GLOBAL = 0, /*!< return global data */ @@ -64,7 +66,8 @@ enum _LMP_STYLE_CONST { /** Type and size constants for extracting data from computes and fixes. * - * Must be kept in sync with the equivalent constants in lammps/constants.py */ + * Must be kept in sync with the equivalent constants in lammps/constants.py + * and fortran/lammps.f90 */ enum _LMP_TYPE_CONST { LMP_TYPE_SCALAR = 0, /*!< return scalar */ @@ -77,7 +80,8 @@ enum _LMP_TYPE_CONST { /** Error codes to select the suitable function in the Error class * - * Must be kept in sync with the equivalent constants in lammps/constants.py */ + * Must be kept in sync with the equivalent constants in lammps/constants.py + * and fortran/lammps.f90 */ enum _LMP_ERROR_CONST { LMP_ERROR_WARNING = 0, /*!< call Error::warning() */ @@ -87,6 +91,17 @@ enum _LMP_ERROR_CONST { LMP_ERROR_UNIVERSE = 8 /*!< error on Comm::universe */ }; +/** Variable style constants for extracting data from variables + * + * Must be kept in sync with the equivalent constants in lammps/constants.py + * and fortran/lammps.f90 */ + +enum _LMP_VAR_CONST { + LMP_VAR_EQUAL = 0, /*!< compatible with equal-style variables */ + LMP_VAR_ATOM = 1, /*!< compatible with atom-style variables */ + LMP_VAR_STRING = 2 /*!< return value will be a string (catch-all) */ +}; + /* Ifdefs to allow this file to be included in C and C++ programs */ #ifdef __cplusplus @@ -153,6 +168,7 @@ void *lammps_extract_atom(void *handle, const char *name); void *lammps_extract_compute(void *handle, const char *, int, int); void *lammps_extract_fix(void *handle, const char *, int, int, int, int); void *lammps_extract_variable(void *handle, const char *, const char *); +int lammps_extract_variable_datatype(void *handle, const char *name); int lammps_set_variable(void *, char *, char *); /* ---------------------------------------------------------------------- diff --git a/unittest/fortran/CMakeLists.txt b/unittest/fortran/CMakeLists.txt index 672333c529..fc0d0dc956 100644 --- a/unittest/fortran/CMakeLists.txt +++ b/unittest/fortran/CMakeLists.txt @@ -65,6 +65,10 @@ if(CMAKE_Fortran_COMPILER) target_link_libraries(test_fortran_extract_compute PRIVATE flammps lammps MPI::MPI_Fortran GTest::GTestMain) add_test(NAME FortranExtractCompute COMMAND test_fortran_extract_compute) + add_executable(test_fortran_extract_fix wrap_extract_fix.cpp test_fortran_extract_fix.f90) + target_link_libraries(test_fortran_extract_fix PRIVATE flammps lammps MPI::MPI_Fortran GTest::GTestMain) + add_test(NAME FortranExtractFix COMMAND test_fortran_extract_fix) + else() message(STATUS "Skipping Tests for the LAMMPS Fortran Module: no Fortran compiler") endif() diff --git a/unittest/fortran/test_fortran_extract_fix.f90 b/unittest/fortran/test_fortran_extract_fix.f90 new file mode 100644 index 0000000000..85b4cb5f4f --- /dev/null +++ b/unittest/fortran/test_fortran_extract_fix.f90 @@ -0,0 +1,118 @@ +MODULE keepfix + USE liblammps + TYPE(LAMMPS) :: lmp + CHARACTER(LEN=40), DIMENSION(3), PARAMETER :: demo_input = & + [ CHARACTER(LEN=40) :: & + 'region box block 0 $x 0 3 0 4', & + 'create_box 1 box', & + 'create_atoms 1 single 1.0 1.0 ${zpos}' ] + CHARACTER(LEN=40), DIMENSION(3), PARAMETER :: cont_input = & + [ CHARACTER(LEN=40) :: & + 'create_atoms 1 single &', & + ' 0.2 0.1 0.1', & + 'create_atoms 1 single 0.5 0.5 0.5' ] + CHARACTER(LEN=40), DIMENSION(3), PARAMETER :: pair_input = & + [ CHARACTER(LEN=40) :: & + 'pair_style lj/cut 2.5', & + 'pair_coeff 1 1 1.0 1.0', & + 'mass 1 2.0' ] +END MODULE keepfix + +FUNCTION f_lammps_with_args() BIND(C) + USE ISO_C_BINDING, ONLY: C_ptr + USE liblammps + USE keepfix, 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 keepfix, ONLY: lmp + IMPLICIT NONE + + CALL lmp%close() + lmp%handle = C_NULL_PTR +END SUBROUTINE f_lammps_close + +SUBROUTINE f_lammps_setup_extract_fix () BIND(C) + USE LIBLAMMPS + USE keepfix, 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("fix state all store/state 0 z") ! per-atom vector + CALL lmp%command("fix move all move linear 0 0 0") ! for per-atom array + CALL lmp%command("fix recenter all recenter 1 1 1") ! global scalar, vector + CALL lmp%command("variable natoms equal count(all)") + CALL lmp%command("variable ts equal step") + CALL lmp%command("fix vec all vector 1 v_natoms v_ts") ! global array + CALL lmp%command("run 1") ! must be 1, otherwise move/recenter won't happen +END SUBROUTINE f_lammps_setup_extract_fix + +FUNCTION f_lammps_extract_fix_global_scalar () BIND(C) RESULT(scalar) + USE, INTRINSIC :: ISO_C_BINDING, ONLY : C_double + USE LIBLAMMPS + USE keepfix, ONLY : lmp + IMPLICIT NONE + REAL(C_double) :: scalar + + scalar = lmp%extract_fix("recenter", lmp%style%global, lmp%type%scalar) +END FUNCTION f_lammps_extract_fix_global_scalar + +FUNCTION f_lammps_extract_fix_global_vector (i) BIND(C) RESULT(element) + USE, INTRINSIC :: ISO_C_BINDING, ONLY : C_double, C_int + USE LIBLAMMPS + USE keepfix, ONLY : lmp + IMPLICIT NONE + INTEGER(C_int), INTENT(IN), VALUE :: i + REAL(C_double) :: element + + element = lmp%extract_fix("recenter", lmp%style%global, lmp%type%vector, i) +END FUNCTION f_lammps_extract_fix_global_vector + +FUNCTION f_lammps_extract_fix_global_array (i,j) BIND(C) RESULT(element) + USE, INTRINSIC :: ISO_C_BINDING, ONLY : C_double, C_int + USE LIBLAMMPS + USE keepfix, ONLY : lmp + IMPLICIT NONE + INTEGER(C_int), INTENT(IN), VALUE :: i, j + REAL(C_double) :: element + + element = lmp%extract_fix("vec", lmp%style%global, lmp%type%array, i, j) +END FUNCTION f_lammps_extract_fix_global_array + +FUNCTION f_lammps_extract_fix_peratom_vector (i) BIND(C) + USE, INTRINSIC :: ISO_C_BINDING, ONLY : C_double, C_int + USE LIBLAMMPS + USE keepfix, ONLY : lmp + IMPLICIT NONE + INTEGER(C_int), INTENT(IN), VALUE :: i + REAL(C_double) :: f_lammps_extract_fix_peratom_vector + REAL(C_double), DIMENSION(:), POINTER :: vector + + vector = lmp%extract_fix("state", lmp%style%atom, lmp%type%vector, -1, -1) + f_lammps_extract_fix_peratom_vector = vector(i) +END FUNCTION f_lammps_extract_fix_peratom_vector + +FUNCTION f_lammps_extract_fix_peratom_array (i,j) BIND(C) + USE, INTRINSIC :: ISO_C_BINDING, ONLY : C_double, C_int + USE LIBLAMMPS + USE keepfix, ONLY : lmp + IMPLICIT NONE + INTEGER(C_int), INTENT(IN), VALUE :: i, j + REAL(C_double) :: f_lammps_extract_fix_peratom_array + REAL(C_double), DIMENSION(:,:), POINTER :: array + + array = lmp%extract_fix("move", lmp%style%atom, lmp%type%array, -1, -1) + f_lammps_extract_fix_peratom_array = array(i,j) +END FUNCTION f_lammps_extract_fix_peratom_array diff --git a/unittest/fortran/wrap_extract_fix.cpp b/unittest/fortran/wrap_extract_fix.cpp new file mode 100644 index 0000000000..d8f19c8b95 --- /dev/null +++ b/unittest/fortran/wrap_extract_fix.cpp @@ -0,0 +1,107 @@ +// unit tests for extracting compute data from a LAMMPS instance through the +// Fortran wrapper +#include + +#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_extract_fix(); +double f_lammps_extract_fix_global_scalar(); +double f_lammps_extract_fix_global_vector(int); +double f_lammps_extract_fix_global_array(int,int); +double f_lammps_extract_fix_peratom_vector(int); +double f_lammps_extract_fix_peratom_array(int,int); +double f_lammps_extract_fix_local_vector(int); +double f_lammps_extract_fix_local_array(int,int); +} + +class LAMMPS_extract_fix : public ::testing::Test { +protected: + LAMMPS_NS::LAMMPS *lmp; + LAMMPS_extract_fix() = default; + ~LAMMPS_extract_fix() 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_extract_fix, global_scalar) +{ + f_lammps_setup_extract_fix(); + double *scalar = (double*) lammps_extract_fix(lmp, "recenter", + LMP_STYLE_GLOBAL, LMP_TYPE_SCALAR, -1, -1); + EXPECT_DOUBLE_EQ(f_lammps_extract_fix_global_scalar(), *scalar); + lammps_free(scalar); +}; + +TEST_F(LAMMPS_extract_fix, global_vector) +{ + f_lammps_setup_extract_fix(); + double *x = (double*) lammps_extract_fix(lmp, "recenter", + LMP_STYLE_GLOBAL, LMP_TYPE_VECTOR, 0, -1); + double *y = (double*) lammps_extract_fix(lmp, "recenter", + LMP_STYLE_GLOBAL, LMP_TYPE_VECTOR, 1, -1); + double *z = (double*) lammps_extract_fix(lmp, "recenter", + LMP_STYLE_GLOBAL, LMP_TYPE_VECTOR, 2, -1); + EXPECT_DOUBLE_EQ(f_lammps_extract_fix_global_vector(1), *x); + EXPECT_DOUBLE_EQ(f_lammps_extract_fix_global_vector(2), *y); + EXPECT_DOUBLE_EQ(f_lammps_extract_fix_global_vector(3), *z); + lammps_free(x); + lammps_free(y); + lammps_free(z); +}; + +TEST_F(LAMMPS_extract_fix, global_array) +{ + f_lammps_setup_extract_fix(); + double natoms = lammps_get_natoms(lmp); + EXPECT_DOUBLE_EQ(f_lammps_extract_fix_global_array(1,1), natoms); + EXPECT_DOUBLE_EQ(f_lammps_extract_fix_global_array(1,2), natoms); + EXPECT_DOUBLE_EQ(f_lammps_extract_fix_global_array(2,1), 0.0); + EXPECT_DOUBLE_EQ(f_lammps_extract_fix_global_array(2,2), 1.0); +}; + +TEST_F(LAMMPS_extract_fix, peratom_vector) +{ + f_lammps_setup_extract_fix(); + EXPECT_DOUBLE_EQ(f_lammps_extract_fix_peratom_vector(1), 1.5); + EXPECT_DOUBLE_EQ(f_lammps_extract_fix_peratom_vector(2), 0.1); + EXPECT_DOUBLE_EQ(f_lammps_extract_fix_peratom_vector(3), 0.5); +}; + +TEST_F(LAMMPS_extract_fix, peratom_array) +{ + f_lammps_setup_extract_fix(); + EXPECT_DOUBLE_EQ(f_lammps_extract_fix_peratom_array(1,1), 1.0); + EXPECT_DOUBLE_EQ(f_lammps_extract_fix_peratom_array(2,1), 1.0); + EXPECT_DOUBLE_EQ(f_lammps_extract_fix_peratom_array(3,1), 1.5); + EXPECT_DOUBLE_EQ(f_lammps_extract_fix_peratom_array(1,2), 0.2); + EXPECT_DOUBLE_EQ(f_lammps_extract_fix_peratom_array(2,2), 0.1); + EXPECT_DOUBLE_EQ(f_lammps_extract_fix_peratom_array(3,2), 0.1); + EXPECT_DOUBLE_EQ(f_lammps_extract_fix_peratom_array(1,3), 0.5); + EXPECT_DOUBLE_EQ(f_lammps_extract_fix_peratom_array(2,3), 0.5); + EXPECT_DOUBLE_EQ(f_lammps_extract_fix_peratom_array(3,3), 0.5); +};