scnc
/
quantum-espresso
mirror of https://gitlab.com/QEF/q-e.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity
quantum-espresso/UtilXlib/clib_wrappers.f90

320 lines
10 KiB
Fortran
Raw Blame History

!
! Copyright (C) 2004-2013 Quantum ESPRESSO group
! This file is distributed under the terms of the
! GNU General Public License. See the file `License'
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
!--------------------------------------------------------------------------
MODULE clib_wrappers
!------------------------------------------------------------------------
!! This module contains fortran wrappers to POSIX system calls.
!! The wrappers are used to convert the Fortran CHARACTER array to
!! null-terminated C *char. The conversion and the interface is done
!! with the F95 intrinsic \(\texttt{iso_c_binding}\) module.
!! Additionally, it provides interfaces to the C functions in clib/:
!! \(\texttt{eval_infix, md5_from_file, f_mkdir_safe}\)
!
! NOTE: the mkdir function is NOT called directly as it returns error if
! directory already exists. We use instead a C wrapper c_mkdir_safe
!
USE util_param, ONLY : DP
USE ISO_C_BINDING
IMPLICIT NONE
!
! C std library functions fortran wrappers:
PUBLIC f_remove, f_rename, f_chdir, f_mkdir, f_rmdir, f_getcwd
! more stuff:
PUBLIC f_copy, feval_infix, md5_from_file, f_mkdir_safe, memstat, get_mem_usage, get_mem_avail
!
! HELP:
! integer f_remove(pathname)
! integer f_rename(oldfile, newfile)
! integer f_chdir(newdir)
! integer f_chmod(mode) i.e. mode=777 (disable)
! integer f_mkdir(dirname, mode) mode is optional
! integer f_rmdir(dirname)
! subroutine f_getcwd(dirname)
! All "*name" are fortran characters of implicit length,
! "mode" are integers, all functions return 0 if successful, -1 otherwise
!
! real(dp) :: result = feval_infix(integer:: ierr, character(len=*) :: expression)
! subroutine md5_from_file(character(len=*) :: filename, character(len=32) ::md5)
PRIVATE
!
SAVE
!
! Interfaces to the C functions, these are kept private as Fortran
! characters have (?) to be converted explicitly to C character arrays.
! Use the f_* wrappers instead
INTERFACE
FUNCTION remove(pathname) BIND(C,name="remove") RESULT(r)
USE iso_c_binding
CHARACTER(kind=c_char),INTENT(in) :: pathname(*)
INTEGER(c_int) :: r
END FUNCTION
FUNCTION rename(input,output) BIND(C,name="rename") RESULT(r)
USE iso_c_binding
CHARACTER(kind=c_char),INTENT(in) :: input(*)
CHARACTER(kind=c_char),INTENT(in) :: output(*)
INTEGER(c_int) :: r
END FUNCTION
FUNCTION chmod(filename,mode) BIND(C,name="chmod") RESULT(r)
USE iso_c_binding
CHARACTER(kind=c_char),INTENT(in) :: filename(*)
INTEGER(c_int),VALUE ,INTENT(in) :: mode
INTEGER(c_int) :: r
END FUNCTION
FUNCTION chdir(filename) BIND(C,name="chdir") RESULT(r)
USE iso_c_binding
CHARACTER(kind=c_char),INTENT(in) :: filename(*)
INTEGER(c_int) :: r
END FUNCTION
FUNCTION mkdir(dirname,mode) BIND(C,name="mkdir") RESULT(r)
USE iso_c_binding
CHARACTER(kind=c_char),INTENT(in) :: dirname(*)
INTEGER(c_int),VALUE ,INTENT(in) :: mode
INTEGER(c_int) :: r
END FUNCTION
FUNCTION rmdir(dirname) BIND(C,name="rmdir") RESULT(r)
USE iso_c_binding
CHARACTER(kind=c_char),INTENT(in) :: dirname(*)
INTEGER(c_int) :: r
END FUNCTION
FUNCTION getcwd(buffer,size) BIND(C,name="getcwd") RESULT(r)
USE iso_c_binding
CHARACTER(kind=c_char) ,INTENT(out) :: buffer(*)
INTEGER(c_size_t),VALUE,INTENT(in) :: size
TYPE(c_ptr) :: r
END FUNCTION
END INTERFACE
!
! ====================================================================
CONTAINS
! ====================================================================
! fortran wrappers functions that call the C functions after converting
! fortran characters to C character arrays
FUNCTION f_remove(filename) RESULT(r)
CHARACTER(*),INTENT(in) :: filename
INTEGER(c_int) :: r
r= remove(TRIM(filename)//C_NULL_CHAR)
END FUNCTION
FUNCTION f_rename(input,output) RESULT(k)
CHARACTER(*),INTENT(in) :: input,output
INTEGER :: k
k= rename(TRIM(input)//C_NULL_CHAR,TRIM(output)//C_NULL_CHAR)
END FUNCTION
FUNCTION f_chdir(dirname) RESULT(r)
CHARACTER(*),INTENT(in) :: dirname
INTEGER(c_int) :: r
r= chdir(TRIM(dirname)//C_NULL_CHAR)
END FUNCTION
!
! f_mkdir, causes an ERROR if dirname already exists: use f_mkdir_safe instead
FUNCTION f_mkdir(dirname, mode) RESULT(r)
CHARACTER(*),INTENT(in) :: dirname
INTEGER,INTENT(in) :: mode
INTEGER(c_int) :: r
INTEGER(c_int) :: c_mode
c_mode = INT(mode, kind=c_int)
r= mkdir(TRIM(dirname)//C_NULL_CHAR, c_mode)
END FUNCTION
! Note: permissions are usually in octal, e.g.:
! mode = o'640' => rw-r-----
FUNCTION f_chmod(filename, mode) RESULT(r)
CHARACTER(*),INTENT(in) :: filename
INTEGER,INTENT(in) :: mode
INTEGER(c_int) :: r
INTEGER(c_int) :: c_mode
c_mode = INT(mode, kind=c_int)
r= chmod(TRIM(filename)//C_NULL_CHAR, c_mode)
END FUNCTION
FUNCTION f_rmdir(dirname) RESULT(r)
CHARACTER(*),INTENT(in) :: dirname
INTEGER(c_int) :: r
r= rmdir(TRIM(dirname)//C_NULL_CHAR)
END FUNCTION
SUBROUTINE f_getcwd(output)
CHARACTER(kind=c_char,len=*),INTENT(out) :: output
TYPE(c_ptr) :: buffer
INTEGER(C_SIZE_T) :: length,i ! was kind=C_LONG, which fails on WIN32
length=LEN(output)
buffer=getcwd(output,length)
DO i=1,length
IF(output(i:i) == C_NULL_CHAR) EXIT
ENDDO
output(i:)=' '
END SUBROUTINE
! ====================================================================
! copy a file, uses clibs/copy.c which currently does a binary copy
! using an 8kb buffer
!
! returns:
! 0 : no error
! -1 : cannot open source
! -2 : cannot open dest
! -3 : error while writing
! -4 : disk full while writing
FUNCTION f_copy(source, dest) RESULT(r)
INTERFACE
FUNCTION c_copy(source,dest) BIND(C,name="copy") RESULT(r)
USE iso_c_binding
CHARACTER(kind=c_char),INTENT(in) :: source(*), dest(*)
INTEGER(c_int) :: r
END FUNCTION c_copy
END INTERFACE
CHARACTER(*),INTENT(in) :: source, dest
INTEGER(c_int) :: r
r= c_copy(TRIM(source)//C_NULL_CHAR, TRIM(dest)//C_NULL_CHAR)
END FUNCTION
!
! safe mkdir from clib/c_mkdir.c that creates a directory, if necessary,
! and checks permissions. It can be called in parallel.
! Returns: 0 = all ok
! 1 = error
! -1 = the directory already existed and is properly writable
FUNCTION f_mkdir_safe(dirname) RESULT(r)
INTERFACE
FUNCTION mkdir_safe(dirname) BIND(C,name="c_mkdir_safe") RESULT(r)
USE iso_c_binding
CHARACTER(kind=c_char),INTENT(in) :: dirname(*)
INTEGER(c_int) :: r
END FUNCTION mkdir_safe
END INTERFACE
CHARACTER(*),INTENT(in) :: dirname
INTEGER(c_int) :: r
r= mkdir_safe(TRIM(dirname)//C_NULL_CHAR)
END FUNCTION
!
! Two more wrappers for eval_infix (simple algebric expression parser)
! and for get_md5 which computes the md5 sum of a file.
!
FUNCTION feval_infix(fierr, fstr)
USE ISO_C_BINDING
IMPLICIT NONE
REAL(DP) :: feval_infix
INTEGER :: fierr
CHARACTER(len=*) :: fstr
INTEGER :: filen
!
INTERFACE
FUNCTION ceval_infix(cierr, cstr, cilen) BIND(C, name="eval_infix")
!REAL(kind=c_double) FUNCTION ceval_infix(cierr, cstr, cilen) BIND(C, name="eval_infix")
! double eval_infix( int *ierr, const char *strExpression, int len )
USE ISO_C_BINDING
REAL(kind=c_double) :: ceval_infix
INTEGER(kind=c_int) :: cierr
CHARACTER(kind=c_char) :: cstr(*)
INTEGER(kind=c_int),VALUE :: cilen
END FUNCTION ceval_infix
END INTERFACE
!
INTEGER(kind=c_int) :: cierr
INTEGER(kind=c_int) :: cilen
CHARACTER(len=len_trim(fstr)+1,kind=c_char) :: cstr
!
INTEGER :: i
!
filen = len_trim(fstr)
cilen = INT(filen, kind=c_int)
DO i = 1,filen
cstr(i:i) = fstr(i:i)
ENDDO
cstr(filen+1:filen+1)=C_NULL_CHAR
!
feval_infix = REAL( ceval_infix(cierr, cstr, cilen), kind=DP)
fierr = INT(cierr)
RETURN
END FUNCTION feval_infix
!
!
SUBROUTINE md5_from_file (ffile, fmd5)
IMPLICIT NONE
CHARACTER(LEN=*), INTENT (IN) :: ffile
CHARACTER(len=32), INTENT (OUT) :: fmd5
!
INTERFACE
SUBROUTINE cget_md5(cfile, cmd5, cierr) BIND(C, name="get_md5")
! void get_md5(const char *file, char *md5, int err)
USE ISO_C_BINDING
CHARACTER(kind=c_char) :: cfile(*)
CHARACTER(kind=c_char) :: cmd5(*)
INTEGER(kind=c_int) :: cierr
END SUBROUTINE cget_md5
END INTERFACE
!
INTEGER,PARAMETER :: md5_length = 32
INTEGER :: i
!
CHARACTER(len=len_trim(ffile)+1,kind=c_char) :: cfile!(*)
CHARACTER(len=(md5_length+1),kind=c_char) :: cmd5!(*)
INTEGER(kind=c_int) :: cierr
!
cfile = TRIM(ffile)//C_NULL_CHAR
!
CALL cget_md5(cfile, cmd5, cierr)
!
DO i = 1,md5_length
fmd5(i:i) = cmd5(i:i)
ENDDO
!
END SUBROUTINE md5_from_file
!
! Wrapper for (buggy) C routine "memstat"
!
SUBROUTINE memstat (kbytes)
IMPLICIT NONE
INTEGER, INTENT(OUT) :: kbytes
!
INTERFACE
FUNCTION c_memstat( ) BIND(C, name="c_memstat")
USE ISO_C_BINDING
INTEGER(kind=c_int) :: c_memstat
END FUNCTION c_memstat
END INTERFACE
!
kbytes = c_memstat()
!
END SUBROUTINE memstat
!
! Wrapper for C routine "getMemUsage"
!
FUNCTION get_mem_usage() RESULT(kbytes)
IMPLICIT NONE
INTEGER(kind=c_size_t) :: kbytes
!
INTERFACE
FUNCTION c_getmemusage() BIND(C, name="c_getMemUsage")
USE ISO_C_BINDING
INTEGER(kind=c_size_t) :: c_getmemusage
END FUNCTION c_getmemusage
END INTERFACE
!
kbytes = c_getmemusage()
!
END FUNCTION get_mem_usage
!
! Wrapper for C routine "getMemAvail"
!
FUNCTION get_mem_avail() RESULT(kbytes)
IMPLICIT NONE
INTEGER(kind=c_size_t) :: kbytes
!
INTERFACE
FUNCTION c_getmemavail() BIND(C, name="c_getMemAvail")
USE ISO_C_BINDING
INTEGER(kind=c_size_t) :: c_getmemavail
END FUNCTION c_getmemavail
END INTERFACE
!
kbytes = c_getmemavail();
!
END FUNCTION get_mem_avail
!
END MODULE
! ====================================================================
Reference in New Issue View Git Blame Copy Permalink