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