Context Navigation

← Previous Revision
Next Revision →
Blame
Revision Log

fsystem.F90

Last change on this file was 3318, checked in by slebonnois, 8 months ago
Titan PCM update : optics + microphysics
File size: 49.1 KB

Line
1	! Copyright (c) (2013-2015,2017,2022) Jeremie Burgalat (jeremie.burgalat@univ-reims.fr).
2	!
3	! This file is part of SWIFT
4	!
5	! Permission is hereby granted, free of charge, to any person obtaining a copy of
6	! this software and associated documentation files (the "Software"), to deal in
7	! the Software without restriction, including without limitation the rights to
8	! use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
9	! the Software, and to permit persons to whom the Software is furnished to do so,
10	! subject to the following conditions:
11	!
12	! The above copyright notice and this permission notice shall be included in all
13	! copies or substantial portions of the Software.
14	!
15	! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
16	! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
17	! FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
18	! COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
19	! IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
20	! CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
21
22	!! file: fsystem.F90
23	!! summary: File system methods source file.
24	!! author: J. Burgalat
25	!! date: 2013-2015,2017,2022
26
27
28	#include "defined.h"
29
30	MODULE FSYSTEM
31	!! File system methods module
32	USE, INTRINSIC :: ISO_C_BINDING
33	USE ERRORS
34	IMPLICIT NONE
35
36	PUBLIC
37
38	PRIVATE :: get_umask
39	PRIVATE :: c2t
40
41	INTEGER, PARAMETER :: MAX_PATH = 512 !! Maximum length of a path
42
43	TYPE, PUBLIC :: chrono
44	!! Define a simple chronometer
45	!!
46	!! This object can be used to get an approximation of the execution of some piece of code.
47	REAL(kind=8), PRIVATE :: cpu_start = 0d0
48	!! Starting CPU time
49	INTEGER(kind=8), PRIVATE :: clock_start = 0d0
50	!! Starting clock time
51	LOGICAL, PRIVATE :: on_run = .false.
52	!! Chrono running state.
53	#if HAVE_FTNPROC
54	CONTAINS
55	PROCEDURE :: is_running => chrono_is_running
56	PROCEDURE :: start => chrono_start
57	PROCEDURE :: stop => chrono_stop
58	PROCEDURE :: reset => chrono_reset
59	PROCEDURE :: get => chrono_get
60	#endif
61	END TYPE chrono
62
63	#ifndef FORD_DOC
64	! C interfaces
65	INTERFACE
66	FUNCTION strlen_c(s) RESULT(length) bind(C,name="strlen")
67	!! Get length of C-string up to (but not including) the terminator
68	IMPORT C_PTR, C_SIZE_T
69	TYPE(C_PTR), INTENT(in), VALUE :: s !! C string (a C_PTR type)
70	INTEGER(kind=C_SIZE_T) :: length !! An integer with the size of the string.
71	END FUNCTION strlen_c
72
73	SUBROUTINE free_c(ptr) bind(C,name="free")
74	!! Free memory used by a C pointer
75	IMPORT C_PTR
76	TYPE(C_PTR), INTENT(in), VALUE :: ptr !! TYPE(C_PTR) object with the underlying C pointer to free
77	END SUBROUTINE free_c
78
79	FUNCTION errno_c() BIND(C,name="c_get_errno")
80	!! Get last error numero
81	IMPORT C_INT
82	INTEGER(kind=C_INT) :: errno_c !! Last errno
83	END FUNCTION errno_c
84
85	FUNCTION usleep_c(usec) BIND(C,name="usleep")
86	!! (attemps to) Sleep for a given number of microseconds
87	IMPORT C_INT
88	INTEGER(kind=C_INT), INTENT(in), VALUE :: usec !! Number of microseconds to sleep
89	INTEGER(kind=C_INT) :: usleep_c !! An integer with 0 on success, last errno otherwise
90	END FUNCTION usleep_c
91
92	FUNCTION getgid_c() BIND(C, name="getgid")
93	!! Get Group ID
94	IMPORT C_INT
95	INTEGER(kind=C_INT) :: getgid_c !! Group identifier
96	END FUNCTION getgid_c
97
98	FUNCTION getpid_c() BIND(C, name="getpid")
99	!! Get Process ID
100	IMPORT C_INT
101	INTEGER(kind=C_INT) :: getpid_c !! Current process identifier
102	END FUNCTION getpid_c
103
104	FUNCTION getuid_c() BIND(C, name="getuid")
105	!! Get User ID
106	IMPORT C_INT
107	INTEGER(kind=C_INT) :: getuid_c !! User identifier
108	END FUNCTION getuid_c
109
110	FUNCTION umask_c() BIND(C,name="c_umask")
111	!! Get the current umask of the session
112	IMPORT C_INT
113	INTEGER(kind=C_INT) :: umask_c !! Current umask value in decimal system
114	END FUNCTION umask_c
115
116	FUNCTION access_c(path,perm) BIND(C,name="c_access")
117	!! Check if path is accessible for current user
118	IMPORT c_char, C_INT
119	CHARACTER(len=c_char), INTENT(in) :: path(*) !! Path to check
120	INTEGER(kind=C_INT), INTENT(in), VALUE :: perm !! User's permission to check
121	INTEGER(kind=C_INT) :: access_c !! 0 on success, last errno on failure
122	END FUNCTION access_c
123
124	FUNCTION create_c(path,mode,asfile,forced) BIND(C,name="c_create")
125	!! Create a directory or a file in given path
126	IMPORT c_char, C_INT
127	CHARACTER(len=c_char), INTENT(in) :: path(*) !! Path to create
128	INTEGER(kind=C_INT), INTENT(in), VALUE :: mode, & !! Decimal permission of the path
129	asfile, & !! 0 to create a directory, any other value to create file
130	forced !! non-zero value to force the creation of intermediate directories
131	INTEGER(kind=C_INT) :: create_c !! 0 on success, last errno otherwise
132	END FUNCTION create_c
133
134	FUNCTION uname_c(uid) BIND(C, name="c_uname")
135	!! Get the name of the given user id
136	IMPORT C_INT, c_ptr
137	INTEGER(kind=C_INT), INTENT(in), VALUE :: uid !! User id
138	TYPE(C_PTR) :: uname_c !! C_PTR to the underlying char* pointer storing user name
139	END FUNCTION uname_c
140
141	FUNCTION gname_c(gid) BIND(C, name="c_gname")
142	!! Get the name of the given group id
143	IMPORT C_INT, c_ptr
144	INTEGER(kind=C_INT), INTENT(in), VALUE :: gid !! Group id
145	TYPE(C_PTR) :: gname_c !! C_PTR to the underlying char* pointer storing group name
146	END FUNCTION gname_c
147
148	FUNCTION dirname_c(path) BIND(C,name="c_dirname")
149	!! Get the directory name of the path
150	IMPORT c_char, c_ptr
151	CHARACTER(kind=c_char), INTENT(in) :: path(*) !! Input path
152	TYPE(C_PTR) :: dirname_c !! C_PTR to the underlying char* pointer storing dirname
153	END FUNCTION dirname_c
154
155	FUNCTION basename_c(path) BIND(C,name="c_basename")
156	!! Get the basename of the path
157	IMPORT c_char, c_ptr
158	CHARACTER(kind=c_char), INTENT(in) :: path(*) !! Input path
159	TYPE(C_PTR) :: basename_c !! C_PTR to the underlying char* pointer sotring basename
160	END FUNCTION basename_c
161
162	FUNCTION getcwd_c() BIND(C,name="c_getcwd")
163	!! Get the current working directory
164	IMPORT c_ptr
165	TYPE(C_PTR) :: getcwd_c !! C_PTR to the underlying char* pointer storing current working directory
166	END FUNCTION getcwd_c
167
168	FUNCTION realpath_c(path) BIND(C, name="c_realpath")
169	!! Get the real path from given path
170	IMPORT c_char, c_ptr
171	CHARACTER(kind=c_char), INTENT(in) :: path(*) !! The path to expand
172	TYPE(C_PTR) :: realpath_c !! C_PTR to the underlying char* pointer storing realpath
173	END FUNCTION realpath_c
174
175	FUNCTION relpath_c(fname,reldir) BIND(C, name="c_relpath")
176	!! Get the relative path of path from another
177	IMPORT c_char, c_ptr
178	CHARACTER(kind=c_char), INTENT(in) :: fname(*), & !! Path to process
179	reldir(*) !! New base path
180	TYPE(C_PTR) :: relpath_c !! C_PTR to the underlying char* pointer storing relative path
181	END FUNCTION
182
183	FUNCTION rename_c(input,output) BIND(C,name="c_rename")
184	!! Rename a path
185	IMPORT c_char, C_INT
186	CHARACTER(kind=c_char), INTENT(in) :: input(*) !! Path to rename
187	CHARACTER(kind=c_char), INTENT(in) :: output(*) !! New name of the path
188	INTEGER(kind=C_INT) :: rename_c !! 0 on success, last errno on failure
189	END FUNCTION rename_c
190
191	FUNCTION chmod_c(path,mode) BIND(C,name="c_chmod")
192	!! Change file/directory permissions
193	IMPORT c_char, C_INT
194	CHARACTER(kind=c_char), INTENT(in) :: path(*) !! Path to modify
195	INTEGER(kind=C_INT), INTENT(in), VALUE :: mode !! New decimal permissions of the path to set
196	INTEGER(kind=C_INT) :: chmod_c !! 0 on success, last errno on failure
197	END FUNCTION chmod_c
198
199	FUNCTION chdir_c(new) BIND(C,name="c_chdir")
200	!! Change current directory
201	IMPORT c_char, C_INT
202	CHARACTER(kind=c_char), INTENT(in) :: new(*) !! Path of the new working directory
203	INTEGER(kind=C_INT) :: chdir_c !! 0 on success, last errno on failure
204	END FUNCTION chdir_c
205
206	FUNCTION mkdir_c(dirname,mode) BIND(C,name="c_mkdir")
207	!! Create directory
208	IMPORT c_char, C_INT
209	CHARACTER(kind=c_char), INTENT(in) :: dirname(*) !! Path of the directory to create
210	INTEGER(kind=C_INT), INTENT(in), VALUE :: mode !! Decimal permission to set
211	INTEGER(kind=C_INT) :: mkdir_c !! 0 on success, last errno on failure
212	END FUNCTION mkdir_c
213
214	FUNCTION mkdirp_c(dirname,mode) BIND(C,name="c_mkdirp")
215	!! Create directory recursively
216	IMPORT c_char, C_INT
217	CHARACTER(kind=c_char), INTENT(in) :: dirname(*) !! Path of the directory to create
218	INTEGER(kind=C_INT), INTENT(in), VALUE :: mode !! Decimal permission to set
219	INTEGER(kind=C_INT) :: mkdirp_c !! 0 on success, last errno on failure
220	END FUNCTION mkdirp_c
221
222	FUNCTION copy_c(to,from) BIND(C,name="c_copy")
223	!! Copy a file.
224	IMPORT c_char, C_INT
225	CHARACTER(kind=c_char), INTENT(in) :: to(*) !! Destination path.
226	CHARACTER(kind=c_char), INTENT(in) :: from(*) !! Input file path to copy.
227	INTEGER(kind=C_INT) :: copy_c !! 0 on success, 1 on failure.
228	END FUNCTION copy_c
229
230	FUNCTION remove_c(path) BIND(C,name="c_remove")
231	!! Remove a file (or a directory) from the filesystem
232	IMPORT c_char, C_INT
233	CHARACTER(kind=c_char), INTENT(in) :: path(*) !! Path to delete
234	INTEGER(kind=C_INT) :: remove_c !! 0 on success, last errno on failure
235	END FUNCTION remove_c
236
237	FUNCTION rmdir_c(dirpath) BIND(C,name="c_rmdir")
238	!! Remove empty directory
239	IMPORT c_char, C_INT
240	CHARACTER(kind=c_char), INTENT(in) :: dirpath(*) !! Directory to delete
241	INTEGER(kind=C_INT) :: rmdir_c !! 0 on success, last errno on failure
242	END FUNCTION rmdir_c
243
244	FUNCTION rmdirf_c(dirpath) BIND(C,name="c_rmdir_f")
245	!! Remove directory (forced)
246	IMPORT c_char, C_INT
247	CHARACTER(kind=c_char), INTENT(in) :: dirpath(*) !! Directory to delete
248	INTEGER(kind=C_INT) :: rmdirf_c !! 0 on success, last errno on failure
249	END FUNCTION rmdirf_c
250
251	FUNCTION fstat_c(pa, pe, ln, ty, ui, gi, si, at, mt, ct) BIND(C, name='c_fstat')
252	!! Get file informations
253	IMPORT c_char, c_long, C_INT
254	CHARACTER(kind=c_char), INTENT(in) :: pa(*) !! Path of the file
255	INTEGER(kind=C_INT), INTENT(out) :: pe !! Decimal permission of the path
256	INTEGER(kind=C_INT), INTENT(out) :: ln !! Number of links
257	INTEGER(kind=C_INT), INTENT(out) :: ty !! Type of the path
258	INTEGER(kind=C_INT), INTENT(out) :: ui !! User ID of the path
259	INTEGER(kind=C_INT), INTENT(out) :: gi !! Group ID of the path
260	INTEGER(kind=c_long), INTENT(out) :: si !! Size of the path
261	CHARACTER(kind=c_char), INTENT(out) :: at(20) !! Last access date
262	CHARACTER(kind=c_char), INTENT(out) :: mt(20) !! Last modification date
263	CHARACTER(kind=c_char), INTENT(out) :: ct(20) !! Creation date
264	INTEGER(kind=C_INT) :: fstat_c !! 0 on success, last errno on failure
265	END FUNCTION fstat_c
266
267	FUNCTION termsize_c(r,c) BIND(C, name='c_termsize')
268	!! Get terminal window size
269	IMPORT C_INT
270	INTEGER(kind=C_INT), INTENT(out) :: r, & !! Number of rows
271	c !! Number of columns
272	INTEGER(kind=C_INT) :: termsize_c !! 0 on success, last errno on failure
273	END FUNCTION termsize_c
274
275	FUNCTION getCurrentRSS_c() BIND(C, name="c_getCurrentRSS")
276	!! Get the current resident set size memory in bytes.
277	IMPORT C_SIZE_T
278	INTEGER(kind=C_SIZE_T) :: getCurrentRSS_c !! Current resident set size in bytes (0 if not available).
279	END FUNCTION getCurrentRSS_c
280
281	FUNCTION getPeakRSS_c() BIND(C, name="c_getPeakRSS")
282	!! Get the peak resident set size memory in bytes.
283	IMPORT C_SIZE_T
284	INTEGER(kind=C_SIZE_T) :: getPeakRSS_c !! Peak resident set size in bytes (0 if not available).
285	END FUNCTION getPeakRSS_c
286
287	FUNCTION getSystemMemory_c(total,avail,free) BIND(C, name='c_getSystemMemory')
288	!! Get global memory informations.
289	IMPORT C_LONG_LONG,C_INT
290	INTEGER(kind=C_LONG_LONG), INTENT(out) :: total !! Total available memory.
291	INTEGER(kind=C_LONG_LONG), INTENT(out) :: avail !! Current available memory.
292	INTEGER(kind=C_LONG_LONG), INTENT(out) :: free !! Current free memory.
293	INTEGER(kind=C_INT) :: getSystemMemory_c !! status, 0 on success, 1 otherwise.
294	END FUNCTION getSystemMemory_c
295	END INTERFACE
296	#endif
297
298	CONTAINS
299
300	FUNCTION fstring(string) RESULT(str)
301	!! Convert C string to Fortran string
302	!!
303	!! The method copies the input C string up to the last C_NULL_CHAR found (not including it),
304	!! and returns the converted Fortran string.
305	!! All other C_NULL_CHAR found in the C string are removed.
306	CHARACTER(len=*), INTENT(in) :: string !! A string from C
307	CHARACTER(len=:), ALLOCATABLE :: str !! Converted fortran string
308	INTEGER :: i,idx
309	str = ""
310	idx = INDEX(string,C_NULL_CHAR,.true.)
311	IF (idx == 0) THEN
312	str = string
313	ELSE
314	DO i=1,idx-1
315	IF (string(i:i) /= C_NULL_CHAR) str = str//string(i:i)
316	ENDDO
317	ENDIF
318	str = TRIM(str)
319	END FUNCTION fstring
320
321	FUNCTION cstr2fstr(cstr) RESULT(fstr)
322	!! Get a Fortran (allocatable) string from a C string
323	!!
324	!! The method build the fortran string from a TYPE(C_PTR) object that represent a
325	!! C char\* pointer string.
326	!! @note
327	!! If __cstr__ is not allocated (i.e. the C_PTR is not associated) or if it is set
328	!! to a C empty string (i.e. '\0') then the method returns an empty string.
329	!! @attention
330	!! The method does not free the underlying C string and it should be free using
331	!! the subroutine free_c(_cstr_).
332	TYPE(C_PTR), INTENT(in) :: cstr
333	!! A TYPE(C_PTR) that represent the pointer to the C char array.
334	CHARACTER(len=:), ALLOCATABLE :: fstr
335	!! An allocatable Fortran string with the content of the input char array.
336	CHARACTER(len=1,kind=C_CHAR), DIMENSION(:), POINTER :: pchars
337	INTEGER :: i,length
338	IF (.NOT.C_ASSOCIATED(cstr)) THEN
339	fstr = ""
340	RETURN
341	ENDIF
342	length = INT(strlen_c(cstr), kind=4)
343	IF (length ==0) THEN
344	fstr = ""
345	RETURN
346	ENDIF
347	CALL C_F_POINTER(cstr,pchars,(/length/))
348	ALLOCATE(CHARACTER(len=length) :: fstr)
349	DO i=1,length
350	fstr(i:i) = pchars(i)
351	ENDDO
352	END FUNCTION cstr2fstr
353
354
355	FUNCTION cstring(string) RESULT(str)
356	!> convert Fortran string to cstring
357	!!
358	!! The method returns a copy of the input string suitable for C functions argument.
359	!! @note
360	!! Input string is trimmed during computations
361	CHARACTER(len=*), INTENT(in) :: string
362	!! A fortran string
363	CHARACTER(len=:,kind=C_CHAR), ALLOCATABLE :: str
364	!! Same string as __string__ except that C_NULL_CHAR is appended at the end
365	INTEGER :: slen
366	slen = LEN_TRIM(string)
367	ALLOCATE(CHARACTER(len=slen+1,kind=C_CHAR) :: str)
368	str(:slen) = TRIM(string) ; str(slen+1:slen+1) = C_NULL_CHAR
369	END FUNCTION cstring
370
371	!===============================================================================
372	! C WRAPPER FUNCTIONS/SUBROUTINES
373	!===============================================================================
374
375	FUNCTION fs_getgid() RESULT(ret)
376	!! Get Group ID
377	INTEGER(kind=4) :: ret !! An integer with the group identifier
378	ret = INT(getgid_c(),kind=4)
379	RETURN
380	END FUNCTION fs_getgid
381
382	FUNCTION fs_getpid() RESULT(ret)
383	!! Get Process ID
384	INTEGER(kind=4) :: ret !! An integer with the current process identifier
385	ret = INT(getpid_c(),kind=4)
386	RETURN
387	END FUNCTION fs_getpid
388
389	FUNCTION fs_getuid() RESULT(ret)
390	!! Get User ID
391	INTEGER(kind=4) :: ret !! An integer with the user identifier
392	ret = INT(getuid_c(),kind=4)
393	RETURN
394	END FUNCTION fs_getuid
395
396	FUNCTION fs_gname(gid) RESULT(gname)
397	!! Get a group name from a group id
398	INTEGER, INTENT(in) :: gid !! User id to check
399	CHARACTER(len=:), ALLOCATABLE :: gname !! A string with the name of the group id
400	TYPE(C_PTR) :: zname
401	zname = gname_c(gid)
402	IF (.NOT.C_ASSOCIATED(zname)) THEN
403	gname = ""
404	ELSE
405	gname = cstr2fstr(zname)
406	ENDIF
407	CALL free_c(zname)
408	END FUNCTION fs_gname
409
410	FUNCTION fs_uname(uid) RESULT(uname)
411	!! Get a user name from a user id
412	INTEGER, INTENT(in) :: uid !! User id to check
413	CHARACTER(len=:), ALLOCATABLE :: uname !! A string with the name of the user id
414	TYPE(C_PTR) :: zname
415	zname = gname_c(uid)
416	IF (.NOT.C_ASSOCIATED(zname)) THEN
417	uname = ""
418	ELSE
419	uname = cstr2fstr(zname)
420	ENDIF
421	CALL free_c(zname)
422	END FUNCTION fs_uname
423
424	FUNCTION fs_dirname(path) RESULT(opath)
425	!! Get the parent directory path of the given path
426	CHARACTER(len=*), INTENT(in) :: path
427	!! A string with a (valid) path
428	CHARACTER(len=:), ALLOCATABLE :: opath
429	!! A Fortran allocated string with the parent directory path or an empty string if method fails
430	CHARACTER(len=:), ALLOCATABLE :: cpath
431	TYPE(C_PTR) :: zpath
432	IF (LEN_TRIM(path) == 0) THEN
433	opath = ""
434	RETURN
435	ENDIF
436	cpath = cstring(ADJUSTL(path))
437	zpath = dirname_c(cpath)
438	IF (.NOT.C_ASSOCIATED(zpath)) THEN
439	opath = ""
440	ELSE
441	opath = cstr2fstr(zpath)
442	ENDIF
443	CALL free_c(zpath)
444	END FUNCTION fs_dirname
445
446	FUNCTION fs_basename(path) RESULT(opath)
447	!! Get the base name of the path
448	CHARACTER(len=*), INTENT(in) :: path
449	!! A string with a (valid) path
450	CHARACTER(len=:), ALLOCATABLE :: opath
451	!! The basename of the path or an empty string if method fails
452	CHARACTER(len=:), ALLOCATABLE :: cpath
453	TYPE(C_PTR) :: zpath
454	IF (LEN_TRIM(path) == 0) THEN
455	opath = ""
456	RETURN
457	ENDIF
458	cpath = cstring(ADJUSTL(path))
459	zpath = basename_c(cpath)
460	IF (.NOT.C_ASSOCIATED(zpath)) THEN
461	opath = ""
462	ELSE
463	opath = cstr2fstr(zpath)
464	ENDIF
465	CALL free_c(zpath)
466	END FUNCTION fs_basename
467
468	FUNCTION fs_realpath(path) RESULT(opath)
469	!! Get the real path of the path
470	!!
471	!! The method computes the absolute path of the given path using C realpath function.
472	!! @note
473	!! If the input path is empty then current working directory is returned.
474	CHARACTER(len=*), INTENT(in) :: path
475	!! A string with a (valid) path
476	CHARACTER(len=:), ALLOCATABLE :: opath
477	!! The absolute of the path or an empty string if method fails
478	CHARACTER(len=:), ALLOCATABLE :: cpath
479	TYPE(C_PTR) :: zpath
480	cpath = cstring(ADJUSTL(path))
481	zpath = realpath_c(cpath)
482	IF (.NOT.C_ASSOCIATED(zpath)) THEN
483	opath = ""
484	ELSE
485	opath = cstr2fstr(zpath)
486	ENDIF
487	CALL free_c(zpath)
488	END FUNCTION fs_realpath
489
490	FUNCTION fs_relpath(path,reldir) RESULT(res)
491	!! Get the relative representation of two paths
492	!!
493	!! The method computes the relative representation of __path__ from __reldir__ if possible.
494	!! If no common prefix is found, the method returns __path__.
495	CHARACTER(len=*), INTENT(in) :: path, & !! Path to be computed relative to reldir
496	reldir !! A directory path from which output should be relative to
497	CHARACTER(len=:), ALLOCATABLE :: res !! An allocated string with the resulting path
498	CHARACTER(len=:), ALLOCATABLE :: cpath1,cpath2
499	TYPE(C_PTR) :: zpath
500	cpath1 = cstring(ADJUSTL(path))
501	cpath2 = cstring(ADJUSTL(reldir))
502	zpath = relpath_c(cpath1,cpath2)
503	IF (.NOT.C_ASSOCIATED(zpath)) THEN
504	res = TRIM(ADJUSTL(path))
505	ELSE
506	res = cstr2fstr(zpath)
507	ENDIF
508	CALL free_c(zpath)
509	END FUNCTION fs_relpath
510
511	FUNCTION fs_getcwd() RESULT(path)
512	!! Get the current working directory
513	CHARACTER(len=:), ALLOCATABLE :: path
514	!! The current working directory or an empty string if method fails
515	TYPE(C_PTR) :: zpath
516	zpath = getcwd_c()
517	IF (C_ASSOCIATED(zpath)) THEN
518	path = cstr2fstr(zpath)
519	ELSE
520	path = ""
521	ENDIF
522	CALL free_c(zpath)
523	RETURN
524	END FUNCTION fs_getcwd
525
526	FUNCTION fs_copy(input,output) RESULT(ret)
527	!! Copy input file into output file.
528	CHARACTER(len=*), INTENT(in) :: input !! Input file path to copy.
529	CHARACTER(len=*), INTENT(in) :: output !! Output file path destination.
530	LOGICAL :: ret !! True on success, false otherwise.
531	CHARACTER(len=:), ALLOCATABLE :: cpath1,cpath2
532
533	IF (LEN_TRIM(input) == 0 .OR. LEN_TRIM(output) == 0 .OR. input == output) THEN
534	ret = .false.
535	ELSE
536	cpath1 = cstring(ADJUSTL(output))
537	cpath2 = cstring(ADJUSTL(input))
538	ret = INT(copy_c(cpath1,cpath2)) == 0
539	ENDIF
540	RETURN
541	END FUNCTION fs_copy
542
543	FUNCTION fs_remove(path) RESULT(ret)
544	!! Delete the file/directory pointed by the given path
545	CHARACTER(len=*), INTENT(in) :: path !! A string with the (valid) file path to delete
546	LOGICAL :: ret !! True on success, false otherwise.
547	CHARACTER(len=:), ALLOCATABLE :: cpath
548	IF (LEN_TRIM(path) == 0) THEN
549	ret = .false.
550	ELSE
551	cpath = cstring(ADJUSTL(path))
552	ret = INT(remove_c(cpath)) == 0
553	ENDIF
554	RETURN
555	END FUNCTION fs_remove
556
557	FUNCTION fs_rename(old, new) RESULT(ret)
558	!! Rename a path
559	CHARACTER(len=*), INTENT(in) :: old, & !! A string with the (valid) path to rename
560	new !! A string with the new name of the path
561	LOGICAL :: ret !! True on success, false otherwise.
562	CHARACTER(len=:), ALLOCATABLE :: cpath1,cpath2
563	IF (LEN_TRIM(old) == 0.OR.LEN_TRIM(new) == 0) THEN
564	ret = .false.
565	ELSE
566	cpath1 = cstring(ADJUSTL(old))
567	cpath2 = cstring(ADJUSTL(new))
568	ret = INT(rename_c(cpath1,cpath2)) == 0
569	ENDIF
570	RETURN
571	END FUNCTION fs_rename
572
573	FUNCTION fs_chmod(path, mode) RESULT(ret)
574	!! Change file/directory permissions
575	CHARACTER(len=*), INTENT(in) :: path !! Path to modify
576	INTEGER, INTENT(in) :: mode !! New octal permissions of the file
577	LOGICAL :: ret !! True on success, false otherwise.
578	INTEGER(kind=C_INT) :: zmode
579	CHARACTER(len=:), ALLOCATABLE :: cpath
580	IF (LEN_TRIM(path) == 0) THEN
581	ret = .false.
582	ELSE
583	zmode = INT(oct_2_dec(mode),kind=C_INT)
584	cpath = cstring(ADJUSTL(path))
585	ret = INT(chmod_c(cpath, zmode)) == 0
586	ENDIF
587	RETURN
588	END FUNCTION fs_chmod
589
590	FUNCTION fs_chdir(path) RESULT(ret)
591	!! Change current working directory
592	CHARACTER(len=*), INTENT(in) :: path !! Path of the new working directory
593	LOGICAL :: ret !! True on success, false otherwise.
594	CHARACTER(len=:), ALLOCATABLE :: cpath
595	IF (LEN_TRIM(path) == 0) THEN
596	ret = .false.
597	ELSE
598	cpath = cstring(ADJUSTL(path))
599	ret = INT(chdir_c(cpath)) == 0
600	ENDIF
601	RETURN
602	END FUNCTION fs_chdir
603
604	FUNCTION fs_mkdir(path, mode, permissive) RESULT(ret)
605	!! Create directory
606	!!
607	!! The method attempts to create a new directory pointed by __path__ with the permission
608	!! given by mode.
609	CHARACTER(len=*), INTENT(in) :: path
610	!! The path to modify
611	INTEGER, INTENT(in), OPTIONAL :: mode
612	!! Optional octal permission to set for the new directory
613	LOGICAL, INTENT(in), OPTIONAL :: permissive
614	!! Optional boolean with .true. to create intermediate directories in the path
615	LOGICAL :: ret
616	!! True on success, false otherwise.
617	INTEGER :: zmode
618	LOGICAL :: zperm
619	CHARACTER(len=:), ALLOCATABLE :: cpath
620
621	IF (LEN_TRIM(path) == 0) THEN
622	ret = .false.
623	ELSE
624	zmode = oct_2_dec(744)
625	IF (PRESENT(mode)) THEN
626	IF (.NOT.chk_pm(mode)) THEN
627	ret = .false. ; RETURN
628	ENDIF
629	zmode = oct_2_dec(mode)
630	ENDIF
631	cpath = cstring(ADJUSTL(path))
632	zperm = .false. ; IF (PRESENT(permissive)) zperm = permissive
633	IF (zperm) THEN
634	ret = INT(mkdirp_c(cpath,INT(zmode,kind=C_INT))) == 0
635	ELSE
636	ret = INT(mkdir_c(cpath,INT(zmode,kind=C_INT))) == 0
637	ENDIF
638	ENDIF
639	RETURN
640	END FUNCTION fs_mkdir
641
642	FUNCTION fs_rmdir(path,forced) RESULT(ret)
643	!! Remove directory
644	!!
645	!! By default, the function removes an __empty__ directory. If __forced__ is given and set
646	!! to .true. then the function recursively deletes the directory and __ALL__ its content.
647	CHARACTER(len=*), INTENT(in) :: path
648	!! The path of the directory to delete
649	LOGICAL, INTENT(in), OPTIONAL :: forced
650	!! Optional boolean with @ti{.true.} to remove all contents of the directory.
651	LOGICAL :: ret
652	!! True on success, false otherwise.
653	LOGICAL :: zforce
654	CHARACTER(len=:), ALLOCATABLE :: cpath
655	IF (LEN_TRIM(path) == 0) THEN
656	ret = .false.
657	ELSE
658	zforce = .false. ; IF (PRESENT(forced)) zforce = forced
659	cpath = cstring(ADJUSTL(path))
660	IF (.NOT.zforce) THEN
661	ret = INT(rmdir_c(cpath)) == 0
662	ELSE
663	ret = INT(rmdirf_c(cpath)) == 0
664	ENDIF
665	ENDIF
666	RETURN
667	END FUNCTION fs_rmdir
668
669	FUNCTION fs_stat(path,type,perm,nlnks,uid,gid,fsize,atime,mtime,ctime) RESULT(ret)
670	!! Get some informations about a path
671	!!
672	!! The method retrieves various informations about the input path using fstat C function.
673	!! The type of path as returned in __type__ argument is can take the following values:
674	!!
675	!! - 0, a file
676	!! - 1, a link to a file
677	!! - 2, a directory
678	!! - 3, a link to a directory
679	!! - 4, other (fifo, socket, block special, char special...)
680	CHARACTER(len=*), INTENT(in) :: path !! Input path
681	INTEGER, INTENT(out), OPTIONAL :: type, & !! Optional type of path (see function documentation).
682	perm, & !! Optional permission of the path
683	nlnks, & !! Optional number of links to the path
684	uid, & !! Optional user id
685	gid !! Optional group id
686	INTEGER(kind=8), INTENT(out), OPTIONAL :: fsize !! Optional file size
687	CHARACTER(len=19), INTENT(out), OPTIONAL :: atime, & !! Optional last access time
688	mtime, & !! Optional last modification time
689	ctime !! Optional creation time
690	LOGICAL :: ret !! True on success, false otherwise.
691	INTEGER :: ty,pe,ln,ud,gd
692	INTEGER(kind=8) :: fs
693	CHARACTER(len=:), ALLOCATABLE :: at,mt,ct
694	INTEGER(kind=C_INT) :: p,l,t,u,g
695	INTEGER(kind=c_long) :: f
696	CHARACTER(len=20,kind=C_CHAR) :: ta,tm,tc
697	CHARACTER(len=:), ALLOCATABLE :: cpath
698	IF (LEN_TRIM(path) == 0) THEN
699	ret = .false.; RETURN
700	ELSE IF (.NOT.(PRESENT(type) .OR. PRESENT(perm) .OR. PRESENT(nlnks) .OR. &
701	PRESENT(uid) .OR. PRESENT(gid) .OR. PRESENT(fsize) .OR. &
702	PRESENT(atime) .OR. PRESENT(mtime) .OR. PRESENT(ctime))) THEN
703	ret = .true.
704	ELSE
705	! set default values
706	pe=-1 ; ty=-1 ; ud=-1 ; gd=-1 ; fs=-1 ; at="" ; mt="" ; ct=""
707	cpath = cstring(ADJUSTL(path))
708	ret = INT(fstat_c(cpath,p,l,t,u,g,f,ta,tm,tc)) == 0
709	IF (ret) THEN
710	pe=INT(p) ; ln=INT(l) ; ty=INT(t) ; ud=INT(u) ; gd=INT(g)
711	fs=INT(f,kind=8)
712	at = fstring(ta)
713	mt = fstring(tm)
714	ct = fstring(tc)
715	ENDIF
716	IF (PRESENT(type)) type = ty
717	IF (PRESENT(perm)) perm = pe
718	IF (PRESENT(nlnks)) nlnks = ln
719	IF (PRESENT(uid)) uid = ud
720	IF (PRESENT(gid)) gid = gd
721	IF (PRESENT(fsize)) fsize = fs
722	IF (PRESENT(atime)) atime = at
723	IF (PRESENT(mtime)) mtime = mt
724	IF (PRESENT(ctime)) ctime = ct
725	ENDIF
726	RETURN
727	END FUNCTION fs_stat
728
729	FUNCTION fs_isdir(path) RESULT (ret)
730	!! Check if a path is a directory
731	!!
732	!! The method is just a wrapper of [[fsystem(module):fs_stat(function)]] to get only specific
733	!! information about __path__ type.
734	CHARACTER(len=*), INTENT(in) :: path !! The path to check
735	LOGICAL :: ret !! .true. if the path is a directory, .false. otherwise.
736	INTEGER :: ty
737	ret = fs_stat(path,type=ty)
738	ret = ret.AND.(ty==2.or.ty==3)
739	RETURN
740	END FUNCTION fs_isdir
741
742	FUNCTION fs_isfile(path) RESULT (ret)
743	!! Check if a path is a file
744	!!
745	!! The method is just a wrapper of [[fsystem(module):fs_stat(function)]] to get only specific
746	!! information about __path__ type.
747	CHARACTER(len=*), INTENT(in) :: path !! The path to check
748	LOGICAL :: ret !! .true. if the path is a file, .false. otherwise.
749	INTEGER :: ty
750	ret=fs_stat(path,type=ty)
751	ret = ret.and.(ty==0.or.ty==1)
752	RETURN
753	END FUNCTION fs_isfile
754
755	FUNCTION fs_islink(path) RESULT (ret)
756	!! Check if a path is a link
757	!!
758	!! The method is just a wrapper of [[fsystem(module):fs_stat(function)]] to get only specific
759	!! information about __path__ type.
760	CHARACTER(len=*), INTENT(in) :: path !! The path to check
761	LOGICAL :: ret !! .true. if the path is a link, .false. otherwise.
762	INTEGER :: ty
763	ret=fs_stat(path,type=ty)
764	ret = ret.and.(ty==1.or.ty==3)
765	RETURN
766	END FUNCTION fs_islink
767
768	FUNCTION fs_access(path,permission) RESULT(ret)
769	!! Check if a path is accessible for current user
770	!!
771	!! The method checks if the given path is accessible for the current user. By default,
772	!! it does not check for specific permissions. If __permission__ is given it should be
773	!! an integer between 0 and 7 resulting from the possible combinations:
774	!!
775	!! - 0 : Checks for path existence (default)
776	!! - 1 : Checks for EXECUTE permission
777	!! - 2 : Checks for WRITE permission
778	!! - 4 : Checks for READ permission
779	CHARACTER(len=*), INTENT(in) :: path !! Path to check
780	INTEGER, INTENT(in), OPTIONAL :: permission !! Optional permission to check
781	LOGICAL :: ret !! True on success, false otherwise.
782	INTEGER(kind=C_INT) :: zp
783	CHARACTER(len=:), ALLOCATABLE :: cpath
784	IF (LEN_TRIM(path) == 0) THEN
785	ret = .false.
786	ELSE
787	zp = 0 ; IF (PRESENT(permission)) zp = INT(permission,kind=C_INT)
788	! Defaults are set in the C function.
789	cpath = cstring(ADJUSTL(path))
790	ret = INT(access_c(cpath,zp)) == 0
791	ENDIF
792	RETURN
793	END FUNCTION fs_access
794
795	FUNCTION fs_split_ext(path, base, ext, absolute) RESULT(ret)
796	!! Split given path into base,extension
797	!!
798	!! The __base__ of a path is conventionnally defined as all characters before the last dot of the path.
799	!! The extension (__ext__) of the path gathers consequently all characters from the last dot to the end
800	!! of the string.
801	!! @note
802	!! If the basename of the path begins by a dot then the path is assumed to be an hidden file (directory).
803	!! __ext__ will then be empty.
804	CHARACTER(len=*), INTENT(in) :: path !! Path to split
805	CHARACTER(len=:), INTENT(out), ALLOCATABLE :: base, & !! Output base of the path
806	ext !! Output extension of the path
807	LOGICAL, INTENT(in), OPTIONAL :: absolute !! .true. to return absolute path
808	LOGICAL :: ret !! .true. on success, .false. otherwise.
809	LOGICAL :: zabs
810	INTEGER :: p
811	CHARACTER(len=:), ALLOCATABLE :: d,b,apath
812	base = "" ; ext = ""
813	ret = .false.
814	IF (LEN_TRIM(path) == 0) THEN
815	RETURN
816	ENDIF
817	zabs = .false. ; IF (PRESENT(absolute)) zabs = absolute
818	apath = TRIM(path)
819	IF (zabs) THEN
820	apath = fs_realpath(path) ; IF (LEN_TRIM(apath) == 0) RETURN
821	ENDIF
822	d = fs_dirname(apath) ; IF (LEN_TRIM(d) == 0) RETURN
823	b = fs_basename(apath) ; IF (LEN_TRIM(b) == 0) RETURN
824	p = INDEX(b,".",.true.)
825	! If dot is set as first char of basename : it's an hidden file
826	IF (p > 1) THEN
827	ext = b(p:) ; base = TRIM(d)//"/"//b(:p-1)
828	ELSE
829	base = TRIM(apath)
830	ENDIF
831	ret = .true.
832	RETURN
833	END FUNCTION fs_split_ext
834
835	FUNCTION fs_create(path, mode, type, permissive) RESULT(ret)
836	!! Create a directory/file
837	!!
838	!! The method creates the file/directory pointed by given __path__.
839	!! If __type__ is not given, the method builds the path as :
840	!!
841	!! -# A file if the basename of the path contains an extension
842	!! -# A directory in any other cases.
843	!!
844	!! Otherwise __type__ should be set to "f" for file or "d" for directory.
845	!!
846	!! Unless __permissive__ is set to .true., the method will fails if intermediate
847	!! directories in the path do not exist.
848	CHARACTER(len=*), INTENT(in) :: path !! Path to create
849	INTEGER, INTENT(in), OPTIONAL :: mode !! Optional octal permisions to set
850	CHARACTER(len=1), INTENT(in), OPTIONAL :: type !! Optional type of path to create
851	LOGICAL, INTENT(in), OPTIONAL :: permissive !! .true. to create intermediate directories if not existing
852	LOGICAL :: ret !! True on success, false otherwise.
853	INTEGER :: zmd,zt,zp
854	CHARACTER(len=:), ALLOCATABLE :: b,e
855	CHARACTER(len=:), ALLOCATABLE :: cpath
856	ret = .false.
857	! Checking for existence
858	IF (LEN_TRIM(path) == 0) THEN
859	RETURN
860	ELSE IF (fs_access(path)) THEN
861	RETURN
862	ENDIF
863	! Set type of path
864	IF (PRESENT(type)) THEN
865	IF (.NOT.(type(1:1)=="f".OR.type(1:1)=="d")) THEN
866	RETURN
867	ELSE
868	zt=0 ; IF (type(1:1)=="f") zt = 1
869	ENDIF
870	ELSE
871	IF(.NOT.fs_split_ext(path,b,e)) RETURN
872	zt = 0 ; IF (LEN_TRIM(e) /= 0) zt=1
873	ENDIF
874	! set permissions according to type
875	IF (zt == 0) THEN
876	zmd = oct_2_dec(777)-get_umask()
877	ELSE
878	zmd = oct_2_dec(666) -get_umask()
879	ENDIF
880	! Check mode argument if present
881	IF (PRESENT(mode)) THEN
882	IF(.NOT.chk_pm(mode)) THEN
883	! not a valid permission : We raise an error and abort
884	RETURN
885	ELSE
886	zmd = oct_2_dec(mode)
887	ENDIF
888	ENDIF
889	zp = 0 ; IF(PRESENT(permissive)) THEN ; IF(permissive) zp=1 ; ENDIF
890
891	cpath = cstring(ADJUSTL(path))
892	ret = INT(create_c(cpath,INT(zmd,kind=C_INT),INT(zt,kind=C_INT),INT(zp,kind=C_INT))) == 0
893	RETURN
894	END FUNCTION fs_create
895
896	FUNCTION fs_get_parent(path, n) RESULT(opath)
897	!! Get the nth parent of the given path
898	!!
899	!! The method first resolves the given path using [[fsystem(module):fs_realpath(function)]]
900	!! to get an absolute path.
901	!! @note
902	!! If __n__ is greater than the maximum parent level of the path, "/" is returned.
903	CHARACTER(len=*), INTENT(in) :: path
904	!! Input path
905	INTEGER, INTENT(in), OPTIONAL :: n
906	!! The level of the parent to get
907	CHARACTER(len=:), ALLOCATABLE :: opath
908	!! The nth parent of the given path, or an empty string if the parent can not be computed
909	CHARACTER(len=:), ALLOCATABLE :: zp
910	INTEGER :: i,mx,zl,mzl
911	opath = ""
912	zl = 1 ; IF (PRESENT(n)) zl = MAX(n,1)
913	IF (LEN_TRIM(path) == 0) THEN
914	RETURN
915	ENDIF
916	! Gets the absolute path
917	zp = fs_realpath(TRIM(ADJUSTL(path)))
918	IF (LEN_TRIM(zp) == 0) RETURN
919	! removing trailing / (only if it's not the first ^^)
920	mx = LEN_TRIM(zp) ; IF (zp(mx:mx)=="/".AND.mx/=1) zp(mx:mx) = ""
921	! compute maximum level
922	mzl = 1 ; DO i=1,mx ; IF(zp(i:i) == '/') mzl=mzl+1 ; ENDDO
923	i=0
924	DO
925	mx = INDEX(zp(1:mx),'/',.true.) ; i=i+1
926	IF (mx==0.OR.i>=zl.OR.i>=mzl) EXIT
927	mx = mx - 1
928	ENDDO
929	IF (mx >= 1) THEN
930	opath = zp(1:MAX(1,mx-1))
931	ELSE
932	opath = "/"
933	ENDIF
934	RETURN
935	END FUNCTION fs_get_parent
936
937	SUBROUTINE fs_termsize(row, column)
938	!! Get the current terminal window size
939	!! @attention
940	!! If the program is redirected to a file (and maybe some other device), the C
941	!! function can raise an error. In that case, the default values (20,80) are
942	!! returned by the C function and thus the subroutine !
943	INTEGER, INTENT(out) :: row, & !! Number of rows of the window
944	column !! Number of columns of the window
945	INTEGER(kind=C_INT) :: r, c, ret
946	ret = termsize_c(r,c)
947	row = INT(r) ; column = INT(c)
948	RETURN
949	END SUBROUTINE fs_termsize
950
951	SUBROUTINE fs_usleep(usec)
952	!! Sleep for a given number of microseconds
953	!! @note
954	!! Currently if C usleep function failed, the system... does not sleep !
955	INTEGER, INTENT(in) :: usec !! The number of microseconds to sleep for
956	INTEGER(kind=C_INT) :: ret
957	! usleep expects useconds_t (unsigned int) which is given here as a 4-bytes int
958	ret = usleep_c(INT(usec,kind=C_INT))
959	END SUBROUTINE fs_usleep
960
961	SUBROUTINE fs_msleep(msec)
962	!! Sleep for a given number of milliseconds
963	INTEGER, INTENT(in) :: msec !! The number of milliseconds to sleep for
964	CALL fs_usleep(msec*1000)
965	END SUBROUTINE fs_msleep
966
967	FUNCTION fs_get_memory(peak,units) RESULT(mem)
968	!! Get the memory usage of the current process.
969	LOGICAL, INTENT(in), OPTIONAL :: peak !! True to retrieve the peak RSS memory, otherwise retrieve the current RSS memory. Default to False.
970	CHARACTER(len=*), INTENT(in), OPTIONAL :: units !! Output units: either 'B' (Bytes),'KB' (Kilo-),'MB' (Mega-),'GB' (Giga-). Default to 'B'.
971	REAL(kind=8) :: mem !! Memory usage.
972	LOGICAL :: zpeak
973	CHARACTER(len=2) :: zunits
974	zpeak = .false. ; IF (PRESENT(peak)) zpeak = peak
975	zunits = 'B ' ; IF (PRESENT(units)) zunits = units
976	IF (zunits /= 'B' .AND. zunits /= 'KB' .AND. zunits /= 'MB' .AND. zunits /= 'GB') zunits = 'B '
977	IF (zpeak) THEN
978	mem = REAL(getPeakRSS_c(),kind=8)
979	ELSE
980	mem = REAL(getCurrentRSS_c(),kind=8)
981	ENDIF
982	IF (zunits == 'KB') THEN
983	mem = mem / 1024d0
984	ELSE IF (zunits == 'MB') THEN
985	mem = mem / 1048576d0
986	ELSE IF (zunits == 'GB') THEN
987	mem = mem / 1073741824d0
988	ENDIF
989	RETURN
990	END FUNCTION fs_get_memory
991
992	FUNCTION fs_get_system_memory(total,available,free,units) RESULT(ret)
993	!! Get informations about system memory.
994	!!
995	!! If no informations is available, output arguments are set to 0 and the method returns false.
996	REAL(kind=8), INTENT(out), OPTIONAL :: total !! Total available memory.
997	REAL(kind=8), INTENT(out), OPTIONAL :: available !! Current available memory.
998	REAL(kind=8), INTENT(out), OPTIONAL :: free !! Current free memory.
999	CHARACTER(len=*), INTENT(in), OPTIONAL :: units !! Output units: either 'B' (Bytes),'KB' (Kilo-),'MB' (Mega-),'GB' (Giga-). Default to 'B'.
1000	LOGICAL :: ret !! True on success, false otherwise.
1001	LOGICAL :: zpeak
1002	CHARACTER(len=2) :: zunits
1003	INTEGER(kind=8) :: ztot,zava,zfre
1004
1005	zunits = 'B ' ; IF (PRESENT(units)) zunits = units
1006	IF (zunits /= 'B' .AND. zunits /= 'KB' .AND. zunits /= 'MB' .AND. zunits /= 'GB') zunits = 'B '
1007	ret = INT(getSystemMemory_c(ztot,zava,zfre),kind=4) == 0
1008	ztot = ztot * 1024 ; zava = zava * 1024 ; zfre = zfre * 1024
1009
1010	IF (PRESENT(total)) total = ztot
1011	IF (PRESENT(available)) available = zava
1012	IF (PRESENT(free)) free = zfre
1013	IF (.NOT.ret) RETURN
1014
1015	IF (zunits == 'KB') THEN
1016	IF (PRESENT(total)) total = ztot / 1024d0
1017	IF (PRESENT(available)) available = zava / 1024d0
1018	IF (PRESENT(free)) free = zfre / 1024d0
1019	ELSE IF (zunits == 'MB') THEN
1020	IF (PRESENT(total)) total = ztot / 1048576d0
1021	IF (PRESENT(available)) available = zava / 1048576d0
1022	IF (PRESENT(free)) free = zfre / 1048576d0
1023	ELSE IF (zunits == 'GB') THEN
1024	IF (PRESENT(total)) total = ztot / 1073741824d0
1025	IF (PRESENT(available)) available = zava / 1073741824d0
1026	IF (PRESENT(free)) free = zfre / 1073741824d0
1027	ENDIF
1028	RETURN
1029	END FUNCTION fs_get_system_memory
1030
1031
1032	!===============================================================================
1033	! MODULE MISCELLANEOUS METHODS
1034	!===============================================================================
1035
1036	FUNCTION oct_2_dec(octal) RESULT(res)
1037	!> Octal to decimal conversion
1038	!!
1039	!! The method converts the octal number ranging from 0 to 777 in the decimal system.
1040	!! @attention
1041	!! If the __octal__ number is out of range then the method returns 384 (600 in octal).
1042	INTEGER, INTENT(in) :: octal !! The octal value to convert
1043	INTEGER :: res !! The converted decimal value
1044	INTEGER :: o,d,i
1045	IF (octal < 0 .OR. octal > 777) THEN
1046	res = 384 ; RETURN ! --> 600 in octal : rw-------
1047	ENDIF
1048	d = 0 ; i = 0 ; o = octal
1049	DO WHILE(o/=0)
1050	d=d+mod(o,10)8*i ; i=i+1 ; o=o/10
1051	ENDDO
1052	res=d
1053	RETURN
1054	END FUNCTION oct_2_dec
1055
1056	FUNCTION dec_2_oct(decimal) RESULT(res)
1057	!! Decimal to octal conversion
1058	!! The method converts the decimal number ranging from 0 to 511 in the octal system.
1059	!! @attention
1060	!! If the __decimal__ number is out of range, then it the method returns 600 (384 in decimal).
1061	INTEGER, INTENT(in) :: decimal !! The decimal value to convert
1062	INTEGER :: res !! The converted octal value
1063	! - LOCAL
1064	INTEGER :: o,d,i,m
1065	IF (decimal < 0 .OR. decimal > 511) THEN
1066	res = 600 ; RETURN ! --> 384 in decimal : rw-------
1067	ENDIF
1068	o=0 ; d = decimal ; i=0 ; m=0
1069	DO WHILE(d/=0)
1070	d=d/8 ; m=m+1
1071	ENDDO
1072	m=m-1 ; d=decimal
1073	DO i=0,m
1074	o=o+mod(d,8)10*i ; d=d/8
1075	ENDDO
1076	res = o
1077	RETURN
1078	END FUNCTION dec_2_oct
1079
1080	FUNCTION sp_2_op(str) RESULT(oct)
1081	!! Get octal number of string representation's permission
1082	CHARACTER(len=3),INTENT(in) :: str !! The permission to convert
1083	INTEGER :: oct !! Octal value of the string permission on succes, -1 otherwise.
1084	oct = -1
1085	IF (LEN_TRIM(str) /= 3) RETURN
1086	SELECT CASE(str)
1087	CASE("---") ; oct = 0
1088	CASE("--x") ; oct = 1
1089	CASE("-w-") ; oct = 2
1090	CASE("-wx") ; oct = 3
1091	CASE("r--") ; oct = 4
1092	CASE("r-x") ; oct = 5
1093	CASE("rw-") ; oct = 6
1094	CASE("rwx") ; oct = 7
1095	CASE DEFAULT
1096	oct = -1 ; RETURN
1097	END SELECT
1098	RETURN
1099	END FUNCTION sp_2_op
1100
1101	FUNCTION op_2_sp(oct) RESULT(str)
1102	!! Get string representation of the octal number's permission
1103	INTEGER, INTENT(in) :: oct !! Octal number to convert
1104	CHARACTER(len=3) :: str !! String representation of the octal number on succes, 'ukn' otherwise
1105	SELECT CASE(oct)
1106	CASE(0) ; str="---"
1107	CASE(1) ; str="--x"
1108	CASE(2) ; str="-w-"
1109	CASE(3) ; str="-wx"
1110	CASE(4) ; str="r--"
1111	CASE(5) ; str="r-x"
1112	CASE(6) ; str="rw-"
1113	CASE(7) ; str="rwx"
1114	CASE DEFAULT
1115	str='ukn' ; RETURN
1116	END SELECT
1117	RETURN
1118	END FUNCTION op_2_sp
1119
1120	FUNCTION str_perm(oct_perm) RESULT(ret)
1121	!! Get the string representation of the given permission mask
1122	INTEGER, INTENT(in) :: oct_perm !! The octal representation of the permission
1123	CHARACTER(len=9) :: ret !! String representation of the octal number on succes, 'ukn' otherwise
1124	INTEGER :: u,g,o
1125	IF (.NOT.chk_pm(oct_perm)) THEN
1126	ret = "ukn" ; RETURN
1127	ENDIF
1128	u=int(oct_perm/100) ; g=int((oct_perm-u100)/10) ; o=int(oct_perm-u100-g*10)
1129	ret(1:3) = op_2_sp(u) ; ret(4:6) = op_2_sp(g) ; ret(7:9) = op_2_sp(o)
1130	RETURN
1131	END FUNCTION str_perm
1132
1133	FUNCTION oct_perm(str) RESULT(ret)
1134	!! Get the string representation of the given permission mask
1135	CHARACTER(len=9), INTENT(in) :: str !! The string representation of the permission
1136	INTEGER :: ret !! Octal permission on success, -1 otherwise
1137	! - LOCAL
1138	INTEGER :: u,g,o
1139	u = sp_2_op(str(1:3)) ; g = sp_2_op(str(4:6)) ; o = sp_2_op(str(7:9))
1140	IF (u==-1.OR.g==-1.OR.o==-1) THEN
1141	ret = -1 ; RETURN
1142	ELSE
1143	ret = u100 + g10 + o
1144	ENDIF
1145	RETURN
1146	END FUNCTION oct_perm
1147
1148	FUNCTION chk_pm(perm) RESULT(valid)
1149	!! Check if the given permission is valid
1150	INTEGER, INTENT(in) :: perm !! Octal permission mask
1151	LOGICAL :: valid !! .true. if the permission mask is valid, .false. otherwise
1152	INTEGER :: u,g,o
1153	u=int(perm/100) ; g=int((perm-u100)/10) ; o=int(perm-u100-g*10)
1154	valid = (u>=0.AND.u<=7).AND.(g>=0.AND.g<=7).AND.(o>=0.AND.o<=7)
1155	RETURN
1156	END FUNCTION chk_pm
1157
1158	FUNCTION get_umask() RESULT(mask)
1159	!! Get the umask value of the current session
1160	INTEGER :: mask !! Current umask value in decimal system
1161	mask = INT(umask_c())
1162	RETURN
1163	END FUNCTION get_umask
1164
1165	FUNCTION sz2str(file_size) RESULT(fstr)
1166	!! Get a human readable file size
1167	INTEGER(kind=8), INTENT(in) :: file_size !! File size (assumed to be bytes)
1168	CHARACTER(len=50) :: fstr !! Size in a human readable format
1169	! - LOCAL
1170	INTEGER :: cc
1171	REAL(kind=8) :: zfs
1172	CHARACTER(len=2), DIMENSION(6), PARAMETER :: sn = &
1173	(/'B ','KB','MB','GB','TB','PB'/)
1174	zfs=DBLE(file_size)
1175	DO cc=1,size(sn)-1 ; IF (zfs<1024.) EXIT ; zfs=zfs/1024. ; ENDDO
1176	IF (MOD(zfs,1.0) == 0) THEN
1177	WRITE(fstr,'(I50)') INT(zfs) ; fstr = TRIM(ADJUSTL(fstr))//sn(cc)
1178	ELSE
1179	WRITE(fstr,'(F50.2)') zfs ; fstr = TRIM(ADJUSTL(fstr))//sn(cc)
1180	ENDIF
1181	RETURN
1182	END FUNCTION sz2str
1183
1184	FUNCTION chrono_is_running(this) RESULT (ret)
1185	!! Get chrono's state.
1186	OBJECT(chrono), INTENT(in) :: this !! Chrono object reference.
1187	LOGICAL :: ret !! Running state.
1188	ret = this%on_run
1189	RETURN
1190	END FUNCTION chrono_is_running
1191
1192	SUBROUTINE chrono_start(this)
1193	!! Start the chrono.
1194	!!
1195	!! @note
1196	!! Calling the method multiple times without explicitly stopping the chrono
1197	!! [[chrono(type):stop(bound)]] does nothing (except for the first called).
1198	OBJECT(chrono), INTENT(inout) :: this !! Chrono object reference.
1199	IF (.NOT.this%on_run) THEN
1200	CALL CPU_TIME(this%cpu_start)
1201	CALL SYSTEM_CLOCK(this%clock_start)
1202	ENDIF
1203	this%on_run = .true.
1204	END SUBROUTINE chrono_start
1205
1206	SUBROUTINE chrono_stop(this)
1207	!! Stop the chrono.
1208	OBJECT(chrono), INTENT(inout) :: this !! Chrono object reference.
1209	REAL(kind=8) :: ecpu
1210	INTEGER(kind=8) :: eclk,nbm,nbr
1211	this%on_run = .false.
1212	END SUBROUTINE chrono_stop
1213
1214	SUBROUTINE chrono_reset(this)
1215	!! Reset the chrono's internal elapsed times.
1216	OBJECT(chrono), INTENT(inout) :: this !! Chrono object reference.
1217	CALL CPU_TIME(this%cpu_start)
1218	CALL SYSTEM_CLOCK(this%clock_start)
1219	END SUBROUTINE chrono_reset
1220
1221	SUBROUTINE chrono_get(this,cpu,clock,units)
1222	!! Get elapsed time since last call of start or reset methods.
1223	!!
1224	!! The method computes the time elapsed in two ways :
1225	!!
1226	!! - If the [[fsystem(module):chrono(type)]] is not running, the method retruns 0.
1227	!! - Otherwise, elapsed time since the last call of
1228	!! [[chrono(type):start(bound)]] (or [[chrono(type):reset(bound)]]).
1229	OBJECT(chrono), INTENT(in) :: this
1230	!! Chrono object reference.
1231	REAL(kind=8), INTENT(out), OPTIONAL :: cpu
1232	!! Elapsed cpu time in seconds by default (see units argument).
1233	REAL(kind=8), INTENT(out), OPTIONAL :: clock
1234	!! Elapsed system clock time in seconds by default (see units argument).
1235	CHARACTER(len=2), INTENT(in), OPTIONAL :: units
1236	!! A two characters wide string with the units to convert in. Units should
1237	!! be one of the following : 'ms', 's' (default), 'm', 'h' or 'd'.
1238	CHARACTER(len=2) :: zu
1239	REAL(kind=8) :: cu, fact
1240	INTEGER(kind=8) :: ck, r, m
1241	IF (this%on_run) THEN
1242	IF (PRESENT(cpu)) THEN
1243	CALL CPU_TIME(cu)
1244	cpu = (cu - this%cpu_start)
1245	ENDIF
1246	IF (PRESENT(clock)) THEN
1247	CALL SYSTEM_CLOCK(ck,r,m)
1248	clock = c2t(ck,this%clock_start,r,m)
1249	ENDIF
1250	ELSE
1251	IF (PRESENT(cpu)) cpu = 0d0
1252	IF (PRESENT(clock)) clock = 0d0
1253	ENDIF
1254	fact = 1d0
1255	zu = 's'
1256	IF (PRESENT(units)) THEN
1257	zu = units
1258	SELECT CASE(zu)
1259	CASE ('d') ; fact = 3600d0*24.
1260	CASE ('h') ; fact = 3600d0
1261	CASE ('m') ; fact = 60d0
1262	CASE ('ms') ; fact = 1d-3
1263	CASE DEFAULT ; fact = 1d0
1264	END SELECT
1265	ENDIF
1266	IF (PRESENT(cpu)) cpu = cpu / fact
1267	IF (PRESENT(clock)) clock = clock / fact
1268	END SUBROUTINE chrono_get
1269
1270	FUNCTION c2t(e,i,r,m) RESULT(time)
1271	!! Get the real-time between two clock counts from system_clock.
1272	INTEGER(kind=8), INTENT(in) :: e !! Final clock count
1273	INTEGER(kind=8), INTENT(in) :: i !! Initial clock count
1274	INTEGER(kind=8), INTENT(in) :: r !! Clock count rate
1275	INTEGER(kind=8), INTENT(in) :: m !! Maximum Clock count value
1276	REAL(kind=8) :: time !! Time in seconds
1277	INTEGER(kind=8) :: nc
1278	nc = e-i ; IF (e < i) nc = nc+m
1279	time = REAL(nc,kind=8)/r
1280	RETURN
1281	END FUNCTION c2t
1282	END MODULE FSYSTEM
1283

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

Original Format