1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
|
!
! 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 .
!
!--------------------------------------------------------------------------
!
! 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 iso_c_binding module.
!
! Additionally, it provides interfaces to the C functions in clib/:
! 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
!
MODULE wrappers
USE kinds, ONLY : DP
USE io_global, ONLY : stdout
USE ISO_C_BINDING
IMPLICIT NONE
!
! C std library functions fortran wrappers:
PUBLIC f_remove, rename, f_chdir, f_mkdir, f_rmdir, f_getcwd
! more stuff:
PUBLIC f_copy, feval_infix, md5_from_file, f_mkdir_safe
!
! 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
END MODULE
! ====================================================================
|
