mirror of https://gitlab.com/QEF/q-e.git
320 lines
10 KiB
Fortran
320 lines
10 KiB
Fortran
!
|
|
! 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
|
|
! ====================================================================
|