From ccbe10ff39d6a1992a0726ce0bcee7817315e862 Mon Sep 17 00:00:00 2001 From: sjplimp Date: Thu, 25 Oct 2012 15:42:25 +0000 Subject: [PATCH] git-svn-id: svn://svn.icms.temple.edu/lammps-ro/trunk@9003 f3b2605a-c512-4ea7-a41b-209d697bcdaa --- examples/COUPLE/fortran2/LAMMPS.F90 | 2110 ++++++++++++--------------- examples/COUPLE/fortran2/README | 486 +++--- examples/COUPLE/fortran2/in.simple | 9 +- examples/COUPLE/fortran2/simple.f90 | 95 +- 4 files changed, 1292 insertions(+), 1408 deletions(-) diff --git a/examples/COUPLE/fortran2/LAMMPS.F90 b/examples/COUPLE/fortran2/LAMMPS.F90 index 5b8cc6466d..7f19b6b450 100644 --- a/examples/COUPLE/fortran2/LAMMPS.F90 +++ b/examples/COUPLE/fortran2/LAMMPS.F90 @@ -1,1169 +1,941 @@ -!! ----------------------------------------------------------------------- -! 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_gather_atoms (ptr, name, count, data) -!! subroutine lammps_scatter_atoms (ptr, name, data) - -#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_gather_atoms, & - lammps_scatter_atoms - public :: 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_gather_atoms (ptr, name, type, count, data) & - bind (C, name='lammps_gather_atoms') - import :: C_ptr, C_int, C_char - type (C_ptr), value :: ptr, data - character (kind=C_char), dimension(*) :: name - integer (C_int), value :: type, count - end subroutine lammps_actual_gather_atoms - - subroutine lammps_actual_scatter_atoms (ptr, name, type, count, data) & - bind (C, name='lammps_scatter_atoms') - import :: C_ptr, C_int, C_char - type (C_ptr), value :: ptr, data - character (kind=C_char), dimension(*) :: name - integer (C_int), value :: type, count - end subroutine lammps_actual_scatter_atoms - 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 - - interface lammps_gather_atoms - module procedure lammps_gather_atoms_ia, lammps_gather_atoms_dpa, & - lammps_gather_atoms_ra - end interface lammps_gather_atoms - - interface lammps_scatter_atoms - module procedure lammps_scatter_atoms_ia, lammps_scatter_atoms_dpa, & - lammps_scatter_atoms_ra - end interface lammps_scatter_atoms - -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), dimension(:), pointer :: Fptr - integer :: nelements - call lammps_extract_global_i (nelements, ptr, 'nlocal') - Cptr = lammps_extract_atom_Cptr (ptr, name) - call C_F_pointer (Cptr, Fptr, (/nelements/)) - if ( .not. associated (Fptr) ) return - allocate (atom(nelements)) - 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 - Cptr = lammps_extract_atom_Cptr (ptr, name) - if ( name == 'mass' ) then - call C_F_pointer (Cptr, Fptr, (/nelements + 1/)) - if ( .not. associated (Fptr) ) return - allocate (atom(nelements)) - atom = Fptr(2:) ! LAMMPS starts numbering at 1 (C does not) - else - call C_F_pointer (Cptr, Fptr, (/nelements/)) - if ( .not. associated (Fptr) ) return - allocate (atom(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) - 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 ( 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) - call lammps_extract_global_i (nelements, ptr, 'nlocal') - 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 (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 - ! 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) - 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 - integer :: nr, nc - ! 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) - compute = Cdoublestar_to_2darray (Cptr, nr, nc) - ! 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) - 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 - ! 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) - 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 - integer :: nr, nc - ! 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) - fix = Cdoublestar_to_2darray (Cptr, nr, nc) - ! 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) - 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 - 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 = nint(d_var) - 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) - type (C_ptr), intent(in) :: ptr - character (len=*), intent(in) :: name - character (len=*), intent(in), optional :: group - integer, 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 - allocate (variable(size(d_var))) - variable = nint(d_var) - deallocate (d_var) - 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) - 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 - allocate (variable(size(d_var))) - variable = real(d_var) - deallocate (d_var) - end subroutine lammps_extract_variable_ra - -!-------------------------------------------------------------------------2}}} - - subroutine lammps_gather_atoms_ia (ptr, name, count, data) - type (C_ptr), intent(in) :: ptr - character (len=*), intent(in) :: name - integer, intent(in) :: count - integer, dimension(:), allocatable, intent(out) :: data - type (C_ptr) :: Cdata - integer (C_int), dimension(:), pointer :: Fdata - integer (C_int) :: natoms - character (kind=C_char), dimension(len_trim(name)+1) :: Cname - integer (C_int), parameter :: Ctype = 0_C_int - integer (C_int) :: Ccount - natoms = lammps_get_natoms (ptr) - Cname = string2Cstring (name) - if ( count /= 1 .and. count /= 3 ) then - call lammps_error_all (ptr, FLERR, 'lammps_gather_atoms requires& - & count to be either 1 or 3') - else - Ccount = count - end if - allocate ( Fdata(count*natoms) ) - allocate ( data(count*natoms) ) - Cdata = C_loc (Fdata(1)) - call lammps_actual_gather_atoms (ptr, Cname, Ctype, Ccount, Cdata) - data = Fdata - deallocate (Fdata) - end subroutine lammps_gather_atoms_ia - subroutine lammps_gather_atoms_dpa (ptr, name, count, data) - type (C_ptr), intent(in) :: ptr - character (len=*), intent(in) :: name - integer, intent(in) :: count - double precision, dimension(:), allocatable, intent(out) :: data - type (C_ptr) :: Cdata - real (C_double), dimension(:), pointer :: Fdata - integer (C_int) :: natoms - character (kind=C_char), dimension(len_trim(name)+1) :: Cname - integer (C_int), parameter :: Ctype = 1_C_int - integer (C_int) :: Ccount - natoms = lammps_get_natoms (ptr) - Cname = string2Cstring (name) - if ( count /= 1 .and. count /= 3 ) then - call lammps_error_all (ptr, FLERR, 'lammps_gather_atoms requires& - & count to be either 1 or 3') - else - Ccount = count - end if - allocate ( Fdata(count*natoms) ) - allocate ( data(count*natoms) ) - Cdata = C_loc (Fdata(1)) - call lammps_actual_gather_atoms (ptr, Cname, Ctype, Ccount, Cdata) - data = Fdata(:) - deallocate (Fdata) - end subroutine lammps_gather_atoms_dpa - subroutine lammps_gather_atoms_ra (ptr, name, count, data) - type (C_ptr), intent(in) :: ptr - character (len=*), intent(in) :: name - integer, intent(in) :: count - real, dimension(:), allocatable, intent(out) :: data - double precision, dimension(:), allocatable :: d_data - call lammps_gather_atoms_dpa (ptr, name, count, d_data) - allocate (data(size(d_data))) - data = d_data - deallocate (d_data) - end subroutine lammps_gather_atoms_ra - -!----------------------------------------------------------------------------- - - subroutine lammps_scatter_atoms_ia (ptr, name, data) - type (C_ptr), intent(in) :: ptr - character (len=*), intent(in) :: name - integer, dimension(:), intent(in) :: data - integer (kind=C_int) :: natoms, Ccount - integer (kind=C_int), parameter :: Ctype = 0_C_int - character (kind=C_char), dimension(len_trim(name)+1) :: Cname - integer (C_int), dimension(size(data)), target :: Fdata - type (C_ptr) :: Cdata - natoms = lammps_get_natoms (ptr) - Cname = string2Cstring (name) - Ccount = size(data) / natoms - if ( Ccount /= 1 .and. Ccount /= 3 ) & - call lammps_error_all (ptr, FLERR, 'lammps_gather_atoms requires& - & count to be either 1 or 3') - Fdata = data - Cdata = C_loc (Fdata(1)) - call lammps_actual_scatter_atoms (ptr, Cname, Ctype, Ccount, Cdata) - end subroutine lammps_scatter_atoms_ia - subroutine lammps_scatter_atoms_dpa (ptr, name, data) - type (C_ptr), intent(in) :: ptr - character (len=*), intent(in) :: name - double precision, dimension(:), intent(in) :: data - integer (kind=C_int) :: natoms, Ccount - integer (kind=C_int), parameter :: Ctype = 1_C_int - character (kind=C_char), dimension(len_trim(name)+1) :: Cname - real (C_double), dimension(size(data)), target :: Fdata - type (C_ptr) :: Cdata - natoms = lammps_get_natoms (ptr) - Cname = string2Cstring (name) - Ccount = size(data) / natoms - if ( Ccount /= 1 .and. Ccount /= 3 ) & - call lammps_error_all (ptr, FLERR, 'lammps_gather_atoms requires& - & count to be either 1 or 3') - Fdata = data - Cdata = C_loc (Fdata(1)) - call lammps_actual_scatter_atoms (ptr, Cname, Ctype, Ccount, Cdata) - end subroutine lammps_scatter_atoms_dpa - subroutine lammps_scatter_atoms_ra (ptr, name, data) - type (C_ptr), intent(in) :: ptr - character (len=*), intent(in) :: name - real, dimension(:), intent(in) :: data - double precision, dimension(size(data)) :: d_data - d_data = real (data, kind(d_data)) - call lammps_scatter_atoms_dpa (ptr, name, d_data) - end subroutine lammps_scatter_atoms_ra - -!----------------------------------------------------------------------------- - - 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 tabstop=3 softtabstop=3 shiftwidth=3 expandtab +!! ----------------------------------------------------------------------- +! 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_gather_atoms (ptr, name, count, data) +!! subroutine lammps_scatter_atoms (ptr, name, data) + +#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_gather_atoms, & + lammps_scatter_atoms + public :: lammps_instance, C_ptr, C_double, C_int + + !! 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_gather_atoms (ptr, name, type, count, data) & + bind (C, name='lammps_gather_atoms') + import :: C_ptr, C_int, C_char + type (C_ptr), value :: ptr, data + character (kind=C_char), dimension(*) :: name + integer (C_int), value :: type, count + end subroutine lammps_actual_gather_atoms + + subroutine lammps_actual_scatter_atoms (ptr, name, type, count, data) & + bind (C, name='lammps_scatter_atoms') + import :: C_ptr, C_int, C_char + type (C_ptr), value :: ptr, data + character (kind=C_char), dimension(*) :: name + integer (C_int), value :: type, count + end subroutine lammps_actual_scatter_atoms + end interface + + ! Generic functions for the wrappers below {{{1 + + interface lammps_extract_global + module procedure lammps_extract_global_i, & + lammps_extract_global_dp + end interface lammps_extract_global + + interface lammps_extract_atom + module procedure lammps_extract_atom_ia, & + lammps_extract_atom_dpa, & + lammps_extract_atom_dp2a + end interface lammps_extract_atom + + interface lammps_extract_compute + module procedure lammps_extract_compute_dp, & + lammps_extract_compute_dpa, & + lammps_extract_compute_dp2a + end interface lammps_extract_compute + + interface lammps_extract_fix + module procedure lammps_extract_fix_dp, & + lammps_extract_fix_dpa, & + lammps_extract_fix_dp2a + end interface lammps_extract_fix + + interface lammps_extract_variable + module procedure lammps_extract_variable_dp, & + lammps_extract_variable_dpa + end interface lammps_extract_variable + + interface lammps_gather_atoms + module procedure lammps_gather_atoms_ia, lammps_gather_atoms_dpa + end interface lammps_gather_atoms + + interface lammps_scatter_atoms + module procedure lammps_scatter_atoms_ia, lammps_scatter_atoms_dpa + end interface lammps_scatter_atoms + +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 (C_int), pointer, intent(out) :: global + type (C_ptr), intent(in) :: ptr + character (len=*), intent(in) :: name + type (C_ptr) :: Cptr + Cptr = lammps_extract_global_Cptr (ptr, name) + call C_F_pointer (Cptr, global) + end subroutine lammps_extract_global_i + subroutine lammps_extract_global_dp (global, ptr, name) + real (C_double), pointer, intent(out) :: global + type (C_ptr), intent(in) :: ptr + character (len=*), intent(in) :: name + type (C_ptr) :: Cptr + Cptr = lammps_extract_global_Cptr (ptr, name) + call C_F_pointer (Cptr, global) + end subroutine lammps_extract_global_dp + +!----------------------------------------------------------------------------- + +! 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 (C_int), dimension(:), pointer, intent(out) :: atom + type (C_ptr), intent(in) :: ptr + character (len=*), intent(in) :: name + type (C_ptr) :: Cptr + integer (C_int), pointer :: nelements + call lammps_extract_global_i (nelements, ptr, 'nlocal') + Cptr = lammps_extract_atom_Cptr (ptr, name) + call C_F_pointer (Cptr, atom, (/nelements/)) + end subroutine lammps_extract_atom_ia + subroutine lammps_extract_atom_dpa (atom, ptr, name) + real (C_double), dimension(:), pointer, intent(out) :: atom + type (C_ptr), intent(in) :: ptr + character (len=*), intent(in) :: name + type (C_ptr) :: Cptr + integer (C_int), pointer :: nlocal + integer :: nelements + real (C_double), dimension(:), pointer :: Fptr + if ( name == 'mass' ) then + nelements = lammps_get_ntypes (ptr) + 1 + else if ( name == 'x' .or. name == 'v' .or. name == 'f' .or. & + name == 'mu' .or. name == 'omega' .or. name == 'torque' .or. & + name == 'angmom' ) then + ! We should not be getting a rank-2 array here! + call lammps_error_all (ptr, FLERR, 'You cannot extract those atom& + & data (' // trim(name) // ') into a rank 1 array.') + return + else + ! Everything else we can get is probably nlocal units long + call lammps_extract_global_i (nlocal, ptr, 'nlocal') + nelements = nlocal + end if + Cptr = lammps_extract_atom_Cptr (ptr, name) + call C_F_pointer (Cptr, Fptr, (/nelements/)) + if ( name == 'mass' ) then + atom(0:) => Fptr + else + atom => Fptr + end if + end subroutine lammps_extract_atom_dpa + subroutine lammps_extract_atom_dp2a (atom, ptr, name) + real (C_double), dimension(:,:), pointer, intent(out) :: atom + type (C_ptr), intent(in) :: ptr + character (len=*), intent(in) :: name + type (C_ptr) :: Cptr + type (C_ptr), pointer, dimension(:) :: Catom + integer (C_int), pointer :: nelements + if ( name /= 'x' .and. name /= 'v' .and. name /= 'f' .and. & + name /= 'mu' .and. name /= 'omega' .and. name /= 'tandque' .and. & + name /= 'angmom' ) then + ! We should not be getting a rank-2 array here! + call lammps_error_all (ptr, FLERR, 'You cannot extract those atom& + & data (' // trim(name) // ') into a rank 2 array.') + return + end if + Cptr = lammps_extract_atom_Cptr (ptr, name) + call lammps_extract_global_i (nelements, ptr, 'nlocal') + ! Catom will now be the array of void* pointers that the void** pointer + ! pointed to. Catom(1) is now the pointer to the first element. + call C_F_pointer (Cptr, Catom, (/nelements/)) + ! Now get the actual array, which has its shape transposed from what we + ! might think of it in C + call C_F_pointer (Catom(1), atom, (/3, nelements/)) + end subroutine lammps_extract_atom_dp2a + +!----------------------------------------------------------------------------- + +! 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) + real (C_double), pointer, intent(out) :: compute + type (C_ptr), intent(in) :: ptr + character (len=*), intent(in) :: id + integer, intent(in) :: style, type + type (C_ptr) :: Cptr + ! 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, compute) + end subroutine lammps_extract_compute_dp + subroutine lammps_extract_compute_dpa (compute, ptr, id, style, type) + real (C_double), dimension(:), pointer, intent(out) :: compute + type (C_ptr), intent(in) :: ptr + character (len=*), intent(in) :: id + integer, intent(in) :: style, type + type (C_ptr) :: Cptr + integer :: nelements + ! 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) + Cptr = lammps_extract_compute_Cptr (ptr, id, style, type) + call C_F_pointer (Cptr, compute, (/nelements/)) + end subroutine lammps_extract_compute_dpa + subroutine lammps_extract_compute_dp2a (compute, ptr, id, style, type) + real (C_double), dimension(:,:), pointer, intent(out) :: compute + type (C_ptr), intent(in) :: ptr + character (len=*), intent(in) :: id + integer, intent(in) :: style, type + type (C_ptr) :: Cptr + type (C_ptr), pointer, dimension(:) :: Ccompute + integer :: nr, nc + ! 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) + call C_F_pointer (Cptr, Ccompute, (/nr/)) + ! Note that the matrix is transposed, from Fortran's perspective + call C_F_pointer (Ccompute(1), compute, (/nc, nr/)) + end subroutine lammps_extract_compute_dp2a + +!----------------------------------------------------------------------------- + +! 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) + real (C_double), 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/& + &type combination.') + 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_dpa (fix, ptr, id, style, type, i, j) + real (C_double), dimension(:), pointer, 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 + integer :: fix_len + ! 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) + call C_F_pointer (Cptr, fix, (/fix_len/)) + ! Memory is only allocated for "global" fix variables, which we should + ! never get here, so no need to call lammps_free! + end subroutine lammps_extract_fix_dpa + subroutine lammps_extract_fix_dp2a (fix, ptr, id, style, type, i, j) + real (C_double), dimension(:,:), pointer, 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 + type (C_ptr), pointer, dimension(:) :: Cfix + integer :: nr, nc + ! 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) + ! Extract pointer to first element as Cfix(1) + call C_F_pointer (Cptr, Cfix, (/nr/)) + ! Now extract the array, which is transposed + call C_F_pointer (Cfix(1), fix, (/nc, nr/)) + end subroutine lammps_extract_fix_dp2a + +!----------------------------------------------------------------------------- + +! 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_dp (variable, ptr, name, group) + real (C_double), 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), 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_dpa (variable, ptr, name, group) + real (C_double), 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) + allocate (variable(natoms)) + call C_F_pointer (Cptr, Fptr, (/natoms/)) + variable = Fptr + nullify (Fptr) + call lammps_free (Cptr) + end subroutine lammps_extract_variable_dpa + +!-------------------------------------------------------------------------2}}} + + subroutine lammps_gather_atoms_ia (ptr, name, count, data) + type (C_ptr), intent(in) :: ptr + character (len=*), intent(in) :: name + integer, intent(in) :: count + integer, dimension(:), allocatable, intent(out) :: data + type (C_ptr) :: Cdata + integer (C_int), dimension(:), pointer :: Fdata + integer (C_int) :: natoms + character (kind=C_char), dimension(len_trim(name)+1) :: Cname + integer (C_int), parameter :: Ctype = 0_C_int + integer (C_int) :: Ccount + natoms = lammps_get_natoms (ptr) + Cname = string2Cstring (name) + if ( count /= 1 .and. count /= 3 ) then + call lammps_error_all (ptr, FLERR, 'lammps_gather_atoms requires& + & count to be either 1 or 3') + else + Ccount = count + end if + allocate ( Fdata(count*natoms) ) + allocate ( data(count*natoms) ) + Cdata = C_loc (Fdata(1)) + call lammps_actual_gather_atoms (ptr, Cname, Ctype, Ccount, Cdata) + data = Fdata + deallocate (Fdata) + end subroutine lammps_gather_atoms_ia + subroutine lammps_gather_atoms_dpa (ptr, name, count, data) + type (C_ptr), intent(in) :: ptr + character (len=*), intent(in) :: name + integer, intent(in) :: count + double precision, dimension(:), allocatable, intent(out) :: data + type (C_ptr) :: Cdata + real (C_double), dimension(:), pointer :: Fdata + integer (C_int) :: natoms + character (kind=C_char), dimension(len_trim(name)+1) :: Cname + integer (C_int), parameter :: Ctype = 1_C_int + integer (C_int) :: Ccount + natoms = lammps_get_natoms (ptr) + Cname = string2Cstring (name) + if ( count /= 1 .and. count /= 3 ) then + call lammps_error_all (ptr, FLERR, 'lammps_gather_atoms requires& + & count to be either 1 or 3') + else + Ccount = count + end if + allocate ( Fdata(count*natoms) ) + allocate ( data(count*natoms) ) + Cdata = C_loc (Fdata(1)) + call lammps_actual_gather_atoms (ptr, Cname, Ctype, Ccount, Cdata) + data = Fdata(:) + deallocate (Fdata) + end subroutine lammps_gather_atoms_dpa + +!----------------------------------------------------------------------------- + + subroutine lammps_scatter_atoms_ia (ptr, name, data) + type (C_ptr), intent(in) :: ptr + character (len=*), intent(in) :: name + integer, dimension(:), intent(in) :: data + integer (kind=C_int) :: natoms, Ccount + integer (kind=C_int), parameter :: Ctype = 0_C_int + character (kind=C_char), dimension(len_trim(name)+1) :: Cname + integer (C_int), dimension(size(data)), target :: Fdata + type (C_ptr) :: Cdata + natoms = lammps_get_natoms (ptr) + Cname = string2Cstring (name) + Ccount = size(data) / natoms + if ( Ccount /= 1 .and. Ccount /= 3 ) & + call lammps_error_all (ptr, FLERR, 'lammps_gather_atoms requires& + & count to be either 1 or 3') + Fdata = data + Cdata = C_loc (Fdata(1)) + call lammps_actual_scatter_atoms (ptr, Cname, Ctype, Ccount, Cdata) + end subroutine lammps_scatter_atoms_ia + subroutine lammps_scatter_atoms_dpa (ptr, name, data) + type (C_ptr), intent(in) :: ptr + character (len=*), intent(in) :: name + double precision, dimension(:), intent(in) :: data + integer (kind=C_int) :: natoms, Ccount + integer (kind=C_int), parameter :: Ctype = 1_C_int + character (kind=C_char), dimension(len_trim(name)+1) :: Cname + real (C_double), dimension(size(data)), target :: Fdata + type (C_ptr) :: Cdata + natoms = lammps_get_natoms (ptr) + Cname = string2Cstring (name) + Ccount = size(data) / natoms + if ( Ccount /= 1 .and. Ccount /= 3 ) & + call lammps_error_all (ptr, FLERR, 'lammps_gather_atoms requires& + & count to be either 1 or 3') + Fdata = data + Cdata = C_loc (Fdata(1)) + call lammps_actual_scatter_atoms (ptr, Cname, Ctype, Ccount, Cdata) + end subroutine lammps_scatter_atoms_dpa + +!----------------------------------------------------------------------------- + + 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 + +! 1}}} + +end module LAMMPS + +! vim: foldmethod=marker tabstop=3 softtabstop=3 shiftwidth=3 expandtab diff --git a/examples/COUPLE/fortran2/README b/examples/COUPLE/fortran2/README index 03c76fb3ca..01eb76b0a1 100644 --- a/examples/COUPLE/fortran2/README +++ b/examples/COUPLE/fortran2/README @@ -1,221 +1,265 @@ -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. - -This interface was created by Karl Hammond who you can contact with -questions: - -Karl D. Hammond -University of Tennessee, Knoxville -karlh at ugcs.caltech.edu -karlh at utk.edu - -------------------------------------- - ---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. +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. See --USE-- for notes on how this interface differs from the +C interface (and the Python interface). + +This interface was created by Karl Hammond who you can contact with +questions: + +Karl D. Hammond +University of Tennessee, Knoxville +karlh at ugcs.caltech.edu +karlh at utk.edu + +------------------------------------- + +--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). + +Steps 3-5 are accomplished, possibly after some modifications to +the makefile, by make using the attached makefile. Said makefile also builds +the dynamically-linkable library (liblammps_fortran.so). + +** STATIC LIBRARY INSTRUCTIONS ** + (1) Compile LAMMPS as a static library. + Call the resulting file ${LAMMPS_LIB}, which will have an actual name + like liblmp_openmpi.a. If compiling using the MPI stubs in + ${LAMMPS_SRC}/STUBS, you will need to know where libmpi_stubs.a + is as well (I'll call it ${MPI_STUBS} hereafter) + (2) Copy said library to your Fortran program's source directory or replace + ${LAMMPS_LIB} with its full path in the instructions below. + (3) Compile (but don't link!) LAMMPS.F90. Example: + mpif90 -c LAMMPS.f90 + OR + gfortran -c LAMMPS.F90 + 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 + (5) OPTIONAL: Make a library from the object files 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" later. 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). + (6) Compile (but don't link) 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, like so: + mpif90 -I${LAMMPS_SRC}/examples/COUPLE/fortran2 -c myfreeformatfile.f90 + + (7) 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} -lmpi_cxx -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 -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. + +** DYNAMIC LIBRARY INSTRUCTIONS ** + (1) Compile LAMMPS as a dynamic library + (make makeshlib && make -f Makefile.shlib [targetname]). + (2) Compile, but don't link, LAMMPS.F90 using the -fPIC flag, such as + mpif90 -fPIC -c LAMMPS.f90 + (3) Compile, but don't link, LAMMPS-wrapper.cpp in the same manner, e.g. + mpicxx -fPIC -c LAMMPS-wrapper.cpp + (4) Make the dynamic library, like so: + mpif90 -fPIC -shared -o liblammps_fortran.so LAMMPS.o LAMMPS-wrapper.o + (5) Compile your program, such as, + mpif90 -I${LAMMPS_SRC}/examples/COUPLE/fortran2 -c myfreeformatfile.f90 + where ${LAMMPS_SRC}/examples/COUPLE/fortran2 contains the .mod file from + step (3) + (6) Link everything together, such as + mpif90 ${my_object_files} -L${LAMMPS_SRC} \ + -L${LAMMPS_SRC}/examples/COUPLE/fortran2 -llammps_fortran \ + -llammps_openmpi -lmpi_cxx -lstdc++ -lm + +If you wish to avoid the -L flags, add the directories containing your +shared libraries to the LIBRARY_PATH environment variable. At run time, you +will have to add these directories to LD_LIBRARY_PATH as well; otherwise, +your executable will not find the libraries it needs. + +------------------------------------- + +--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 + real (C_double) :: fix + real (C_double), dimension(:), pointer :: 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: + * Though I dislike the use of pointers, they are necessary when communicating + with C and C++, which do not support Fortran's ALLOCATABLE attribute. + * There is no need to deallocate C-allocated memory; this is done for you in + the cases when it is done (which are all cases when pointers are not + accepted, such as global fix data) + * 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 a pointer to type INTEGER, but it + will give the wrong answer if nlocal is a pointer to type REAL. This is a + feature of the (void*) type cast in library.cpp. There is no way I can + check this for you! It WILL catch you if you pass it an allocatable or + fixed-size array when it expects a pointer. + * Arrays constructed from temporary data from LAMMPS are ALLOCATABLE, and + represent COPIES of data, not the originals. Functions like + lammps_extract_atom, which return actual LAMMPS data, are pointers. + * IMPORTANT: Due to the differences between C and Fortran arrays (C uses + row-major vectors, Fortran uses column-major vectors), all arrays returned + from LAMMPS have their indices swapped. + * An example of a complete program, simple.f90, is included with this + package. + +------------------------------------- + +--TROUBLESHOOTING-- + +Compile-time errors (when compiling LAMMPS.F90, that is) 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-wrapper.cpp using the same MPI headers. Using +the stubs for one and the actual MPI library for the other will cause Bad +Things to happen. + +If you find run-time errors, please pass them along via the LAMMPS Users +mailing list (please CC me as well; address above). 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. If you want the command line to be + passed to lammps_open (as it often would be from C/C++), use the + GET_COMMAND intrinsic to obtain it. + * 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/pointer to be returned (pretend it's on the left-hand side); 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. + * 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 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). + * lammps_extract_global returns COPIES of the (scalar) data, as does the + C version. + * lammps_extract_atom, lammps_extract_compute, and lammps_extract_fix + have a first argument that will be associated with ACTUAL LAMMPS DATA. + This means the first argument must be: + * The right rank (via the DIMENSION modifier) + * A C-interoperable POINTER type (i.e., INTEGER (C_int) or + REAL (C_double)). + * lammps_extract_variable returns COPIES of the data, as the C library + interface does. There is no need to deallocate using lammps_free. + * The 'data' argument to lammps_gather_atoms and lammps_scatter atoms must + be ALLOCATABLE. It should be of type INTEGER or DOUBLE PRECISION. It + does NOT need to be C inter-operable (and indeed should not be). + * The 'count' argument of lammps_scatter_atoms is unnecessary; the shape of + the array determines the number of elements LAMMPS will read. diff --git a/examples/COUPLE/fortran2/in.simple b/examples/COUPLE/fortran2/in.simple index 69384836ee..5982cbaac1 100644 --- a/examples/COUPLE/fortran2/in.simple +++ b/examples/COUPLE/fortran2/in.simple @@ -1,10 +1,11 @@ -units metal -lattice bcc 3.1656 +units lj +atom_modify map array +lattice bcc 1.0 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 +pair_style lj/cut 2.5 +pair_coeff * * 1.0 1.0 mass 1 58.2 # These are made-up numbers mass 2 28.3 velocity all create 1200.0 7474848 dist gaussian diff --git a/examples/COUPLE/fortran2/simple.f90 b/examples/COUPLE/fortran2/simple.f90 index 93cf519f97..7ed3850a3d 100644 --- a/examples/COUPLE/fortran2/simple.f90 +++ b/examples/COUPLE/fortran2/simple.f90 @@ -1,44 +1,111 @@ program simple + use MPI use LAMMPS + + ! The following line is unnecessary, as I have included these three entities + ! with the LAMMPS module, but I leave them in anyway to remind people where + ! they came from + use, intrinsic :: ISO_C_binding, only : C_double, C_ptr, C_int + 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 + ! Notes: + ! * If LAMMPS returns a scalar that is allocated by the library interface + ! (see library.cpp), then that memory is deallocated automatically and + ! the argument to lammps_extract_fix must be a SCALAR. + ! * If LAMMPS returns a pointer to an array, consisting of internal LAMMPS + ! data, then the argument must be an interoperable Fortran pointer. + ! Interoperable means it is of type INTEGER (C_INT) or of type + ! REAL (C_DOUBLE) in this context. + ! * Pointers should NEVER be deallocated, as that would deallocate internal + ! LAMMPS data! + ! * Note that just because you can read the values of, say, a compute at + ! any time does not mean those values represent the "correct" values. + ! LAMMPS will abort you if you try to grab a pointer to a non-current + ! entity, but once it's bound, it's your responsibility to check that + ! it's current before evaluating. + ! * IMPORTANT: Two-dimensional arrays (such as 'x' from extract_atom) + ! will be transposed from what they might look like in C++. This is + ! because of different bookkeeping conventions between Fortran and C + ! that date back to about 1970 or so (when C was written). + ! * Arrays start from 1, EXCEPT for mass from extract_atom, which + ! starts from 0. This is because the C array actually has a blank + ! first element (and thus mass[1] corresponds to the mass of type 1) + + type (C_ptr) :: lmp + real (C_double), pointer :: compute => NULL() + real (C_double) :: fix, fix2 + real (C_double), dimension(:), pointer :: compute_v => NULL() + real (C_double), dimension(:,:), pointer :: x => NULL() + real (C_double), dimension(:), pointer :: mass => NULL() + integer, dimension(:), allocatable :: types + double precision, dimension(:), allocatable :: r + integer :: error, narg, me, nprocs + character (len=1024) :: command_line + + call MPI_Init (error) + call MPI_Comm_rank (MPI_COMM_WORLD, me, error) + call MPI_Comm_size (MPI_COMM_WORLD, nprocs, error) + + ! You are free to pass any string you like to lammps_open or + ! lammps_open_no_mpi; here is how you pass it the command line + !call get_command (command_line) + !call lammps_open (command_line, MPI_COMM_WORLD, lmp) + + ! And here's how to to it with a string constant of your choice + call lammps_open_no_mpi ('lmp -log log.simple', lmp) - call lammps_open_no_mpi ('',lmp) call lammps_file (lmp, 'in.simple') call lammps_command (lmp, 'run 500') + ! This extracts f_2 as a scalar (the last two arguments can be arbitrary) call lammps_extract_fix (fix, lmp, '2', 0, 1, 1, 1) print *, 'Fix is ', fix + ! This extracts f_4[1][1] as a scalar call lammps_extract_fix (fix2, lmp, '4', 0, 2, 1, 1) print *, 'Fix 2 is ', fix2 + ! This extracts the scalar compute of compute thermo_temp call lammps_extract_compute (compute, lmp, 'thermo_temp', 0, 0) print *, 'Compute is ', compute + ! This extracts the vector compute of compute thermo_temp call lammps_extract_compute (compute_v, lmp, 'thermo_temp', 0, 1) print *, 'Vector is ', compute_v + ! This extracts the masses call lammps_extract_atom (mass, lmp, 'mass') - print *, 'Mass is ', mass + print *, 'Mass is ', mass(1:) + ! Extracts a pointer to the arrays of positions for all atoms call lammps_extract_atom (x, lmp, 'x') - if ( .not. allocated (x) ) print *, 'x is not allocated' - print *, 'x is ', x(1,:) + if ( .not. associated (x) ) print *, 'x is not associated' + print *, 'x is ', x(:,1) ! Prints x, y, z for atom 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,:) + ! Extracts pointer to atom types + call lammps_gather_atoms (lmp, 'type', 1, types) + print *, 'types is ', types(1:3) - call lammps_get_coords (lmp, r) - print *, 'r is ', r(1:3) + ! Allocates an array and assigns all positions to it + call lammps_gather_atoms (lmp, 'x', 3, r) + print *, 'size(r) = ', size(r) + print *, 'r is ', r(1:6) + + ! Puts those position data back + call lammps_scatter_atoms (lmp, 'x', r) + + call lammps_command (lmp, 'run 1') + print *, 'x is ', x(:,1) ! Note that the position updates! + print *, 'Compute is ', compute ! This did only because "temp" is part of + ! the thermo output; the vector part did + ! not, and won't until we give LAMMPS a + ! thermo output or other command that + ! requires its value call lammps_close (lmp) + call MPI_Finalize (error) + end program simple