lammps/fortran/lammps.f90

581 lines
20 KiB
Fortran
Raw Normal View History

! -------------------------------------------------------------------------
! LAMMPS - Large-scale Atomic/Molecular Massively Parallel Simulator
2021-05-25 04:16:21 +08:00
! https://www.lammps.org/ Sandia National Laboratories
! Steve Plimpton, sjplimp@sandia.gov
!
! Copyright (2003) Sandia Corporation. Under the terms of Contract
! DE-AC04-94AL85000 with Sandia Corporation, the U.S. Government retains
! certain rights in this software. This software is distributed under
! the GNU General Public License.
!
! See the README file in the top-level LAMMPS directory.
! -------------------------------------------------------------------------
!
! Fortran interface to the LAMMPS library implemented as a Fortran 2003
! style module that wraps the C-style library interface in library.cpp
! and library.h using the ISO_C_BINDING module of the Fortran compiler.
!
! Based on the LAMMPS Fortran 2003 module contributed by:
! Karl D. Hammond <hammondkd@missouri.edu>
! University of Missouri, 2012-2020
!
! The Fortran module tries to follow the API of the C-library interface
! closely, but like the Python wrapper it employs an object oriented
! approach. To accommodate the object oriented approach, all exported
! subroutine and functions have to be implemented in Fortran to then
! call the interfaced C style functions with adapted calling conventions
! as needed. The C-library interfaced functions retain their names
! starting with "lammps_" while the Fortran versions start with "lmp_".
!
MODULE LIBLAMMPS
USE, INTRINSIC :: ISO_C_BINDING, ONLY: c_ptr, c_null_ptr, c_loc, &
c_int, c_int64_t, c_char, c_null_char, c_double, c_size_t, c_f_pointer
IMPLICIT NONE
PRIVATE
PUBLIC :: lammps
! These are public-interface constants that have the same purpose as the
! constants in library.h, except that their types match the type of the
! constant in question. Their purpose is to determine the type of the
! return value without something akin to a C/C++ type cast
INTEGER (c_int), PUBLIC, PARAMETER :: LMP_INT = 0_c_int
INTEGER (c_int), PUBLIC, DIMENSION(2), PARAMETER :: LMP_INT_1D = 1_c_int
INTEGER (c_int), PUBLIC, DIMENSION(2,2), PARAMETER :: LMP_INT_2D = 1_c_int
REAL (c_double), PUBLIC, PARAMETER :: LMP_DOUBLE = 2.0_c_double
REAL (c_double), PUBLIC, DIMENSION(2), PARAMETER :: &
LMP_DOUBLE_1D = 2.0_c_double
REAL (c_double), PUBLIC, DIMENSION(2,2), PARAMETER :: &
LMP_DOUBLE_2D = 3.0_c_double
INTEGER (c_int64_t), PUBLIC, PARAMETER :: LMP_INT64 = 4_c_int64_t
INTEGER (c_int64_t), PUBLIC, DIMENSION(2), PARAMETER :: &
LMP_INT64_1D = 4_c_int64_t
INTEGER (c_int64_t), PUBLIC, DIMENSION(2,2), PARAMETER :: &
LMP_INT64_2D = 5_c_int64_t
CHARACTER(LEN=*), PUBLIC, PARAMETER :: LMP_STRING = 'six'
! Data type constants for extracting data from global, atom, compute, and fix
!
! Must be kept in sync with the equivalent declarations in
! src/library.h and python/lammps/constants.py
INTEGER (c_int), PARAMETER :: &
LAMMPS_INT = 0_c_int, & ! 32-bit integer (array)
LAMMPS_INT_2D = 1, & ! two-dimensional 32-bit integer array
LAMMPS_DOUBLE = 2, & ! 64-bit double (array)
LAMMPS_DOUBLE_2D = 3, & ! two-dimensional 64-bit double array
LAMMPS_INT64 = 4, & ! 64-bit integer (array)
LAMMPS_INT64_2D = 5, & ! two-dimensional 64-bit integer array
LAMMPS_STRING = 6 ! C-String
TYPE lammps
TYPE(c_ptr) :: handle
CONTAINS
PROCEDURE :: close => lmp_close
PROCEDURE :: file => lmp_file
PROCEDURE :: command => lmp_command
PROCEDURE :: commands_list => lmp_commands_list
PROCEDURE :: commands_string => lmp_commands_string
PROCEDURE :: get_natoms => lmp_get_natoms
PROCEDURE :: get_thermo => lmp_get_thermo
PROCEDURE :: extract_box => lmp_extract_box
PROCEDURE :: reset_box => lmp_reset_box
PROCEDURE :: memory_usage => lmp_memory_usage
PROCEDURE :: get_mpi_comm => lmp_get_mpi_comm
PROCEDURE :: extract_setting => lmp_extract_setting
PROCEDURE :: version => lmp_version
END TYPE lammps
INTERFACE lammps
MODULE PROCEDURE lmp_open
END INTERFACE lammps
! interface definitions for calling functions in library.cpp
INTERFACE
FUNCTION lammps_open(argc, argv, comm) BIND(C, name='lammps_open_fortran')
IMPORT :: c_ptr, c_int
INTEGER(c_int), VALUE, INTENT(IN) :: argc, comm
TYPE(c_ptr), DIMENSION(*), INTENT(IN) :: argv
TYPE(c_ptr) :: lammps_open
END FUNCTION lammps_open
FUNCTION lammps_open_no_mpi(argc, argv, handle) BIND(C)
IMPORT :: c_ptr, c_int
INTEGER(c_int), VALUE, INTENT(IN) :: argc
TYPE(c_ptr), DIMENSION(*), INTENT(IN) :: argv
2022-08-07 06:46:33 +08:00
TYPE(c_ptr), VALUE, INTENT(in) :: handle
TYPE(c_ptr) :: lammps_open_no_mpi
END FUNCTION lammps_open_no_mpi
SUBROUTINE lammps_close(handle) BIND(C)
IMPORT :: c_ptr
TYPE(c_ptr), VALUE :: handle
END SUBROUTINE lammps_close
SUBROUTINE lammps_mpi_init() BIND(C)
END SUBROUTINE lammps_mpi_init
SUBROUTINE lammps_mpi_finalize() BIND(C)
END SUBROUTINE lammps_mpi_finalize
SUBROUTINE lammps_kokkos_finalize() BIND(C)
END SUBROUTINE lammps_kokkos_finalize
SUBROUTINE lammps_file(handle, filename) BIND(C)
IMPORT :: c_ptr
TYPE(c_ptr), VALUE :: handle
TYPE(c_ptr), VALUE :: filename
END SUBROUTINE lammps_file
SUBROUTINE lammps_command(handle, cmd) BIND(C)
IMPORT :: c_ptr
TYPE(c_ptr), VALUE :: handle
TYPE(c_ptr), VALUE :: cmd
END SUBROUTINE lammps_command
SUBROUTINE lammps_commands_list(handle, ncmd, cmds) BIND(C)
IMPORT :: c_ptr, c_int
TYPE(c_ptr), VALUE :: handle
INTEGER(c_int), VALUE, INTENT(IN) :: ncmd
TYPE(c_ptr), DIMENSION(*), INTENT(IN) :: cmds
END SUBROUTINE lammps_commands_list
SUBROUTINE lammps_commands_string(handle, str) BIND(C)
IMPORT :: c_ptr
TYPE(c_ptr), VALUE :: handle
TYPE(c_ptr), VALUE :: str
END SUBROUTINE lammps_commands_string
FUNCTION lammps_get_natoms(handle) BIND(C)
IMPORT :: c_ptr, c_double
TYPE(c_ptr), VALUE :: handle
REAL(c_double) :: lammps_get_natoms
END FUNCTION lammps_get_natoms
FUNCTION lammps_get_thermo(handle,name) BIND(C)
IMPORT :: c_ptr, c_double
IMPLICIT NONE
REAL(c_double) :: lammps_get_thermo
TYPE(c_ptr), VALUE :: handle
TYPE(c_ptr), VALUE :: name
END FUNCTION lammps_get_thermo
SUBROUTINE lammps_extract_box(handle,boxlo,boxhi,xy,yz,xz,pflags, &
boxflag) BIND(C)
IMPORT :: c_ptr, c_double, c_int
IMPLICIT NONE
TYPE(c_ptr), VALUE :: handle, boxlo, boxhi, xy, yz, xz, pflags, &
boxflag
END SUBROUTINE lammps_extract_box
SUBROUTINE lammps_reset_box(handle,boxlo,boxhi,xy,yz,xz) BIND(C)
IMPORT :: c_ptr, c_double
IMPLICIT NONE
TYPE (c_ptr), VALUE :: handle
REAL (c_double), DIMENSION(3) :: boxlo, boxhi
REAL (c_double), VALUE :: xy, yz, xz
END SUBROUTINE lammps_reset_box
SUBROUTINE lammps_memory_usage(handle,meminfo) BIND(C)
IMPORT :: c_ptr, c_double
IMPLICIT NONE
TYPE(c_ptr), VALUE :: handle
REAL(c_double), DIMENSION(*) :: meminfo
END SUBROUTINE lammps_memory_usage
FUNCTION lammps_get_mpi_comm(handle) BIND(C)
IMPORT :: c_ptr, c_int
IMPLICIT NONE
TYPE (c_ptr), VALUE :: handle
INTEGER (c_int) :: lammps_get_mpi_comm
END FUNCTION lammps_get_mpi_comm
FUNCTION lammps_extract_setting(handle,keyword) BIND(C)
IMPORT :: c_ptr, c_int
IMPLICIT NONE
TYPE(c_ptr), VALUE :: handle, keyword
INTEGER (c_int) :: lammps_extract_setting
END FUNCTION lammps_extract_setting
FUNCTION lammps_extract_global_datatype(handle,name) BIND(C)
IMPORT :: c_ptr, c_int
IMPLICIT NONE
TYPE(c_ptr), VALUE :: handle, name
INTEGER (c_int) :: lammps_extract_global_datatype
END FUNCTION lammps_extract_global_datatype
FUNCTION lammps_extract_global(handle, name) BIND(C)
IMPORT :: c_ptr
TYPE(c_ptr), VALUE :: handle, name
TYPE(c_ptr) :: lammps_extract_global
END FUNCTION lammps_extract_global
!(generic) lammps_extract_global
! TODO: You can fake out the type-casting by declaring non-optional
! parameters that help the compiler figure out which one to call
!INTEGER (c_int) FUNCTION lammps_extract_atom_datatype
!(generic) lammps_extract_atom
!(generic) lammps_extract_compute
!(generic) lammps_extract_fix
!(generic) lammps_extract_variable
!INTEGER (c_int) lammps_set_variable
!SUBROUTINE lammps_gather_atoms
!SUBROUTINE lammps_gather_atoms_concat
!SUBROUTINE lammps_gather_atoms_subset
!SUBROUTINE lammps_scatter_atoms
!SUBROUTINE lammps_scatter_atoms_subset
!SUBROUTINE lammps_gather_bonds
!SUBROUTINE lammps_gather
!SUBROUTINE lammps_gather_concat
!SUBROUTINE lammps_gather_subset
!SUBROUTINE lammps_scatter_subset
!(generic / id, type, and image are special) / requires LAMMPS_BIGBIG
!INTEGER (C_int) FUNCTION lammps_create_atoms
!INTEGER (C_int) FUNCTION lammps_find_pair_neighlist
!INTEGER (C_int) FUNCTION lammps_find_fix_neighlist
!INTEGER (C_int) FUNCTION lammps_find_compute_neighlist
!INTEGER (C_int) FUNCTION lammps_neighlist_num_elements
!SUBROUTINE lammps_neighlist_element_neighbors
FUNCTION lammps_version(handle) BIND(C)
IMPORT :: c_ptr, c_int
TYPE(c_ptr), VALUE :: handle
INTEGER(c_int) :: lammps_version
END FUNCTION lammps_version
!SUBROUTINE lammps_get_os_info
!LOGICAL FUNCTION lammps_config_has_mpi_support
!LOGICAL FUNCTION lammps_config_has_gzip_support
!LOGICAL FUNCTION lammps_config_has_png_support
!LOGICAL FUNCTION lammps_config_has_jpeg_support
!LOGICAL FUNCTION lammps_config_has_ffmpeg_support
!LOGICAL FUNCTION lammps_config_has_exceptions
!LOGICAL FUNCTION lammps_config_has_package
!INTEGER (C_int) FUNCTION lammps_config_package_count
!SUBROUTINE lammps_config_package_name
!LOGICAL FUNCTION lammps_config_accelerator
!LOGICAL FUNCTION lammps_has_gpu_device
!SUBROUTINE lammps_get_gpu_device
!LOGICAL FUNCTION lammps_has_id
!INTEGER (C_int) FUNCTION lammps_id_count
!SUBROUTINE lammps_id_name
!INTEGER (C_int) FUNCTION lammps_plugin_count
!SUBROUTINE lammps_plugin_name
!Both of these use LAMMPS_BIGBIG
!INTEGER (LAMMPS_imageint) FUNCTION lammps_encode_image_flags
!SUBROUTINE lammps_decode_image_flags
!SUBROUTINE lammps_set_fix_external_callback ! may have trouble....
!FUNCTION lammps_fix_external_get_force() ! returns real(c_double) (:)
!SUBROUTINE lammps_fix_external_set_energy_global
!SUBROUTINE lammps_fix_external_set_energy_peratom
!SUBROUTINE lammps_fix_external_set_virial_global
!SUBROUTINE lammps_fix_external_set_virial_peratom
!SUBROUTINE lammps_fix_external_set_vector_length
!SUBROUTINE lammps_fix_external_set_vector
!SUBROUTINE lammps_flush_buffers
FUNCTION lammps_malloc(size) BIND(C, name='malloc')
IMPORT :: c_ptr, c_size_t
INTEGER(c_size_t), VALUE :: size
TYPE(c_ptr) :: lammps_malloc
END FUNCTION lammps_malloc
SUBROUTINE lammps_free(ptr) BIND(C)
IMPORT :: c_ptr
TYPE(c_ptr), VALUE :: ptr
END SUBROUTINE lammps_free
!LOGICAL FUNCTION lammps_is_running
!SUBROUTINE lammps_force_timeout
!LOGICAL FUNCTION lammps_has_error
!INTEGER (c_int) FUNCTION lammps_get_last_error_message
END INTERFACE
CONTAINS
! Fortran wrappers and helper functions.
! Constructor for the LAMMPS class.
! Combined wrapper around lammps_open_fortran() and lammps_open_no_mpi()
TYPE(lammps) FUNCTION lmp_open(args, comm)
IMPLICIT NONE
INTEGER, INTENT(in), OPTIONAL :: comm
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: args(:)
TYPE(c_ptr), ALLOCATABLE :: argv(:)
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
ELSE
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)
ELSE
2022-08-07 06:46:33 +08:00
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))
END DO
DEALLOCATE(argv)
END FUNCTION lmp_open
! Combined Fortran wrapper around lammps_close() and lammps_mpi_finalize()
SUBROUTINE lmp_close(self, finalize)
IMPLICIT NONE
CLASS(lammps) :: self
LOGICAL, INTENT(IN), OPTIONAL :: finalize
CALL lammps_close(self%handle)
IF (PRESENT(finalize)) THEN
IF (finalize) THEN
CALL lammps_kokkos_finalize()
CALL lammps_mpi_finalize()
END IF
END IF
END SUBROUTINE lmp_close
SUBROUTINE lmp_file(self, filename)
IMPLICIT NONE
CLASS(lammps) :: self
CHARACTER(len=*) :: filename
TYPE(c_ptr) :: str
str = f2c_string(filename)
CALL lammps_file(self%handle, str)
CALL lammps_free(str)
END SUBROUTINE lmp_file
! equivalent function to lammps_command()
SUBROUTINE lmp_command(self, cmd)
IMPLICIT NONE
CLASS(lammps) :: self
CHARACTER(len=*) :: cmd
TYPE(c_ptr) :: str
str = f2c_string(cmd)
CALL lammps_command(self%handle, str)
CALL lammps_free(str)
END SUBROUTINE lmp_command
! equivalent function to lammps_commands_list()
SUBROUTINE lmp_commands_list(self, cmds)
IMPLICIT NONE
CLASS(lammps) :: self
CHARACTER(len=*), INTENT(in), OPTIONAL :: cmds(:)
TYPE(c_ptr), ALLOCATABLE :: cmdv(:)
INTEGER :: i, ncmd
! convert command list to c style
ncmd = SIZE(cmds)
ALLOCATE(cmdv(ncmd))
DO i=1, ncmd
cmdv(i) = f2c_string(cmds(i))
END DO
CALL lammps_commands_list(self%handle, ncmd, cmdv)
! Clean up allocated memory
DO i=1, ncmd
CALL lammps_free(cmdv(i))
END DO
DEALLOCATE(cmdv)
END SUBROUTINE lmp_commands_list
! equivalent function to lammps_commands_string()
SUBROUTINE lmp_commands_string(self, str)
IMPLICIT NONE
CLASS(lammps) :: self
CHARACTER(len=*) :: str
TYPE(c_ptr) :: tmp
tmp = f2c_string(str)
CALL lammps_commands_string(self%handle, tmp)
CALL lammps_free(tmp)
END SUBROUTINE lmp_commands_string
! equivalent function to lammps_get_natoms
DOUBLE PRECISION FUNCTION lmp_get_natoms(self)
IMPLICIT NONE
CLASS(lammps) :: self
lmp_get_natoms = lammps_get_natoms(self%handle)
END FUNCTION lmp_get_natoms
! equivalent function to lammps_get_thermo
REAL (C_double) FUNCTION lmp_get_thermo(self,name)
CLASS(lammps), INTENT(IN) :: self
CHARACTER(LEN=*) :: name
TYPE(C_ptr) :: Cname
Cname = f2c_string(name)
lmp_get_thermo = lammps_get_thermo(self%handle, Cname)
CALL lammps_free(Cname)
END FUNCTION lmp_get_thermo
! equivalent subroutine to lammps_extract_box
SUBROUTINE lmp_extract_box (self, boxlo, boxhi, xy, yz, xz, pflags, boxflag)
CLASS(lammps), INTENT(IN) :: self
REAL(c_double), INTENT(OUT), TARGET, OPTIONAL :: boxlo(3), boxhi(3)
REAL(c_double), INTENT(OUT), TARGET, OPTIONAL :: xy, yz, xz
LOGICAL, INTENT(OUT), OPTIONAL :: pflags(3), boxflag
INTEGER(c_int), TARGET :: C_pflags(3), C_boxflag
TYPE (c_ptr) :: ptr(7)
ptr = c_null_ptr
IF ( PRESENT(boxlo) ) ptr(1) = C_LOC(boxlo(1))
IF ( PRESENT(boxhi) ) ptr(2) = C_LOC(boxhi(1))
IF ( PRESENT(xy) ) ptr(3) = C_LOC(xy)
IF ( PRESENT(yz) ) ptr(4) = C_LOC(yz)
IF ( PRESENT(xz) ) ptr(5) = C_LOC(xz)
IF ( PRESENT(pflags) ) ptr(6) = C_LOC(C_pflags(1))
IF ( PRESENT(boxflag) ) ptr(7) = C_LOC(C_boxflag)
CALL lammps_extract_box(self%handle, ptr(1), ptr(2), ptr(3), ptr(4), &
ptr(5), ptr(6), ptr(7))
IF ( PRESENT(pflags) ) pflags = ( C_pflags /= 0_C_int )
IF ( PRESENT(boxflag) ) boxflag = ( C_boxflag /= 0_C_int )
END SUBROUTINE lmp_extract_box
! equivalent function to lammps_reset_box
SUBROUTINE lmp_reset_box (self, boxlo, boxhi, xy, yz, xz)
CLASS(lammps), INTENT(IN) :: self
REAL(C_double), INTENT(IN) :: boxlo(3), boxhi(3), xy, yz, xz
CALL lammps_reset_box (self%handle, boxlo, boxhi, xy, yz, xz)
END SUBROUTINE lmp_reset_box
! equivalent function to lammps_memory_usage
SUBROUTINE lmp_memory_usage(self,meminfo)
CLASS(lammps), INTENT(IN) :: self
INTEGER, PARAMETER :: MEMINFO_ELEM = 3
REAL (c_double), DIMENSION(MEMINFO_ELEM), INTENT(OUT) :: meminfo
CALL lammps_memory_usage(self%handle,meminfo)
END SUBROUTINE lmp_memory_usage
! equivalent function to lammps_get_mpi_comm
INTEGER FUNCTION lmp_get_mpi_comm (self)
CLASS(lammps), INTENT(IN) :: self
lmp_get_mpi_comm = lammps_get_mpi_comm(self%handle)
END FUNCTION lmp_get_mpi_comm
! equivalent function to lammps_extract_setting
INTEGER (c_int) FUNCTION lmp_extract_setting (self, keyword)
CLASS(lammps), INTENT(IN) :: self
CHARACTER(LEN=*), INTENT(IN) :: keyword
TYPE(c_ptr) :: Ckeyword
Ckeyword = f2c_string(keyword)
lmp_extract_setting = lammps_extract_setting(self%handle, Ckeyword)
CALL lammps_free(Ckeyword)
END FUNCTION lmp_extract_setting
! equivalent function to lammps_extract_global_datatype
! this function doesn't need to be accessed by the user, but is instead used
! for type checking
INTEGER (c_int) FUNCTION lmp_extract_global_datatype (self, name)
CLASS(lammps), INTENT(IN) :: self
CHARACTER(LEN=*), INTENT(IN) :: name
TYPE(c_ptr) :: Cname
Cname = f2c_string(name)
lmp_extract_global_datatype &
= lammps_extract_global_datatype(self%handle, Cname)
CALL lammps_free(Cname)
END FUNCTION lmp_extract_global_datatype
! equivalent functions to lammps_extract_global (overloaded)
FUNCTION lmp_extract_global_int (self, name, dtype)
CLASS(lammps), INTENT(IN) :: self
CHARACTER(LEN=*), INTENT(IN) :: name
INTEGER(c_int) :: dtype
INTEGER(c_int) :: lmp_extract_global_int
TYPE(c_ptr) :: Cname, Cptr
INTEGER(c_int) :: datatype
INTEGER(c_int), POINTER :: ptr
Cname = f2c_string(name)
datatype = lammps_extract_global_datatype(self%handle, Cname)
IF ( datatype /= LAMMPS_INT ) THEN
! throw an exception or something; data type doesn't match!
END IF
Cptr = lammps_extract_global(self%handle, Cname)
CALL c_f_pointer(Cptr, ptr)
lmp_extract_global_int = ptr
CALL lammps_free(Cname)
END FUNCTION lmp_extract_global_int
! TODO need more generics here to match TKR of LMP_INT_1D, LMP_BIGINT,
! LMP_DOUBLE, LMP_DOUBLE_1D, LMS_STRING [this assumes no one adds anything
! requiring LMP_DOUBLE_2D and the like!]
! equivalent function to lammps_version()
INTEGER FUNCTION lmp_version(self)
IMPLICIT NONE
CLASS(lammps) :: self
lmp_version = lammps_version(self%handle)
END FUNCTION lmp_version
! ----------------------------------------------------------------------
! local helper functions
! copy fortran string to zero terminated c string
! ----------------------------------------------------------------------
FUNCTION f2c_string(f_string) RESULT(ptr)
CHARACTER (LEN=*), INTENT(IN) :: f_string
CHARACTER (LEN=1, KIND=c_char), POINTER :: c_string(:)
TYPE(c_ptr) :: ptr
INTEGER(c_size_t) :: i, n
n = LEN_TRIM(f_string)
ptr = lammps_malloc(n+1)
CALL C_F_POINTER(ptr, c_string, [1])
DO i=1, n
c_string(i) = f_string(i:i)
END DO
c_string(n+1) = c_null_char
END FUNCTION f2c_string
END MODULE LIBLAMMPS