diff --git a/examples/COUPLE/README b/examples/COUPLE/README index 727d2b5367..07e878cbe6 100644 --- a/examples/COUPLE/README +++ b/examples/COUPLE/README @@ -34,5 +34,7 @@ library collection of useful inter-code communication routines simple simple example of driver code calling LAMMPS as library fortran a wrapper on the LAMMPS library API that can be called from Fortran +fortran2 a more sophisticated wrapper on the LAMMPS library API that + can be called from Fortran Each sub-directory has its own README. diff --git a/examples/COUPLE/fortran/README b/examples/COUPLE/fortran/README index 3cbbb7e559..5e5a4fe504 100644 --- a/examples/COUPLE/fortran/README +++ b/examples/COUPLE/fortran/README @@ -1,9 +1,8 @@ libfwrapper.c is a C file that wraps the LAMMPS library API in src/library.h so that it can be called from Fortran. -See the couple/simple/simple.f90 program for an example -of a Fortran code that does this. +See the couple/simple/simple.f90 program for an example of a Fortran +code that does this. -See the README file in that dir for instructions -on how to build a Fortran code that uses this -wrapper and links to the LAMMPS library. +See the README file in that dir for instructions on how to build a +Fortran code that uses this wrapper and links to the LAMMPS library. diff --git a/examples/COUPLE/fortran/libfwrapper.c b/examples/COUPLE/fortran/libfwrapper.c index 69c3ca3226..844324362b 100644 --- a/examples/COUPLE/fortran/libfwrapper.c +++ b/examples/COUPLE/fortran/libfwrapper.c @@ -22,7 +22,7 @@ #include "library.h" /* this is a LAMMPS include file */ /* wrapper for creating a lammps instance from fortran. - since fortran has no simple way to emit a c-compatible + since fortran has no simple way to emit a C-compatible argument array, we don't support it. for simplicity, the address of the pointer to the lammps object is stored in a 64-bit integer on all platforms. */ @@ -109,6 +109,8 @@ void lammps_get_natoms_(int64_t *ptr, MPI_Fint *natoms) /* wrapper to copy coordinates from lammps to fortran */ +/* NOTE: this is now out-of-date, needs to be updated to lammps_gather_atoms() + void lammps_get_coords_(int64_t *ptr, double *coords) { void *obj; @@ -117,8 +119,12 @@ void lammps_get_coords_(int64_t *ptr, double *coords) lammps_get_coords(obj,coords); } +*/ + /* wrapper to copy coordinates from fortran to lammps */ +/* NOTE: this is now out-of-date, needs to be updated to lammps_scatter_atoms() + void lammps_put_coords_(int64_t *ptr, double *coords) { void *obj; @@ -127,3 +133,4 @@ void lammps_put_coords_(int64_t *ptr, double *coords) lammps_put_coords(obj,coords); } +*/ diff --git a/examples/COUPLE/fortran2/LAMMPS-wrapper.cpp b/examples/COUPLE/fortran2/LAMMPS-wrapper.cpp new file mode 100644 index 0000000000..ff6f8cf4ae --- /dev/null +++ b/examples/COUPLE/fortran2/LAMMPS-wrapper.cpp @@ -0,0 +1,235 @@ +/* ----------------------------------------------------------------------- + LAMMPS - Large-scale Atomic/Molecular Massively Parallel Simulator + www.cs.sandia.gov/~sjplimp/lammps.html + Steve Plimpton, sjplimp@sandia.gov, Sandia National Laboratories + + 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. +------------------------------------------------------------------------- */ + +/* ------------------------------------------------------------------------ + Contributing author: Karl D. Hammond + University of Tennessee, Knoxville (USA), 2012 +------------------------------------------------------------------------- */ + +/* This is set of "wrapper" functions to assist LAMMPS.F90, which itself + provides a (I hope) robust Fortran interface to library.cpp and + library.h. All functions herein COULD be added to library.cpp instead of + including this as a separate file. See the README for instructions. */ + +#include +#include "LAMMPS-wrapper.h" +#include +#include +#include +#include +#include +#include +#include + +using namespace LAMMPS_NS; + +void lammps_open_fortran_wrapper (int argc, char **argv, + MPI_Fint communicator, void **ptr) +{ + MPI_Comm C_communicator = MPI_Comm_f2c (communicator); + lammps_open (argc, argv, C_communicator, ptr); +} + +int lammps_get_ntypes (void *ptr) +{ + class LAMMPS *lmp = (class LAMMPS *) ptr; + int ntypes = lmp->atom->ntypes; + return ntypes; +} + +void lammps_error_all (void *ptr, const char *file, int line, const char *str) +{ + class LAMMPS *lmp = (class LAMMPS *) ptr; + lmp->error->all (file, line, str); +} + +int lammps_extract_compute_vectorsize (void *ptr, char *id, int style) +{ + class LAMMPS *lmp = (class LAMMPS *) ptr; + int icompute = lmp->modify->find_compute(id); + if ( icompute < 0 ) return 0; + class Compute *compute = lmp->modify->compute[icompute]; + + if ( style == 0 ) + { + if ( !compute->vector_flag ) + return 0; + else + return compute->size_vector; + } + else if ( style == 1 ) + { + return lammps_get_natoms (ptr); + } + else if ( style == 2 ) + { + if ( !compute->local_flag ) + return 0; + else + return compute->size_local_rows; + } + else + return 0; +} + +void lammps_extract_compute_arraysize (void *ptr, char *id, int style, + int *nrows, int *ncols) +{ + class LAMMPS *lmp = (class LAMMPS *) ptr; + int icompute = lmp->modify->find_compute(id); + if ( icompute < 0 ) + { + *nrows = 0; + *ncols = 0; + } + class Compute *compute = lmp->modify->compute[icompute]; + + if ( style == 0 ) + { + if ( !compute->array_flag ) + { + *nrows = 0; + *ncols = 0; + } + else + { + *nrows = compute->size_array_rows; + *ncols = compute->size_array_cols; + } + } + else if ( style == 1 ) + { + if ( !compute->peratom_flag ) + { + *nrows = 0; + *ncols = 0; + } + else + { + *nrows = lammps_get_natoms (ptr); + *ncols = compute->size_peratom_cols; + } + } + else if ( style == 2 ) + { + if ( !compute->local_flag ) + { + *nrows = 0; + *ncols = 0; + } + else + { + *nrows = compute->size_local_rows; + *ncols = compute->size_local_cols; + } + } + else + { + *nrows = 0; + *ncols = 0; + } + + return; +} + +int lammps_extract_fix_vectorsize (void *ptr, char *id, int style) +{ + class LAMMPS *lmp = (class LAMMPS *) ptr; + int ifix = lmp->modify->find_fix(id); + if ( ifix < 0 ) return 0; + class Fix *fix = lmp->modify->fix[ifix]; + + if ( style == 0 ) + { + if ( !fix->vector_flag ) + return 0; + else + return fix->size_vector; + } + else if ( style == 1 ) + { + return lammps_get_natoms (ptr); + } + else if ( style == 2 ) + { + if ( !fix->local_flag ) + return 0; + else + return fix->size_local_rows; + } + else + return 0; +} + +void lammps_extract_fix_arraysize (void *ptr, char *id, int style, + int *nrows, int *ncols) +{ + class LAMMPS *lmp = (class LAMMPS *) ptr; + int ifix = lmp->modify->find_fix(id); + if ( ifix < 0 ) + { + *nrows = 0; + *ncols = 0; + } + class Fix *fix = lmp->modify->fix[ifix]; + + if ( style == 0 ) + { + if ( !fix->array_flag ) + { + *nrows = 0; + *ncols = 0; + } + else + { + *nrows = fix->size_array_rows; + *ncols = fix->size_array_cols; + } + } + else if ( style == 1 ) + { + if ( !fix->peratom_flag ) + { + *nrows = 0; + *ncols = 0; + } + else + { + *nrows = lammps_get_natoms (ptr); + *ncols = fix->size_peratom_cols; + } + } + else if ( style == 2 ) + { + if ( !fix->local_flag ) + { + *nrows = 0; + *ncols = 0; + } + else + { + *nrows = fix->size_local_rows; + *ncols = fix->size_local_cols; + } + } + else + { + *nrows = 0; + *ncols = 0; + } + + return; + +} + +/* vim: set ts=3 sts=3 expandtab: */ diff --git a/examples/COUPLE/fortran2/LAMMPS-wrapper.h b/examples/COUPLE/fortran2/LAMMPS-wrapper.h new file mode 100644 index 0000000000..dce39cad89 --- /dev/null +++ b/examples/COUPLE/fortran2/LAMMPS-wrapper.h @@ -0,0 +1,47 @@ +/* ----------------------------------------------------------------------- + LAMMPS - Large-scale Atomic/Molecular Massively Parallel Simulator + www.cs.sandia.gov/~sjplimp/lammps.html + Steve Plimpton, sjplimp@sandia.gov, Sandia National Laboratories + + 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. +------------------------------------------------------------------------- */ + +/* ------------------------------------------------------------------------ + Contributing author: Karl D. Hammond + University of Tennessee, Knoxville (USA), 2012 +------------------------------------------------------------------------- */ + +/* This is set of "wrapper" functions to assist LAMMPS.F90, which itself + provides a (I hope) robust Fortran interface to library.cpp and + library.h. All prototypes herein COULD be added to library.h instead of + including this as a separate file. See the README for instructions. */ + +/* These prototypes probably belong in mpi.h in the src/STUBS directory. */ +#ifndef OPEN_MPI +#define MPI_Comm_f2c(a) a +#define MPI_Fint int +#endif + +#ifdef __cplusplus +extern "C" { +#endif + +/* Prototypes for auxiliary functions */ +void lammps_open_fortran_wrapper (int, char**, MPI_Fint, void**); +int lammps_get_ntypes (void*); +int lammps_extract_compute_vectorsize (void*, char*, int); +void lammps_extract_compute_arraysize (void*, char*, int, int*, int*); +int lammps_extract_fix_vectorsize (void*, char*, int); +void lammps_extract_fix_arraysize (void*, char*, int, int*, int*); +void lammps_error_all (void *ptr, const char*, int, const char*); + +#ifdef __cplusplus +} +#endif + +/* vim: set ts=3 sts=3 expandtab: */ diff --git a/examples/COUPLE/fortran2/LAMMPS.F90 b/examples/COUPLE/fortran2/LAMMPS.F90 new file mode 100644 index 0000000000..3d07a55feb --- /dev/null +++ b/examples/COUPLE/fortran2/LAMMPS.F90 @@ -0,0 +1,1094 @@ +!! ----------------------------------------------------------------------- +! LAMMPS - Large-scale Atomic/Molecular Massively Parallel Simulator +! www.cs.sandia.gov/~sjplimp/lammps.html +! Steve Plimpton, sjplimp@sandia.gov, Sandia National Laboratories +! +! 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. +!-------------------------------------------------------------------------- + +!! ------------------------------------------------------------------------ +! Contributing author: Karl D. Hammond +! University of Tennessee, Knoxville (USA), 2012 +!-------------------------------------------------------------------------- + +!! LAMMPS, a Fortran 2003 module containing an interface between Fortran +!! programs and the C-style functions in library.cpp that ship with LAMMPS. +!! This file should be accompanied by LAMMPS-wrapper.cpp and LAMMPS-wrapper.h, +!! which define wrapper functions that ease portability and enforce array +!! dimensions. +!! +!! Everything in this module should be 100% portable by way of Fortran 2003's +!! ISO_C_BINDING intrinsic module. See the README for instructions for +!! compilation and use. +!! +!! Here are the PUBLIC functions and subroutines included in this module. +!! subroutine lammps_open (command_line, communicator, ptr) +!! subroutine lammps_open_no_mpi (command_line, ptr) +!! subroutine lammps_close (ptr) +!! subroutine lammps_file (ptr, str) +!! subroutine lammps_command (ptr, str) +!! subroutine lammps_free (ptr) +!! subroutine lammps_extract_global (global, ptr, name) +!! subroutine lammps_extract_atom (atom, ptr, name) +!! subroutine lammps_extract_fix (fix, ptr, id, style, type, i, j) +!! subroutine lammps_extract_compute (compute, ptr, id, style, type) +!! subroutine lammps_extract_variable (variable, ptr, name, group) +!! function lammps_get_natoms (ptr) +!! subroutine lammps_get_coords (ptr, coords) +!! subroutine lammps_put_coords (ptr, coords) + +#define FLERR __FILE__,__LINE__ +! The above line allows for similar error checking as is done with standard +! LAMMPS files. + +module LAMMPS + + use, intrinsic :: ISO_C_binding, only : C_double, C_int, C_ptr, C_char, & + C_NULL_CHAR, C_loc, C_F_pointer, lammps_instance => C_ptr + implicit none + private + public :: lammps_open, lammps_open_no_mpi, lammps_close, lammps_file, & + lammps_command, lammps_free, lammps_extract_global, & + lammps_extract_atom, lammps_extract_compute, lammps_extract_fix, & + lammps_extract_variable, lammps_get_natoms, lammps_get_coords, & + lammps_put_coords, lammps_instance + + !! Functions supplemental to the prototypes in library.h. {{{1 + !! The function definitions (in C++) are contained in LAMMPS-wrapper.cpp. + !! I would have written the first in Fortran, but the MPI libraries (which + !! were written in C) have C-based functions to convert from Fortran MPI + !! handles to C MPI handles, and there is no Fortran equivalent for those + !! functions. + interface + subroutine lammps_open_wrapper (argc, argv, communicator, ptr) & + bind (C, name='lammps_open_fortran_wrapper') + import :: C_int, C_ptr + integer (C_int), value :: argc + type (C_ptr), dimension(*) :: argv + integer, value :: communicator + type (C_ptr) :: ptr + end subroutine lammps_open_wrapper + subroutine lammps_actual_error_all (ptr, file, line, str) & + bind (C, name='lammps_error_all') + import :: C_int, C_char, C_ptr + type (C_ptr), value :: ptr + character (kind=C_char), dimension(*), intent(in) :: file, str + integer (C_int), value :: line + end subroutine lammps_actual_error_all + function lammps_get_ntypes (ptr) result (ntypes) & + bind (C, name='lammps_get_ntypes') + import :: C_int, C_ptr + type (C_ptr), value :: ptr + integer (C_int) :: ntypes + end function lammps_get_ntypes + function lammps_actual_extract_compute_vectorsize (ptr, id, style) & + result (vectorsize) bind (C, name='lammps_extract_compute_vectorsize') + import :: C_int, C_char, C_ptr + integer (C_int) :: vectorsize + type (C_ptr), value :: ptr + character (kind=C_char), dimension(*) :: id + integer (C_int), value :: style + end function lammps_actual_extract_compute_vectorsize + subroutine lammps_actual_extract_compute_arraysize (ptr, id, style, & + nrows, ncols) bind (C, name='lammps_extract_compute_arraysize') + import :: C_int, C_char, C_ptr + integer (C_int) :: arraysize + type (C_ptr), value :: ptr + character (kind=C_char), dimension(*) :: id + integer (C_int), value :: style + integer (C_int) :: nrows, ncols + end subroutine lammps_actual_extract_compute_arraysize + function lammps_actual_extract_fix_vectorsize (ptr, id, style) & + result (vectorsize) bind (C, name='lammps_extract_fix_vectorsize') + import :: C_int, C_char, C_ptr + integer (C_int) :: vectorsize + type (C_ptr), value :: ptr + character (kind=C_char), dimension(*) :: id + integer (C_int), value :: style + end function lammps_actual_extract_fix_vectorsize + subroutine lammps_actual_extract_fix_arraysize (ptr, id, style, & + nrows, ncols) bind (C, name='lammps_extract_fix_arraysize') + import :: C_int, C_char, C_ptr + type (C_ptr), value :: ptr + character (kind=C_char), dimension(*) :: id + integer (C_int), value :: style + integer (C_int) :: nrows, ncols + end subroutine lammps_actual_extract_fix_arraysize + end interface + + !! Functions/subroutines defined in library.h and library.cpp {{{1 + interface + subroutine lammps_actual_open_no_mpi (argc, argv, ptr) & + bind (C, name='lammps_open_no_mpi') + import :: C_int, C_ptr + integer (C_int), value :: argc + type (C_ptr), dimension(*) :: argv + type (C_ptr) :: ptr + end subroutine lammps_actual_open_no_mpi + + subroutine lammps_close (ptr) bind (C, name='lammps_close') + import :: C_ptr + type (C_ptr), value :: ptr + end subroutine lammps_close + + subroutine lammps_actual_file (ptr, str) bind (C, name='lammps_file') + import :: C_ptr, C_char + type (C_ptr), value :: ptr + character (kind=C_char), dimension(*) :: str + end subroutine lammps_actual_file + + function lammps_actual_command (ptr, str) result (command) & + bind (C, name='lammps_command') + import :: C_ptr, C_char + type (C_ptr), value :: ptr + character (kind=C_char), dimension(*) :: str + type (C_ptr) :: command + end function lammps_actual_command + + subroutine lammps_free (ptr) bind (C, name='lammps_free') + import :: C_ptr + type (C_ptr), value :: ptr + end subroutine lammps_free + + function lammps_actual_extract_global (ptr, name) & + bind (C, name='lammps_extract_global') result (global) + import :: C_ptr, C_char + type (C_ptr), value :: ptr + character (kind=C_char), dimension(*) :: name + type (C_ptr) :: global + end function lammps_actual_extract_global + + function lammps_actual_extract_atom (ptr, name) & + bind (C, name='lammps_extract_atom') result (atom) + import :: C_ptr, C_char + type (C_ptr), value :: ptr + character (kind=C_char), dimension(*) :: name + type (C_ptr) :: atom + end function lammps_actual_extract_atom + + function lammps_actual_extract_compute (ptr, id, style, type) & + result (compute) bind (C, name='lammps_extract_compute') + import :: C_ptr, C_char, C_int + type (C_ptr), value :: ptr + character (kind=C_char), dimension(*) :: id + integer (C_int), value :: style, type + type (C_ptr) :: compute + end function lammps_actual_extract_compute + + function lammps_actual_extract_fix (ptr, id, style, type, i, j) & + result (fix) bind (C, name='lammps_extract_fix') + import :: C_ptr, C_char, C_int + type (C_ptr), value :: ptr + character (kind=C_char), dimension(*) :: id + integer (C_int), value :: style, type, i, j + type (C_ptr) :: fix + end function lammps_actual_extract_fix + + function lammps_actual_extract_variable (ptr, name, group) & + result (variable) bind (C, name='lammps_extract_variable') + import :: C_ptr, C_char + type (C_ptr), value :: ptr + character (kind=C_char), dimension(*) :: name, group + type (C_ptr) :: variable + end function lammps_actual_extract_variable + + function lammps_get_natoms (ptr) result (natoms) & + bind (C, name='lammps_get_natoms') + import :: C_ptr, C_int + type (C_ptr), value :: ptr + integer (C_int) :: natoms + end function lammps_get_natoms + + subroutine lammps_actual_get_coords (ptr, coords) & + bind (C, name='lammps_get_coords') + import :: C_ptr + type (C_ptr), value :: ptr, coords + end subroutine lammps_actual_get_coords + + subroutine lammps_actual_put_coords (ptr, coords) & + bind (C, name='lammps_put_coords') + import :: C_ptr, C_double + type (C_ptr), value :: ptr + real (C_double), dimension(*) :: coords + end subroutine lammps_actual_put_coords + end interface + + ! Generic functions for the wrappers below {{{1 + + ! Check the dimensions of the arrays these return; they are not always + ! easy to find. Note that I consider returning pointers to arbitrary + ! memory locations with no information as to array size/shape to be + ! extremely sloppy and error-prone. It would appear the Fortran standards + ! committee would agree, as they chose not to allow that sort of nonsense. + + interface lammps_extract_global + module procedure lammps_extract_global_i, lammps_extract_global_r, & + lammps_extract_global_dp + end interface lammps_extract_global + + interface lammps_extract_atom + module procedure lammps_extract_atom_ia, lammps_extract_atom_ra, & + lammps_extract_atom_dpa, lammps_extract_atom_dp2a, & + lammps_extract_atom_r2a + end interface lammps_extract_atom + + interface lammps_extract_compute + module procedure lammps_extract_compute_r, lammps_extract_compute_dp, & + lammps_extract_compute_ra, lammps_extract_compute_dpa, & + lammps_extract_compute_r2a, lammps_extract_compute_dp2a + end interface lammps_extract_compute + + interface lammps_extract_fix + module procedure lammps_extract_fix_r, lammps_extract_fix_dp, & + lammps_extract_fix_ra, lammps_extract_fix_dpa, & + lammps_extract_fix_r2a, lammps_extract_fix_dp2a + end interface lammps_extract_fix + + interface lammps_extract_variable + module procedure lammps_extract_variable_i, & + lammps_extract_variable_dp, & + lammps_extract_variable_r, & + lammps_extract_variable_ra, & + lammps_extract_variable_ia, & + lammps_extract_variable_dpa + end interface lammps_extract_variable + +contains !! Wrapper functions local to this module {{{1 + + subroutine lammps_open (command_line, communicator, ptr) + character (len=*), intent(in) :: command_line + integer, intent(in) :: communicator + type (C_ptr) :: ptr + integer (C_int) :: argc + type (C_ptr), dimension(:), allocatable :: argv + character (kind=C_char), dimension(len_trim(command_line)+1), target :: & + c_command_line + c_command_line = string2Cstring (command_line) + call Cstring2argcargv (c_command_line, argc, argv) + call lammps_open_wrapper (argc, argv, communicator, ptr) + deallocate (argv) + end subroutine lammps_open + +!----------------------------------------------------------------------------- + + subroutine lammps_open_no_mpi (command_line, ptr) + character (len=*), intent(in) :: command_line + type (C_ptr) :: ptr + integer (C_int) :: argc + type (C_ptr), dimension(:), allocatable :: argv + character (kind=C_char), dimension(len_trim(command_line)+1), target :: & + c_command_line + c_command_line = string2Cstring (command_line) + call Cstring2argcargv (c_command_line, argc, argv) + call lammps_actual_open_no_mpi (argc, argv, ptr) + deallocate (argv) + end subroutine lammps_open_no_mpi + +!----------------------------------------------------------------------------- + + subroutine lammps_file (ptr, str) + type (C_ptr) :: ptr + character (len=*) :: str + character (kind=C_char), dimension(len_trim(str)+1) :: Cstr + Cstr = string2Cstring (str) + call lammps_actual_file (ptr, Cstr) + end subroutine lammps_file + +!----------------------------------------------------------------------------- + + subroutine lammps_command (ptr, str) + type (C_ptr) :: ptr + character (len=*) :: str + character (kind=C_char), dimension(len_trim(str)+1) :: Cstr + type (C_ptr) :: dummy + Cstr = string2Cstring (str) + dummy = lammps_actual_command (ptr, Cstr) + end subroutine lammps_command + +!----------------------------------------------------------------------------- + +! lammps_extract_global {{{2 + function lammps_extract_global_Cptr (ptr, name) result (global) + type (C_ptr) :: global + type (C_ptr), intent(in) :: ptr + character (len=*), intent(in) :: name + character (kind=C_char), dimension(len_trim(name)+1) :: Cname + Cname = string2Cstring (name) + global = lammps_actual_extract_global (ptr, Cname) + end function lammps_extract_global_Cptr + subroutine lammps_extract_global_i (global, ptr, name) + integer, intent(out) :: global + type (C_ptr), intent(in) :: ptr + character (len=*), intent(in) :: name + type (C_ptr) :: Cptr + integer (C_int), pointer :: Fptr + Cptr = lammps_extract_global_Cptr (ptr, name) + call C_F_pointer (Cptr, Fptr) + global = Fptr + nullify (Fptr) + end subroutine lammps_extract_global_i + subroutine lammps_extract_global_dp (global, ptr, name) + double precision, intent(out) :: global + type (C_ptr), intent(in) :: ptr + character (len=*), intent(in) :: name + type (C_ptr) :: Cptr + real (C_double), pointer :: Fptr + Cptr = lammps_extract_global_Cptr (ptr, name) + call C_F_pointer (Cptr, Fptr) + global = Fptr + nullify (Fptr) + end subroutine lammps_extract_global_dp + subroutine lammps_extract_global_r (global, ptr, name) + real :: global + type (C_ptr), intent(in) :: ptr + character (len=*), intent(in) :: name + type (C_ptr) :: Cptr + real (C_double), pointer :: Fptr + Cptr = lammps_extract_global_Cptr (ptr, name) + call C_F_pointer (Cptr, Fptr) + global = real (Fptr) + nullify (Fptr) + end subroutine lammps_extract_global_r + +!----------------------------------------------------------------------------- + +! lammps_extract_atom {{{2 + function lammps_extract_atom_Cptr (ptr, name) result (atom) + type (C_ptr) :: atom + type (C_ptr), intent(in) :: ptr + character (len=*), intent(in) :: name + character (kind=C_char), dimension(len_trim(name)+1) :: Cname + Cname = string2Cstring (name) + atom = lammps_actual_extract_atom (ptr, Cname) + end function lammps_extract_atom_Cptr + subroutine lammps_extract_atom_ia (atom, ptr, name) + integer, dimension(:), allocatable, intent(out) :: atom + type (C_ptr), intent(in) :: ptr + character (len=*), intent(in) :: name + type (C_ptr) :: Cptr + integer (C_int), pointer :: Fptr + integer :: natoms + natoms = lammps_get_natoms (ptr) + if ( allocated (atom) ) deallocate (atom) + allocate (atom(natoms)) + Cptr = lammps_extract_atom_Cptr (ptr, name) + call C_F_pointer (Cptr, Fptr, (/natoms/)) + atom = Fptr + nullify (Fptr) + end subroutine lammps_extract_atom_ia + subroutine lammps_extract_atom_dpa (atom, ptr, name) + double precision, dimension(:), allocatable, intent(out) :: atom + type (C_ptr), intent(in) :: ptr + character (len=*), intent(in) :: name + type (C_ptr) :: Cptr + real (C_double), dimension(:), pointer :: Fptr + integer :: nelements + if ( name == 'mass' ) then + nelements = lammps_get_ntypes (ptr) + else if ( name == 'x' .or. name == 'v' .or. name == 'f' ) then + ! We should not be getting 'x' or 'v' or 'f' here! + call lammps_error_all (ptr, FLERR, 'You cannot extract those atom& + & data (x, v, or f) into a rank 1 array.') + return + else + ! Everything else we can get is probably nlocal units long + call lammps_extract_global_i (nelements, ptr, 'nlocal') + end if + if ( allocated (atom) ) deallocate (atom) + allocate (atom(nelements)) + Cptr = lammps_extract_atom_Cptr (ptr, name) + if ( name == 'mass' ) then + call C_F_pointer (Cptr, Fptr, (/nelements + 1/)) + atom = Fptr(2:) ! LAMMPS starts numbering at 1 (C does not) + else + call C_F_pointer (Cptr, Fptr, (/nelements/)) + atom = Fptr + end if + nullify (Fptr) + end subroutine lammps_extract_atom_dpa + subroutine lammps_extract_atom_ra (atom, ptr, name) + real, dimension(:), allocatable, intent(out) :: atom + type (C_ptr), intent(in) :: ptr + character (len=*), intent(in) :: name + double precision, dimension(:), allocatable :: d_atom + call lammps_extract_atom_dpa (d_atom, ptr, name) + if ( allocated (atom) ) deallocate (atom) + allocate (atom(size(d_atom))) + atom = real(d_atom) + deallocate (d_atom) + end subroutine lammps_extract_atom_ra + subroutine lammps_extract_atom_dp2a (atom, ptr, name) + double precision, dimension(:,:), allocatable, intent(out) :: atom + type (C_ptr), intent(in) :: ptr + character (len=*), intent(in) :: name + type (C_ptr) :: Cptr + integer :: nelements + if ( allocated (atom) ) deallocate (atom) + if ( name /= 'x' .and. name /= 'v' .and. name /= 'f' ) then + call lammps_error_all (ptr, FLERR, 'You cannot extract ' // name // & + ' into a rank 2 array.') + return + end if + Cptr = lammps_extract_atom_Cptr (ptr, name) + nelements = lammps_get_natoms (ptr) + allocate (atom(nelements,3)) + atom = Cdoublestar_to_2darray (Cptr, nelements, 3) + end subroutine lammps_extract_atom_dp2a + subroutine lammps_extract_atom_r2a (atom, ptr, name) + real, dimension(:,:), allocatable, intent(out) :: atom + type (C_ptr), intent(in) :: ptr + character (len=*), intent(in) :: name + double precision, dimension(:,:), allocatable :: d_atom + call lammps_extract_atom_dp2a (d_atom, ptr, name) + if ( allocated (atom) ) deallocate (atom) + if ( allocated (d_atom) ) then + allocate (atom(size(d_atom,1), size(d_atom,2))) + else + return + end if + atom = real(d_atom) + deallocate (d_atom) + end subroutine lammps_extract_atom_r2a + +!----------------------------------------------------------------------------- + +! lammps_extract_compute {{{2 + function lammps_extract_compute_Cptr (ptr, id, style, type) result (compute) + type (C_ptr) :: compute + type (C_ptr), intent(in) :: ptr + character (len=*), intent(in) :: id + integer, intent(in) :: style, type + integer (kind=C_int) :: Cstyle, Ctype + character (kind=C_char), dimension(len_trim(id)+1) :: Cid + Cid = string2Cstring (id) + Cstyle = style + Ctype = type + compute = lammps_actual_extract_compute (ptr, Cid, Cstyle, Ctype) + end function lammps_extract_compute_Cptr + subroutine lammps_extract_compute_dp (compute, ptr, id, style, type) + double precision, intent(out) :: compute + type (C_ptr), intent(in) :: ptr + character (len=*), intent(in) :: id + integer, intent(in) :: style, type + type (C_ptr) :: Cptr + real (C_double), pointer :: Fptr + ! The only valid values of (style,type) are (0,0) for scalar 'compute' + if ( style /= 0 ) then + call lammps_error_all (ptr, FLERR, 'You cannot pack per-atom/local& + & data into a scalar.') + return + end if + if ( type == 1 ) then + call lammps_error_all (ptr, FLERR, 'You cannot extract a compute& + & vector (rank 1) into a scalar.') + return + else if ( type == 2 ) then + call lammps_error_all (ptr, FLERR, 'You cannot extract a compute& + & array (rank 2) into a scalar.') + return + end if + Cptr = lammps_extract_compute_Cptr (ptr, id, style, type) + call C_F_pointer (Cptr, Fptr) + compute = Fptr + nullify (Fptr) + ! C pointer should not be freed! + end subroutine lammps_extract_compute_dp + subroutine lammps_extract_compute_r (compute, ptr, id, style, type) + real, intent(out) :: compute + type (C_ptr), intent(in) :: ptr + character (len=*), intent(in) :: id + integer, intent(in) :: style, type + double precision :: d_compute + call lammps_extract_compute_dp (d_compute, ptr, id, style, type) + compute = real(d_compute) + end subroutine lammps_extract_compute_r + subroutine lammps_extract_compute_dpa (compute, ptr, id, style, type) + double precision, dimension(:), allocatable, intent(out) :: compute + type (C_ptr), intent(in) :: ptr + character (len=*), intent(in) :: id + integer, intent(in) :: style, type + type (C_ptr) :: Cptr + real (C_double), dimension(:), pointer :: Fptr + integer :: nelements + if ( allocated (compute) ) deallocate (compute) + ! Check for the correct dimensionality + if ( type == 0 ) then + call lammps_error_all (ptr, FLERR, 'You cannot extract a compute& + & scalar (rank 0) into a rank 1 variable.') + return + else if ( type == 2 ) then + call lammps_error_all (ptr, FLERR, 'You cannot extract a compute& + & array (rank 2) into a rank 1 variable.') + return + end if + nelements = lammps_extract_compute_vectorsize (ptr, id, style) + allocate (compute(nelements)) + Cptr = lammps_extract_compute_Cptr (ptr, id, style, type) + call C_F_pointer (Cptr, Fptr, (/nelements/)) + compute = Fptr + nullify (Fptr) + ! C pointer should not be freed + end subroutine lammps_extract_compute_dpa + subroutine lammps_extract_compute_ra (compute, ptr, id, style, type) + real, dimension(:), allocatable, intent(out) :: compute + type (C_ptr), intent(in) :: ptr + character (len=*), intent(in) :: id + integer, intent(in) :: style, type + double precision, dimension(:), allocatable :: d_compute + call lammps_extract_compute_dpa (d_compute, ptr, id, style, type) + if ( allocated (compute) ) deallocate (compute) + allocate (compute(size(d_compute))) + compute = real(d_compute) + deallocate (d_compute) + end subroutine lammps_extract_compute_ra + subroutine lammps_extract_compute_dp2a (compute, ptr, id, style, type) + double precision, dimension(:,:), allocatable, intent(out) :: compute + type (C_ptr), intent(in) :: ptr + character (len=*), intent(in) :: id + integer, intent(in) :: style, type + type (C_ptr) :: Cptr + real (C_double), dimension(:,:), pointer :: Fptr + integer :: nr, nc + if ( allocated (compute) ) deallocate (compute) + ! Check for the correct dimensionality + if ( type == 0 ) then + call lammps_error_all (ptr, FLERR, 'You cannot extract a compute& + & scalar (rank 0) into a rank 2 variable.') + return + else if ( type == 1 ) then + call lammps_error_all (ptr, FLERR, 'You cannot extract a compute& + & array (rank 1) into a rank 2 variable.') + return + end if + call lammps_extract_compute_arraysize (ptr, id, style, nr, nc) + allocate (compute(nr, nc)) + Cptr = lammps_extract_compute_Cptr (ptr, id, style, type) + call C_F_pointer (Cptr, Fptr, (/nr, nc/)) + compute = Fptr + nullify (Fptr) + ! C pointer should not be freed + end subroutine lammps_extract_compute_dp2a + subroutine lammps_extract_compute_r2a (compute, ptr, id, style, type) + real, dimension(:,:), allocatable, intent(out) :: compute + type (C_ptr), intent(in) :: ptr + character (len=*), intent(in) :: id + integer, intent(in) :: style, type + double precision, dimension(:,:), allocatable :: d_compute + call lammps_extract_compute_dp2a (d_compute, ptr, id, style, type) + if ( allocated (compute) ) deallocate (compute) + allocate (compute(size(d_compute,1), size(d_compute,2))) + compute = real(d_compute) + deallocate (d_compute) + end subroutine lammps_extract_compute_r2a + +!----------------------------------------------------------------------------- + +! lammps_extract_fix {{{2 + function lammps_extract_fix_Cptr (ptr, id, style, type, i, j) & + result (fix) + type (C_ptr) :: fix + type (C_ptr), intent(in) :: ptr + character (len=*), intent(in) :: id + integer, intent(in) :: style, type, i, j + character (kind=C_char), dimension(len_trim(id)+1) :: Cid + integer (kind=C_int) :: Cstyle, Ctype, Ci, Cj + Cid = string2Cstring (id) + Cstyle = style + Ctype = type + Ci = i - 1 ! This is for consistency with the values from f_ID[i], + Cj = j - 1 ! which is different from what library.cpp uses! + if ( (type >= 1 .and. Ci < 0) .or. & + (type == 2 .and. (Ci < 0 .or. Cj < 0) ) ) then + call lammps_error_all (ptr, FLERR, 'Index out of range in& + & lammps_extract_fix') + end if + fix = lammps_actual_extract_fix (ptr, Cid, Cstyle, Ctype, Ci, Cj) + end function lammps_extract_fix_Cptr + subroutine lammps_extract_fix_dp (fix, ptr, id, style, type, i, j) + double precision, intent(out) :: fix + type (C_ptr), intent(in) :: ptr + character (len=*), intent(in) :: id + integer, intent(in) :: style, type, i, j + type (C_ptr) :: Cptr + real (C_double), pointer :: Fptr + ! Check for the correct dimensionality + if ( style /= 0 ) then + select case (type) + case (0) + call lammps_error_all (ptr, FLERR, 'There is no per-atom or local& + & scalar data available from fixes.') + case (1) + call lammps_error_all (ptr, FLERR, 'You cannot extract a fix''s & + &per-atom/local vector (rank 1) into a scalar.') + case (2) + call lammps_error_all (ptr, FLERR, 'You cannot extract a fix''s & + &per-atom/local array (rank 2) into a scalar.') + case default + call lammps_error_all (ptr, FLERR, 'Invalid extract_fix style& + & value.') + end select + return + end if + Cptr = lammps_extract_fix_Cptr (ptr, id, style, type, i, j) + call C_F_pointer (Cptr, Fptr) + fix = Fptr + nullify (Fptr) + ! Memory is only allocated for "global" fix variables + if ( style == 0 ) call lammps_free (Cptr) + end subroutine lammps_extract_fix_dp + subroutine lammps_extract_fix_r (fix, ptr, id, style, type, i, j) + real, intent(out) :: fix + type (C_ptr), intent(in) :: ptr + character (len=*), intent(in) :: id + integer, intent(in) :: style, type, i, j + double precision :: d_fix + call lammps_extract_fix_dp (d_fix, ptr, id, style, type, i, j) + fix = real(d_fix) + end subroutine lammps_extract_fix_r + subroutine lammps_extract_fix_dpa (fix, ptr, id, style, type, i, j) + double precision, dimension(:), allocatable, intent(out) :: fix + type (C_ptr), intent(in) :: ptr + character (len=*), intent(in) :: id + integer, intent(in) :: style, type, i, j + type (C_ptr) :: Cptr + real (C_double), dimension(:), pointer :: Fptr + integer :: fix_len + if ( allocated (fix) ) deallocate (fix) + ! Check for the correct dimensionality + if ( style == 0 ) then + call lammps_error_all (ptr, FLERR, 'You can''t extract the& + & whole vector from global fix data') + return + else if ( type == 0 ) then + call lammps_error_all (ptr, FLERR, 'You can''t extract a fix& + & scalar into a rank 1 variable') + return + else if ( type == 2 ) then + call lammps_error_all (ptr, FLERR, 'You cannot extract a fix& + & array into a rank 1 variable.') + return + else if ( type /= 1 ) then + call lammps_error_all (ptr, FLERR, 'Invalid type for fix extraction.') + return + end if + fix_len = lammps_extract_fix_vectorsize (ptr, id, style) + allocate (fix(fix_len)) + Cptr = lammps_extract_fix_Cptr (ptr, id, style, type, i, j) + call C_F_pointer (Cptr, Fptr, (/fix_len/)) + fix = Fptr + nullify (Fptr) + ! Memory is only allocated for "global" fix variables + if ( style == 0 ) call lammps_free (Cptr) + end subroutine lammps_extract_fix_dpa + subroutine lammps_extract_fix_ra (fix, ptr, id, style, type, i, j) + real, dimension(:), allocatable, intent(out) :: fix + type (C_ptr), intent(in) :: ptr + character (len=*), intent(in) :: id + integer, intent(in) :: style, type, i, j + double precision, dimension(:), allocatable :: d_fix + call lammps_extract_fix_dpa (d_fix, ptr, id, style, type, i, j) + if ( allocated (fix) ) deallocate (fix) + allocate (fix(size(d_fix))) + fix = real(d_fix) + deallocate (d_fix) + end subroutine lammps_extract_fix_ra + subroutine lammps_extract_fix_dp2a (fix, ptr, id, style, type, i, j) + double precision, dimension(:,:), allocatable, intent(out) :: fix + type (C_ptr), intent(in) :: ptr + character (len=*), intent(in) :: id + integer, intent(in) :: style, type, i, j + type (C_ptr) :: Cptr + real (C_double), dimension(:,:), pointer :: Fptr + integer :: nr, nc + if ( allocated (fix) ) deallocate (fix) + ! Check for the correct dimensionality + if ( style == 0 ) then + call lammps_error_all (ptr, FLERR, 'It is not possible to extract the& + & entire array from global fix data.') + return + else if ( type == 0 ) then + call lammps_error_all (ptr, FLERR, 'You cannot extract a fix& + & scalar (rank 0) into a rank 2 variable.') + return + else if ( type == 1 ) then + call lammps_error_all (ptr, FLERR, 'You cannot extract a fix& + & vector (rank 1) into a rank 2 variable.') + return + end if + call lammps_extract_fix_arraysize (ptr, id, style, nr, nc) + allocate (fix(nr, nc)) + Cptr = lammps_extract_fix_Cptr (ptr, id, style, type, i, j) + call C_F_pointer (Cptr, Fptr, (/nr, nc/)) + fix = Fptr + nullify (Fptr) + ! C pointer should not be freed + end subroutine lammps_extract_fix_dp2a + subroutine lammps_extract_fix_r2a (fix, ptr, id, style, type, i, j) + real, dimension(:,:), allocatable, intent(out) :: fix + type (C_ptr), intent(in) :: ptr + character (len=*), intent(in) :: id + integer, intent(in) :: style, type, i, j + double precision, dimension(:,:), allocatable :: d_fix + call lammps_extract_fix_dp2a (d_fix, ptr, id, style, type, i, j) + if ( allocated (fix) ) deallocate (fix) + allocate (fix(size(d_fix,1), size(d_fix,2))) + fix = real(d_fix) + deallocate (d_fix) + end subroutine lammps_extract_fix_r2a + +!----------------------------------------------------------------------------- + +! lammps_extract_variable {{{2 + function lammps_extract_variable_Cptr (ptr, name, group) result (variable) + type (C_ptr) :: ptr, variable + character (len=*) :: name + character (len=*), optional :: group + character (kind=C_char), dimension(len_trim(name)+1) :: Cname + character (kind=C_char), dimension(:), allocatable :: Cgroup + Cname = string2Cstring (name) + if ( present(group) ) then + allocate (Cgroup(len_trim(group)+1)) + Cgroup = string2Cstring (group) + else + allocate (Cgroup(1)) + Cgroup(1) = C_NULL_CHAR + end if + variable = lammps_actual_extract_variable (ptr, Cname, Cgroup) + deallocate (Cgroup) + end function lammps_extract_variable_Cptr + subroutine lammps_extract_variable_i (variable, ptr, name, group) + type (C_ptr), intent(in) :: ptr + character (len=*), intent(in) :: name + character (len=*), intent(in), optional :: group + integer, intent(out) :: variable + type (C_ptr) :: Cptr + integer (C_int), pointer :: Fptr + if ( present(group) ) then + Cptr = lammps_extract_variable_Cptr (ptr, name, group) + else + Cptr = lammps_extract_variable_Cptr (ptr, name) + end if + call C_F_pointer (Cptr, Fptr) + variable = Fptr + nullify (Fptr) + call lammps_free (Cptr) + end subroutine lammps_extract_variable_i + subroutine lammps_extract_variable_dp (variable, ptr, name, group) + type (C_ptr), intent(in) :: ptr + character (len=*), intent(in) :: name + character (len=*), intent(in), optional :: group + double precision, intent(out) :: variable + type (C_ptr) :: Cptr + real (C_double), pointer :: Fptr + if ( present(group) ) then + Cptr = lammps_extract_variable_Cptr (ptr, name, group) + else + Cptr = lammps_extract_variable_Cptr (ptr, name) + end if + call C_F_pointer (Cptr, Fptr) + variable = Fptr + nullify (Fptr) + call lammps_free (Cptr) + end subroutine lammps_extract_variable_dp + subroutine lammps_extract_variable_r (variable, ptr, name, group) + type (C_ptr), intent(in) :: ptr + character (len=*), intent(in) :: name + character (len=*), intent(in), optional :: group + real, intent(out) :: variable + double precision :: d_var + if ( present (group) ) then + call lammps_extract_variable_dp (d_var, ptr, name, group) + else + call lammps_extract_variable_dp (d_var, ptr, name) + end if + variable = real(d_var) + end subroutine lammps_extract_variable_r + + subroutine lammps_extract_variable_ia (variable, ptr, name, group) + integer, dimension(:), allocatable, intent(out) :: variable + type (C_ptr), intent(in) :: ptr + character (len=*), intent(in) :: name + character (len=*), intent(in), optional :: group + type (C_ptr) :: Cptr + integer (C_int), dimension(:), pointer :: Fptr + integer :: natoms + nullify (Fptr) + if ( present(group) ) then + Cptr = lammps_extract_variable_Cptr (ptr, name, group) + else + Cptr = lammps_extract_variable_Cptr (ptr, name) + end if + natoms = lammps_get_natoms (ptr) + if ( allocated (variable) ) deallocate (variable) + allocate (variable(natoms)) + call C_F_pointer (Cptr, Fptr, (/natoms/)) + variable = Fptr + nullify (Fptr) + call lammps_free (Cptr) + end subroutine lammps_extract_variable_ia + subroutine lammps_extract_variable_dpa (variable, ptr, name, group) + double precision, dimension(:), allocatable, intent(out) :: variable + type (C_ptr), intent(in) :: ptr + character (len=*), intent(in) :: name + character (len=*), intent(in), optional :: group + type (C_ptr) :: Cptr + real (C_double), dimension(:), pointer :: Fptr + integer :: natoms + if ( present(group) ) then + Cptr = lammps_extract_variable_Cptr (ptr, name, group) + else + Cptr = lammps_extract_variable_Cptr (ptr, name) + end if + natoms = lammps_get_natoms (ptr) + if ( allocated (variable) ) deallocate (variable) + allocate (variable(natoms)) + call C_F_pointer (Cptr, Fptr, (/natoms/)) + variable = Fptr + nullify (Fptr) + call lammps_free (Cptr) + end subroutine lammps_extract_variable_dpa + subroutine lammps_extract_variable_ra (variable, ptr, name, group) + type (C_ptr), intent(in) :: ptr + character (len=*), intent(in) :: name + character (len=*), intent(in), optional :: group + real, dimension(:), allocatable, intent(out) :: variable + double precision, dimension(:), allocatable :: d_var + if ( present (group) ) then + call lammps_extract_variable_dpa (d_var, ptr, name, group) + else + call lammps_extract_variable_dpa (d_var, ptr, name) + end if + if ( allocated (variable) ) deallocate (variable) + allocate (variable(size(d_var))) + variable = real(d_var) + deallocate (d_var) + end subroutine lammps_extract_variable_ra + +!-------------------------------------------------------------------------2}}} + + subroutine lammps_get_coords (ptr, coords) + type (C_ptr) :: ptr + double precision, dimension(:), allocatable :: coords + real (C_double), dimension(:), allocatable, target :: C_coords + integer :: natoms + natoms = lammps_get_natoms (ptr) + if ( allocated(coords) ) deallocate (coords) + allocate (coords(3*natoms)) + allocate (C_coords(3*natoms)) + call lammps_actual_get_coords (ptr, C_loc(C_coords)) + coords = C_coords + deallocate (C_coords) + end subroutine lammps_get_coords + +!----------------------------------------------------------------------------- + + subroutine lammps_put_coords (ptr, coords) + type (C_ptr) :: ptr + double precision, dimension(:) :: coords + real (C_double), dimension(size(coords)) :: C_coords + C_coords = coords + call lammps_actual_put_coords (ptr, C_coords) + end subroutine lammps_put_coords + +!----------------------------------------------------------------------------- + + function lammps_extract_compute_vectorsize (ptr, id, style) & + result (vectorsize) + integer :: vectorsize + type (C_ptr), intent(in) :: ptr + character (len=*), intent(in) :: id + integer, intent(in) :: style + integer (C_int) :: Cvectorsize, Cstyle + character (kind=C_char), dimension(len_trim(id)+1) :: Cid + Cid = string2Cstring (id) + Cstyle = int(style, C_int) + Cvectorsize = lammps_actual_extract_compute_vectorsize (ptr, Cid, Cstyle) + vectorsize = int(Cvectorsize, kind(vectorsize)) + end function lammps_extract_compute_vectorsize + +!----------------------------------------------------------------------------- + + function lammps_extract_fix_vectorsize (ptr, id, style) & + result (vectorsize) + integer :: vectorsize + type (C_ptr), intent(in) :: ptr + character (len=*), intent(in) :: id + integer, intent(in) :: style + integer (C_int) :: Cvectorsize, Cstyle + character (kind=C_char), dimension(len_trim(id)+1) :: Cid + Cid = string2Cstring (id) + Cstyle = int(style, C_int) + Cvectorsize = lammps_actual_extract_fix_vectorsize (ptr, Cid, Cstyle) + vectorsize = int(Cvectorsize, kind(vectorsize)) + end function lammps_extract_fix_vectorsize + +!----------------------------------------------------------------------------- + + subroutine lammps_extract_compute_arraysize (ptr, id, style, nrows, ncols) + type (C_ptr), intent(in) :: ptr + character (len=*), intent(in) :: id + integer, intent(in) :: style + integer, intent(out) :: nrows, ncols + integer (C_int) :: Cstyle, Cnrows, Cncols + character (kind=C_char), dimension(len_trim(id)+1) :: Cid + Cid = string2Cstring (id) + Cstyle = int (style, C_int) + call lammps_actual_extract_compute_arraysize (ptr, Cid, Cstyle, & + Cnrows, Cncols) + nrows = int (Cnrows, kind(nrows)) + ncols = int (Cncols, kind(ncols)) + end subroutine lammps_extract_compute_arraysize + +!----------------------------------------------------------------------------- + + subroutine lammps_extract_fix_arraysize (ptr, id, style, nrows, ncols) + type (C_ptr), intent(in) :: ptr + character (len=*), intent(in) :: id + integer, intent(in) :: style + integer, intent(out) :: nrows, ncols + integer (C_int) :: Cstyle, Cnrows, Cncols + character (kind=C_char), dimension(len_trim(id)+1) :: Cid + Cid = string2Cstring (id) + Cstyle = int (style, kind(Cstyle)) + call lammps_actual_extract_fix_arraysize (ptr, Cid, Cstyle, & + Cnrows, Cncols) + nrows = int (Cnrows, kind(nrows)) + ncols = int (Cncols, kind(ncols)) + end subroutine lammps_extract_fix_arraysize + +!----------------------------------------------------------------------------- + + subroutine lammps_error_all (ptr, file, line, str) + type (C_ptr), intent(in) :: ptr + character (len=*), intent(in) :: file, str + integer, intent(in) :: line + character (kind=C_char), dimension(len_trim(file)+1) :: Cfile + character (kind=C_char), dimension(len_trim(str)+1) :: Cstr + integer (C_int) :: Cline + Cline = int(line, kind(Cline)) + Cfile = string2Cstring (file) + Cstr = string2Cstring (str) + call lammps_actual_error_all (ptr, Cfile, Cline, Cstr) + end subroutine lammps_error_all + +!----------------------------------------------------------------------------- + +! Locally defined helper functions {{{1 + + pure function string2Cstring (string) result (C_string) + use, intrinsic :: ISO_C_binding, only : C_char, C_NULL_CHAR + character (len=*), intent(in) :: string + character (len=1, kind=C_char) :: C_string (len_trim(string)+1) + integer :: i, n + n = len_trim (string) + forall (i = 1:n) + C_string(i) = string(i:i) + end forall + C_string(n+1) = C_NULL_CHAR + end function string2Cstring + +!----------------------------------------------------------------------------- + + subroutine Cstring2argcargv (Cstring, argc, argv) + !! Converts a C-style string to argc and argv, that is, words in Cstring + !! become C-style strings in argv. IMPORTANT: Cstring is modified by + !! this routine! I would make Cstring local TO this routine and accept + !! a Fortran-style string instead, but we run into scoping and + !! allocation problems that way. This routine assumes the string is + !! null-terminated, as all C-style strings must be. + + character (kind=C_char), dimension(*), target, intent(inout) :: Cstring + integer (C_int), intent(out) :: argc + type (C_ptr), dimension(:), allocatable, intent(out) :: argv + + integer :: StringStart, SpaceIndex, strlen, argnum + + argc = 1_C_int + + ! Find the length of the string + strlen = 1 + do while ( Cstring(strlen) /= C_NULL_CHAR ) + strlen = strlen + 1 + end do + + ! Find the number of non-escaped spaces + SpaceIndex = 2 + do while ( SpaceIndex < strlen ) + if ( Cstring(SpaceIndex) == ' ' .and. & + Cstring(SpaceIndex-1) /= '\' ) then + argc = argc + 1_C_int + ! Find the next non-space character + do while ( Cstring(SpaceIndex+1) == ' ') + SpaceIndex = SpaceIndex + 1 + end do + end if + SpaceIndex = SpaceIndex + 1 + end do + + ! Now allocate memory for argv + allocate (argv(argc)) + + ! Now find the string starting and ending locations + StringStart = 1 + SpaceIndex = 2 + argnum = 1 + do while ( SpaceIndex < strlen ) + if ( Cstring(SpaceIndex) == ' ' .and. & + Cstring(SpaceIndex-1) /= '\' ) then + ! Found a real space => split strings and store this one + Cstring(Spaceindex) = C_NULL_CHAR ! Replaces space with NULL + argv(argnum) = C_loc(Cstring(StringStart)) + argnum = argnum + 1 + ! Find the next non-space character + do while ( Cstring(SpaceIndex+1) == ' ') + SpaceIndex = SpaceIndex + 1 + end do + StringStart = SpaceIndex + 1 + else if ( Cstring(SpaceIndex) == ' ' .and. & + Cstring(SpaceIndex-1) == '\' ) then + ! Escaped space => remove backslash and move rest of array + Cstring(SpaceIndex-1:strlen-1) = Cstring(SpaceIndex:strlen) + strlen = strlen - 1 ! Last character is still C_NULL_CHAR + end if + SpaceIndex = SpaceIndex + 1 + end do + ! Now handle the last argument + argv(argnum) = C_loc(Cstring(StringStart)) + + end subroutine Cstring2argcargv + +!----------------------------------------------------------------------------- + + function Cdoublestar_to_2darray (Carray, nrows, ncolumns) result (Farray) + + ! Take a C/C++ array of pointers to pointers to doubles (sort of like a + ! two-dimensional array, and handled the same way from the programmer's + ! perspective) into a Fortran-style array. Note that columns in C still + ! correspond to columns in Fortran here and the same for rows. + + type (C_ptr), intent(in) :: Carray + integer, intent(in) :: nrows, ncolumns + double precision, dimension(nrows, ncolumns) :: Farray + type (C_ptr), dimension(:), pointer :: C_rows + real (C_double), dimension(:), pointer :: F_row + integer :: i + + ! Convert each "C row pointer" into an array of rows + call C_F_pointer (Carray, C_rows, (/nrows/)) + do i = 1, nrows + ! Convert each C pointer (an entire row) into a Fortran pointer + call C_F_pointer (C_rows(i), F_row, (/ncolumns/)) + Farray (i,:) = real(F_row, kind(0.0D0)) + end do + + end function Cdoublestar_to_2darray +! 1}}} + +end module LAMMPS + +! vim: foldmethod=marker ts=3 sts=3 expandtab diff --git a/examples/COUPLE/fortran2/README b/examples/COUPLE/fortran2/README new file mode 100644 index 0000000000..99f3ffa2c5 --- /dev/null +++ b/examples/COUPLE/fortran2/README @@ -0,0 +1,213 @@ +LAMMPS.F90 defines a Fortran 2003 module, LAMMPS, which wraps all functions in +src/library.h so they can be used directly from Fortran-encoded programs. + +All functions in src/library.h that use and/or return C-style pointers have +Fortran wrapper functions that use Fortran-style arrays, pointers, and +strings; all C-style memory management is handled internally with no user +intervention. + +------------------------------------- + +--COMPILATION-- + +First, be advised that mixed-language programming is not trivial. It requires +you to link in the required libraries of all languages you use (in this case, +those for Fortran, C, and C++), as well as any other libraries required. +You are also advised to read the --USE-- section below before trying to +compile. + +The following steps will work to compile this module (replace ${LAMMPS_SRC} +with the path to your LAMMPS source directory): + (1) Compile LAMMPS as a static library. Call the resulting file ${LAMMPS_LIB}, + which will have an actual name lake liblmp_openmpi.a. If compiling + using the MPI stubs in ${LAMMPS_SRC}/STUBS, you will need to know where + libmpi.a is as well (I'll call it ${MPI_STUBS} hereafter) + (2) Copy said library to your Fortran program's source directory or include + its location in a -L${LAMMPS_SRC} flag to your compiler. + (3) Compile (but don't link!) LAMMPS.F90. Example: + mpif90 -c LAMMPS.f90 + OR + gfortran -c LAMMPS.F90 + Copy the LAMMPS.o and lammps.mod (or whatever your compiler calls module + files) to your Fortran program's source directory. + NOTE: you may get a warning such as, + subroutine lammps_open_wrapper (argc, argv, communicator, ptr) & + Variable 'communicator' at (1) is a parameter to the BIND(C) + procedure 'lammps_open_wrapper' but may not be C interoperable + This is normal (see --IMPLEMENTATION NOTES--). + (4) Compile (but don't link) LAMMPS-wrapper.cpp. You will need its header + file as well. You will have to provide the locations of LAMMPS's + header files. For example, + mpicxx -c -I${LAMMPS_SRC} LAMMPS-wrapper.cpp + OR + g++ -c -I${LAMMPS_SRC} -I${LAMMPS_SRC}/STUBS LAMMPS-wrapper.cpp + OR + icpc -c -I${LAMMPS_SRC} -I${LAMMPS_SRC}/STUBS LAMMPS-wrapper.cpp + Copy the resulting object file LAMMPS-wrapper.o to your Fortran program's + source directory. + (4b) OPTIONAL: Make a library so you can carry around two files instead of + three. Example: + ar rs liblammps_fortran.a LAMMPS.o LAMMPS-wrapper.o + This will create the file liblammps_fortran.a that you can use in place + of "LAMMPS.o LAMMPS-wrapper.o" in part (6). Note that you will still + need to have the .mod file from part (3). + + It is also possible to add LAMMPS.o and LAMMPS-wrapper.o into the + LAMMPS library (e.g., liblmp_openmpi.a) instead of creating a separate + library, like so: + ar rs ${LAMMPS_LIB} LAMMPS.o LAMMPS-wrapper.o + In this case, you can now use the Fortran wrapper functions as if they + were part of the usual LAMMPS library interface (if you have the module + file visible to the compiler, that is). + (5) Compile your Fortran program. Example: + mpif90 -c myfreeformatfile.f90 + mpif90 -c myfixedformatfile.f + OR + gfortran -c myfreeformatfile.f90 + gfortran -c myfixedformatfile.f + The object files generated by these steps are collectively referred to + as ${my_object_files} in the next step(s). + + IMPORTANT: If the Fortran module from part (3) is not in the current + directory or in one searched by the compiler for module files, you will + need to include that location via the -I flag to the compiler. + (6) Link everything together, including any libraries needed by LAMMPS (such + as the C++ standard library, the C math library, the JPEG library, fftw, + etc.) For example, + mpif90 LAMMPS.o LAMMPS-wrapper.o ${my_object_files} \ + ${LAMMPS_LIB} -lstdc++ -lm + OR + gfortran LAMMPS.o LAMMPS-wrapper.o ${my_object_files} \ + ${LAMMPS_LIB} ${MPI_STUBS} -lstdc++ -lm + OR + ifort LAMMPS.o LAMMPS-wrapper.o ${my_object_files} \ + ${LAMMPS_LIB} ${MPI_STUBS} -cxxlib -limf -lm + Any other required libraries (e.g. -ljpeg, -lfftw) should be added to + the end of this line. + +You should now have a working executable. + +Steps 3 and 4 above are accomplished, possibly after some modifications to +the makefile, by make using the attached makefile. + +------------------------------------- + +--USAGE-- + +To use this API, your program unit (PROGRAM/SUBROUTINE/FUNCTION/MODULE/etc.) +should look something like this: + program call_lammps + use LAMMPS + ! Other modules, etc. + implicit none + type (lammps_instance) :: lmp ! This is a pointer to your LAMMPS instance + double precision :: fix + double precision, dimension(:), allocatable :: fix2 + ! Rest of declarations + call lammps_open_no_mpi ('lmp -in /dev/null -screen out.lammps',lmp) + ! Set up rest of program here + call lammps_file (lmp, 'in.example') + call lammps_extract_fix (fix, lmp, '2', 0, 1, 1, 1) + call lammps_extract_fix (fix2, lmp, '4', 0, 2, 1, 1) + call lammps_close (lmp) + end program call_lammps + +Important notes: + * All arguments which are char* variables in library.cpp are character (len=*) + variables here. For example, + call lammps_command (lmp, 'units metal') + will work as expected. + * The public functions (the only ones you can use) have interfaces as + described in the comments at the top of LAMMPS.F90. They are not always + the same as those in library.h, since C strings are replaced by Fortran + strings and the like. + * The module attempts to check whether you have done something stupid (such + as assign a 2D array to a scalar), but it's not perfect. For example, the + command + call lammps_extract_global (nlocal, ptr, 'nlocal') + will give nlocal correctly if nlocal is of type INTEGER, but it will give + the wrong answer if nlocal is of type REAL or DOUBLE PRECISION. This is a + feature of the (void*) type cast in library.cpp. There is no way I can + check this for you! + * You are allowed to use REAL or DOUBLE PRECISION floating-point numbers. + All LAMMPS data (which are of type REAL(C_double)) are rounded off if + placed in single precision variables. It is tacitly assumed that NO C++ + variables are of type float; everything is int or double (since this is + all library.cpp currently handles). + * An example of a complete program is offered at the end of this file. + +------------------------------------- + +--TROUBLESHOOTING-- + +Compile-time errors probably indicate that your compiler is not new enough to +support Fortran 2003 features. For example, GCC 4.1.2 will not compile this +module, but GCC 4.4.0 will. + +If your compiler balks at 'use, intrinsic :: ISO_C_binding,' try removing the +intrinsic part so it looks like an ordinary module. However, it is likely +that such a compiler will also have problems with everything else in the +file as well. + +If you get a segfault as soon as the lammps_open call is made, check that you +compiled your program AND LAMMPS-header.cpp using the same MPI headers. Using +the stubs for one and the actual MPI library for the other will cause major +problems. + +If you find run-time errors, please pass them along via the LAMMPS Users +mailing list. Please provide a minimal working example along with the names +and versions of the compilers you are using. Please make sure the error is +repeatable and is in MY code, not yours (generating a minimal working example +will usually ensure this anyway). + +------------------------------------- + +--IMPLEMENTATION NOTES-- + +The Fortran procedures have the same names as the C procedures, and +their purpose is the same, but they may take different arguments. Here are +some of the important differences: + * lammps_open and lammps_open_no_mpi take a string instead of argc and + argv. This is necessary because C and C++ have a very different way + of treating strings than Fortran. + * All C++ functions that accept char* pointers now accept Fortran-style + strings within this interface instead. + * All of the lammps_extract_[something] functions, which return void* + C-style pointers, have been replaced by generic subroutines that return + Fortran variables (which may be arrays). The first argument houses the + variable to be returned; all other arguments are identical except as + stipulated above. Note that it is not possible to declare generic + functions that are selected based solely on the type/kind/rank (TKR) + signature of the return value, only based on the TKR of the arguments. + * The SHAPE of the first argument to lammps_extract_[something] is checked + against the "shape" of the C array (e.g., double vs. double* vs. double**). + Calling a subroutine with arguments of inappropriate rank will result in an + error at run time. + * All arrays passed to subroutines must be ALLOCATABLE and are REALLOCATED + to fit the shape of the array LAMMPS will be returning. + * The indices i and j in lammps_extract_fix are used the same way they + are in f_ID[i][j] references in LAMMPS (i.e., starting from 1). This is + different than the way library.cpp uses these numbers, but is more + consistent with the way arrays are accessed in LAMMPS and in Fortran. + * The char* pointer normally returned by lammps_command is thrown away + in this version; note also that lammps_command is now a subroutine + instead of a function. + * The pointer to LAMMPS itself is of type(lammps_instance), which is itself + a synonym for type(C_ptr), part of ISO_C_BINDING. Type (C_ptr) is + C's void* data type. This should be the only C data type that needs to + be used by the end user. + * This module will almost certainly generate a compile-time warning, + such as, + subroutine lammps_open_wrapper (argc, argv, communicator, ptr) & + Variable 'communicator' at (1) is a parameter to the BIND(C) + procedure 'lammps_open_wrapper' but may not be C interoperable + This happens because lammps_open_wrapper actually takes a Fortran + INTEGER argument, whose type is defined by the MPI library itself. The + Fortran integer is converted to a C integer by the MPI library (if such + conversion is actually necessary). + * Unlike library.cpp, this module returns COPIES of the data LAMMPS actually + uses. This is done for safety reasons, as you should, in general, not be + overwriting LAMMPS data directly from Fortran. If you require this + functionality, it is possible to write another function that, for example, + returns a Fortran pointer that resolves to the C/C++ data instead of + copying the contents of that pointer to the original array as is done now. diff --git a/examples/COUPLE/fortran2/in.simple b/examples/COUPLE/fortran2/in.simple new file mode 100644 index 0000000000..69384836ee --- /dev/null +++ b/examples/COUPLE/fortran2/in.simple @@ -0,0 +1,15 @@ +units metal +lattice bcc 3.1656 +region simbox block 0 10 0 10 0 10 +create_box 2 simbox +create_atoms 1 region simbox +pair_style eam/fs +pair_coeff * * path/to/my_potential.eam.fs A1 A2 +mass 1 58.2 # These are made-up numbers +mass 2 28.3 +velocity all create 1200.0 7474848 dist gaussian +fix 1 all nve +fix 2 all dt/reset 1 1E-5 1E-3 0.01 units box +fix 4 all ave/histo 10 5 100 0.5 1.5 50 f_2 file temp.histo ave running +thermo_style custom step dt temp press etotal f_4[1][1] +thermo 100 diff --git a/examples/COUPLE/fortran2/makefile b/examples/COUPLE/fortran2/makefile new file mode 100644 index 0000000000..3d13c4428e --- /dev/null +++ b/examples/COUPLE/fortran2/makefile @@ -0,0 +1,33 @@ +SHELL = /bin/sh + +# Path to LAMMPS extraction directory +LAMMPS_ROOT = ../svn-dist +LAMMPS_SRC = $(LAMMPS_ROOT)/src + +# Remove the line below if using mpicxx/mpic++ as your C++ compiler +MPI_STUBS = $(LAMMPS_SRC)/STUBS + +FC = gfortran # replace with your Fortran compiler +CXX = g++ # replace with your C++ compiler + +# Flags for Fortran compiler, C++ compiler, and C preprocessor, respectively +FFLAGS = -O2 +CXXFLAGS = -O2 +CPPFLAGS = + +all : liblammps_fortran.a + +liblammps_fortran.a : LAMMPS.o LAMMPS-wrapper.o + $(AR) rs $@ $^ + +LAMMPS.o lammps.mod : LAMMPS.F90 + $(FC) $(CPPFLAGS) $(FFLAGS) -c $< + +LAMMPS-wrapper.o : LAMMPS-wrapper.cpp LAMMPS-wrapper.h + $(CXX) $(CPPFLAGS) $(CXXFLAGS) -c $< -I$(LAMMPS_SRC) -I$(MPI_STUBS) + +clean : + $(RM) *.o *.mod liblammps_fortran.a + +dist : + tar -czf Fortran-interface.tar.gz LAMMPS-wrapper.h LAMMPS-wrapper.cpp LAMMPS.F90 makefile README diff --git a/examples/COUPLE/fortran2/simple.f90 b/examples/COUPLE/fortran2/simple.f90 new file mode 100644 index 0000000000..93cf519f97 --- /dev/null +++ b/examples/COUPLE/fortran2/simple.f90 @@ -0,0 +1,44 @@ +program simple + + use LAMMPS + implicit none + + type (lammps_instance) :: lmp + double precision :: compute, fix, fix2 + double precision, dimension(:), allocatable :: compute_v, mass, r + double precision, dimension(:,:), allocatable :: x + real, dimension(:,:), allocatable :: x_r + + call lammps_open_no_mpi ('',lmp) + call lammps_file (lmp, 'in.simple') + call lammps_command (lmp, 'run 500') + + call lammps_extract_fix (fix, lmp, '2', 0, 1, 1, 1) + print *, 'Fix is ', fix + + call lammps_extract_fix (fix2, lmp, '4', 0, 2, 1, 1) + print *, 'Fix 2 is ', fix2 + + call lammps_extract_compute (compute, lmp, 'thermo_temp', 0, 0) + print *, 'Compute is ', compute + + call lammps_extract_compute (compute_v, lmp, 'thermo_temp', 0, 1) + print *, 'Vector is ', compute_v + + call lammps_extract_atom (mass, lmp, 'mass') + print *, 'Mass is ', mass + + call lammps_extract_atom (x, lmp, 'x') + if ( .not. allocated (x) ) print *, 'x is not allocated' + print *, 'x is ', x(1,:) + + call lammps_extract_atom (x_r, lmp, 'x') + if ( .not. allocated (x_r) ) print *, 'x is not allocated' + print *, 'x_r is ', x_r(1,:) + + call lammps_get_coords (lmp, r) + print *, 'r is ', r(1:3) + + call lammps_close (lmp) + +end program simple diff --git a/examples/COUPLE/simple/README b/examples/COUPLE/simple/README index a1d5e2034e..ab1fd7b88d 100644 --- a/examples/COUPLE/simple/README +++ b/examples/COUPLE/simple/README @@ -35,7 +35,8 @@ gcc -L/home/sjplimp/lammps/src simple.o \ -llmp_g++ -lfftw -lmpich -lmpl -lpthread -lstdc++ -o simpleC This builds the Fortran wrapper and driver with the LAMMPS library -using a Fortran and C compiler: +using a Fortran and C compiler, using the wrapper in the fortran +directory: cp ../fortran/libfwrapper.c . gcc -I/home/sjplimp/lammps/src -c libfwrapper.c