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