Branch data Line data Source code
1 : : !!****m* ABINIT/m_clib
2 : : !! NAME
3 : : !! m_clib
4 : : !!
5 : : !! FUNCTION
6 : : !!
7 : : !! COPYRIGHT
8 : : !! Copyright (C) 2009-2026 ABINIT group (MG)
9 : : !! This file is distributed under the terms of the
10 : : !! GNU General Public License, see ~abinit/COPYING
11 : : !! or http://www.gnu.org/copyleft/gpl.txt .
12 : : !!
13 : : !! SOURCE
14 : :
15 : : #if defined HAVE_CONFIG_H
16 : : #include "config.h"
17 : : #endif
18 : :
19 : : #include "abi_common.h"
20 : :
21 : : MODULE m_clib
22 : :
23 : : use, intrinsic :: iso_c_binding
24 : :
25 : : implicit none
26 : :
27 : : private
28 : :
29 : : public :: clib_rename ! Rename a file with a new name using the rename function from C stdlib
30 : : public :: clib_is_writable ! True if the process can write the file (access function from POSIX)
31 : : public :: clib_cclock
32 : : public :: clib_etime
33 : : public :: clib_mtrace
34 : : public :: clib_print_mallinfo
35 : : public :: clib_ulimit_stack ! Set stack size limit to maximum allowed value.
36 : : public :: clib_getpid ! Get process id
37 : : public :: clib_sleep ! Sleep for a certain number of seconds.
38 : : public :: clib_setenv ! Set env variable.
39 : : public :: clib_mkdir_if_needed
40 : : public :: clib_lock_file_by_name
41 : : public :: clib_close_fd
42 : :
43 : : ! ===================================================
44 : : ! ==== Fortran-bindings declared in fsi_posix.c ====
45 : : ! ===================================================
46 : :
47 : : interface
48 : : subroutine c_mkdir_if_needed(dirpath, ierr) bind(C, name="c_mkdir_if_needed")
49 : : import
50 : : character(kind=c_char), dimension(*), intent(in) :: dirpath
51 : : integer(c_int),intent(out) :: ierr
52 : : end subroutine c_mkdir_if_needed
53 : : end interface
54 : :
55 : : interface
56 : : integer(c_int) function c_rename(oldname, newname) bind(C, name='rename')
57 : : import
58 : : character(kind=c_char),intent(in) :: oldname(*)
59 : : character(kind=c_char),intent(in) :: newname(*)
60 : : end function c_rename
61 : : end interface
62 : :
63 : : interface
64 : : integer(c_int) function c_access(path, amode) bind(C, name='access')
65 : : import
66 : : character(kind=c_char),intent(in) :: path(*)
67 : : integer(c_int),value,intent(in) :: amode
68 : : end function c_access
69 : : end interface
70 : :
71 : : interface
72 : : subroutine clib_lock_file_by_name(filename, fd, ierr) bind(C, name="c_lock_file_by_name")
73 : : import
74 : : character(kind=c_char), dimension(*), intent(in) :: filename
75 : : integer(c_int),intent(out) :: fd
76 : : integer(c_int),intent(out) :: ierr
77 : : end subroutine clib_lock_file_by_name
78 : : end interface
79 : :
80 : : interface
81 : : subroutine clib_close_fd(fd) bind(C, name="c_close_fd")
82 : : import
83 : : integer(c_int),intent(in) :: fd
84 : : end subroutine clib_close_fd
85 : : end interface
86 : :
87 : : interface
88 : : subroutine clib_cclock(cpu) bind(C, name="cclock")
89 : : import
90 : : real(c_double),intent(out) :: cpu
91 : : end subroutine clib_cclock
92 : : end interface
93 : :
94 : : interface
95 : : real(c_double) function clib_etime(tt) bind(C, name="etime") result(res)
96 : : import
97 : : real(c_float),intent(out) :: tt(2)
98 : : end function clib_etime
99 : : end interface
100 : :
101 : : interface
102 : : ! The type of pid_t data is a signed integer type (signed int or we can say int).
103 : : function clib_getpid() bind(C, name='getpid')
104 : : import
105 : : integer(c_int) :: clib_getpid
106 : : end function clib_getpid
107 : : end interface
108 : :
109 : : interface
110 : : subroutine clib_sleep(seconds) bind(C, name="sleep")
111 : : import
112 : : integer(c_int), value :: seconds ! This is unsigned int in C
113 : : end subroutine clib_sleep
114 : : end interface
115 : :
116 : :
117 : : ! =================================================
118 : : ! ==== Fortran-bindings declared in mallinfo.c ====
119 : : ! =================================================
120 : : interface
121 : : subroutine clib_mallinfo(arena, hblkhd, usmblks, fsmblks, uordblks, fordblks) bind(C, name="clib_mallinfo")
122 : : import
123 : : integer(c_long),intent(out) :: arena, hblkhd, usmblks, fsmblks, uordblks, fordblks
124 : : end subroutine clib_mallinfo
125 : : end interface
126 : :
127 : : ! ==================================================
128 : : ! ==== Fortran-bindings declared in gnu_tools.c ====
129 : : ! ==================================================
130 : :
131 : : interface
132 : : subroutine clib_mtrace(ierr) bind(C, name="clib_mtrace")
133 : : import
134 : : integer(c_int),intent(out) :: ierr
135 : : end subroutine
136 : : end interface
137 : :
138 : : interface
139 : : subroutine clib_muntrace(ierr) bind(C, name="clib_muntrace")
140 : : import
141 : : integer(c_int),intent(out) :: ierr
142 : : end subroutine
143 : : end interface
144 : :
145 : : interface
146 : : subroutine clib_mcheck(ierr) bind(C, name="clib_mcheck")
147 : : import
148 : : integer(c_int),intent(out) :: ierr
149 : : end subroutine
150 : : end interface
151 : :
152 : : interface
153 : : ! Set stack size limit to maximum allowed value. Return soft and hard limit and exit status.
154 : : subroutine clib_ulimit_stack(rlim_cur, rlim_max, ierr) bind(C, name="ulimit_stack")
155 : : import
156 : : integer(c_long),intent(out) :: rlim_cur, rlim_max
157 : : integer(c_int),intent(out) :: ierr
158 : : end subroutine
159 : : end interface
160 : :
161 : : interface
162 : : integer(C_INT) function setenv(name, value, overwrite) bind(C, name="setenv")
163 : : import
164 : : character(kind=c_char),intent(in) :: name(*), value(*)
165 : : integer(c_int),intent(in) :: overwrite
166 : : end function
167 : : end interface
168 : :
169 : : ! ==========================================
170 : : ! ==== Fortran-bindings for file_lock.c ====
171 : : ! ==========================================
172 : :
173 : : !interface
174 : : ! function lock_file(filepath) bind(C)
175 : : ! import
176 : : ! implicit none
177 : : ! character(kind=c_char),intent(in) :: filepath(*)
178 : : ! integer(c_int) :: lock_file
179 : : ! end function lock_file
180 : : !end interface
181 : :
182 : : !interface
183 : : ! function unlock_fd(fd) bind(C)
184 : : ! import
185 : : ! implicit none
186 : : ! integer(c_int),value,intent(in) :: fd
187 : : ! integer(c_int) unlock_fd
188 : : ! end function unlock_fd
189 : : !end interface
190 : :
191 : : contains
192 : : !!***
193 : :
194 : : !!****f* m_clib/clib_print_fmallinfo
195 : : !! NAME
196 : : !! clib_print_fmallinfo
197 : : !!
198 : : !! FUNCTION
199 : : !!
200 : : !! INPUTS
201 : : !!
202 : : !! OUTPUT
203 : : !!
204 : : !! SOURCE
205 : :
206 : 0 : subroutine clib_print_mallinfo(unit)
207 : :
208 : : !Arguments ------------------------------------
209 : : integer,intent(in) :: unit
210 : :
211 : : !Local variables-------------------------------
212 : : integer(c_long) :: arena,hblkhd,usmblks,fsmblks,uordblks,fordblks
213 : : ! *********************************************************************
214 : :
215 : 0 : call clib_mallinfo(arena, hblkhd, usmblks, fsmblks, uordblks, fordblks)
216 : :
217 : 0 : write(unit,*)""
218 : 0 : write(unit,*)"--- !Mallinfo"
219 : 0 : write(unit,*)' Total space in arena: ',arena
220 : 0 : write(unit,*)' Space in holding block headers: ',hblkhd
221 : 0 : write(unit,*)' Space in small blocks in use: ',usmblks
222 : 0 : write(unit,*)' Space in free small blocks: ',fsmblks
223 : 0 : write(unit,*)' Space in ordinary blocks in use: ',uordblks
224 : 0 : write(unit,*)' Space in free ordinary blocks: ',fordblks
225 : 0 : write(unit,*)"..."
226 : 0 : write(unit,*)""
227 : :
228 : 0 : end subroutine clib_print_mallinfo
229 : : !!***
230 : :
231 : : !!****f* m_clib/clib_rename
232 : : !! NAME
233 : : !! clib_rename
234 : : !!
235 : : !! FUNCTION
236 : : !! Rename a file with a new name using the rename function from C stdlib
237 : : !!
238 : : !! SOURCE
239 : :
240 : 2 : integer function clib_rename(old_fname, new_fname) result(ierr)
241 : :
242 : : !Arguments ------------------------------------
243 : : character(len=*),intent(in) :: old_fname, new_fname
244 : : ! *********************************************************************
245 : :
246 : 2 : ierr = c_rename(trim(old_fname)//c_null_char, trim(new_fname)//c_null_char)
247 : :
248 : 2 : end function clib_rename
249 : : !!***
250 : :
251 : : !!****f* m_clib/clib_is_writable
252 : : !! NAME
253 : : !! clib_is_writable
254 : : !!
255 : : !! FUNCTION
256 : : !! True if the process can write the file, using the access function from POSIX.
257 : : !! False if the file does not exist. Symbolic links are followed.
258 : : !! Fortran INQUIRE(write=...) cannot be used: ifort returns UNKNOWN for files that are not connected.
259 : : !!
260 : : !! SOURCE
261 : :
262 : 2275 : logical function clib_is_writable(path) result(ans)
263 : :
264 : : !Arguments ------------------------------------
265 : : character(len=*),intent(in) :: path
266 : :
267 : : !Local variables-------------------------------
268 : : integer(c_int),parameter :: W_OK = 2 ! As in unistd.h
269 : : ! *********************************************************************
270 : :
271 : 2275 : ans = c_access(trim(path)//c_null_char, W_OK) == 0
272 : :
273 : 2275 : end function clib_is_writable
274 : : !!***
275 : :
276 : : !!****f* m_clib/clib_mkdir
277 : : !! NAME
278 : : !! clib_mkdir
279 : : !!
280 : : !! FUNCTION
281 : : !! Create a directory if it does not exist. Return 0 on success.
282 : : !!
283 : : !! SOURCE
284 : :
285 : 0 : subroutine clib_mkdir_if_needed(dirpath, ierr)
286 : :
287 : : !Arguments ------------------------------------
288 : : character(len=*),intent(in) :: dirpath
289 : : integer,intent(out) :: ierr
290 : : ! *********************************************************************
291 : :
292 [ # # ]: 0 : call c_mkdir_if_needed(trim(dirpath)//c_null_char, ierr)
293 : :
294 : 0 : end subroutine clib_mkdir_if_needed
295 : : !!***
296 : :
297 : : !!****f* m_clib/clib_setenv
298 : : !! NAME
299 : : !! clib_setenv
300 : : !!
301 : : !! FUNCTION
302 : : !! The setenv() function adds the variable name to the environment
303 : : !! with the value value, if name does not already exist. If name
304 : : !! does exist in the environment, then its value is changed to value
305 : : !! if overwrite is nonzero; if overwrite is zero, then the value of
306 : : !! name is not changed (and setenv() returns a success status).
307 : : !! This function makes copies of the strings pointed to by name and
308 : : !! value (by contrast with putenv(3)).
309 : : !!
310 : : !! SOURCE
311 : :
312 : 0 : integer function clib_setenv(name, value, overwrite) result(ierr)
313 : :
314 : : !Arguments ------------------------------------
315 : : character(len=*) ,intent(in) :: name, value
316 : : integer(C_INT), intent(in) :: overwrite
317 : : ! *********************************************************************
318 : :
319 : 0 : ierr = setenv(trim(name)//C_NULL_CHAR, trim(value)//C_NULL_CHAR, overwrite)
320 : :
321 : 0 : end function clib_setenv
322 : : !!***
323 : :
324 : 0 : END MODULE m_clib
325 : : !!***
|
