Context Navigation

fsystem.F90 @ 3094

Last change on this file since 3094 was 3090, checked in by slebonnois, 15 months ago
BdeBatz? : Cleans microphysics and makes few corrections for physics
File size: 48.2 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	TYPE(C_PTR) :: zpath
431	IF (LEN_TRIM(path) == 0) THEN
432	opath = ""
433	RETURN
434	ENDIF
435	zpath = dirname_c(cstring(ADJUSTL(path)))
436	IF (.NOT.C_ASSOCIATED(zpath)) THEN
437	opath = ""
438	ELSE
439	opath = cstr2fstr(zpath)
440	ENDIF
441	CALL free_c(zpath)
442	END FUNCTION fs_dirname
443
444	FUNCTION fs_basename(path) RESULT(opath)
445	!! Get the base name of the path
446	CHARACTER(len=*), INTENT(in) :: path
447	!! A string with a (valid) path
448	CHARACTER(len=:), ALLOCATABLE :: opath
449	!! The basename of the path or an empty string if method fails
450	TYPE(C_PTR) :: zpath
451	IF (LEN_TRIM(path) == 0) THEN
452	opath = ""
453	RETURN
454	ENDIF
455	zpath = basename_c(cstring(ADJUSTL(path)))
456	IF (.NOT.C_ASSOCIATED(zpath)) THEN
457	opath = ""
458	ELSE
459	opath = cstr2fstr(zpath)
460	ENDIF
461	CALL free_c(zpath)
462	END FUNCTION fs_basename
463
464	FUNCTION fs_realpath(path) RESULT(opath)
465	!! Get the real path of the path
466	!!
467	!! The method computes the absolute path of the given path using C realpath function.
468	!! @note
469	!! If the input path is empty then current working directory is returned.
470	CHARACTER(len=*), INTENT(in) :: path
471	!! A string with a (valid) path
472	CHARACTER(len=:), ALLOCATABLE :: opath
473	!! The absolute of the path or an empty string if method fails
474	TYPE(C_PTR) :: zpath
475	zpath = realpath_c(cstring(ADJUSTL(path)))
476	IF (.NOT.C_ASSOCIATED(zpath)) THEN
477	opath = ""
478	ELSE
479	opath = cstr2fstr(zpath)
480	ENDIF
481	CALL free_c(zpath)
482	END FUNCTION fs_realpath
483
484	FUNCTION fs_relpath(path,reldir) RESULT(res)
485	!! Get the relative representation of two paths
486	!!
487	!! The method computes the relative representation of __path__ from __reldir__ if possible.
488	!! If no common prefix is found, the method returns __path__.
489	CHARACTER(len=*), INTENT(in) :: path, & !! Path to be computed relative to reldir
490	reldir !! A directory path from which output should be relative to
491	CHARACTER(len=:), ALLOCATABLE :: res !! An allocated string with the resulting path
492	TYPE(C_PTR) :: zpath
493	zpath = relpath_c(cstring(ADJUSTL(path)),cstring(ADJUSTL(reldir)))
494	IF (.NOT.C_ASSOCIATED(zpath)) THEN
495	res = TRIM(ADJUSTL(path))
496	ELSE
497	res = cstr2fstr(zpath)
498	ENDIF
499	CALL free_c(zpath)
500	END FUNCTION fs_relpath
501
502	FUNCTION fs_getcwd() RESULT(path)
503	!! Get the current working directory
504	CHARACTER(len=:), ALLOCATABLE :: path
505	!! The current working directory or an empty string if method fails
506	TYPE(C_PTR) :: zpath
507	zpath = getcwd_c()
508	IF (C_ASSOCIATED(zpath)) THEN
509	path = cstr2fstr(zpath)
510	ELSE
511	path = ""
512	ENDIF
513	CALL free_c(zpath)
514	RETURN
515	END FUNCTION fs_getcwd
516
517	FUNCTION fs_copy(input,output) RESULT(ret)
518	!! Copy input file into output file.
519	CHARACTER(len=*), INTENT(in) :: input !! Input file path to copy.
520	CHARACTER(len=*), INTENT(in) :: output !! Output file path destination.
521	LOGICAL :: ret !! True on success, false otherwise.
522	IF (LEN_TRIM(input) == 0 .OR. LEN_TRIM(output) == 0 .OR. input == output) THEN
523	ret = .false.
524	ELSE
525	ret = INT(copy_c(cstring(ADJUSTL(output)),cstring(ADJUSTL(input)))) == 0
526	ENDIF
527	RETURN
528	END FUNCTION fs_copy
529
530	FUNCTION fs_remove(path) RESULT(ret)
531	!! Delete the file/directory pointed by the given path
532	CHARACTER(len=*), INTENT(in) :: path !! A string with the (valid) file path to delete
533	LOGICAL :: ret !! True on success, false otherwise.
534	IF (LEN_TRIM(path) == 0) THEN
535	ret = .false.
536	ELSE
537	ret = INT(remove_c(cstring(ADJUSTL(path)))) == 0
538	ENDIF
539	RETURN
540	END FUNCTION fs_remove
541
542	FUNCTION fs_rename(old, new) RESULT(ret)
543	!! Rename a path
544	CHARACTER(len=*), INTENT(in) :: old, & !! A string with the (valid) path to rename
545	new !! A string with the new name of the path
546	LOGICAL :: ret !! True on success, false otherwise.
547	IF (LEN_TRIM(old) == 0.OR.LEN_TRIM(new) == 0) THEN
548	ret = .false.
549	ELSE
550	ret = INT(rename_c(cstring(ADJUSTL(old)),cstring(ADJUSTL(new)))) == 0
551	ENDIF
552	RETURN
553	END FUNCTION fs_rename
554
555	FUNCTION fs_chmod(path, mode) RESULT(ret)
556	!! Change file/directory permissions
557	CHARACTER(len=*), INTENT(in) :: path !! Path to modify
558	INTEGER, INTENT(in) :: mode !! New octal permissions of the file
559	LOGICAL :: ret !! True on success, false otherwise.
560	INTEGER(kind=C_INT) :: zmode
561	IF (LEN_TRIM(path) == 0) THEN
562	ret = .false.
563	ELSE
564	zmode = INT(oct_2_dec(mode),kind=C_INT)
565	ret = INT(chmod_c(cstring(ADJUSTL(path)), zmode)) == 0
566	ENDIF
567	RETURN
568	END FUNCTION fs_chmod
569
570	FUNCTION fs_chdir(path) RESULT(ret)
571	!! Change current working directory
572	CHARACTER(len=*), INTENT(in) :: path !! Path of the new working directory
573	LOGICAL :: ret !! True on success, false otherwise.
574	IF (LEN_TRIM(path) == 0) THEN
575	ret = .false.
576	ELSE
577	ret = INT(chdir_c(cstring(ADJUSTL(path)))) == 0
578	ENDIF
579	RETURN
580	END FUNCTION fs_chdir
581
582	FUNCTION fs_mkdir(path, mode, permissive) RESULT(ret)
583	!! Create directory
584	!!
585	!! The method attempts to create a new directory pointed by __path__ with the permission
586	!! given by mode.
587	CHARACTER(len=*), INTENT(in) :: path
588	!! The path to modify
589	INTEGER, INTENT(in), OPTIONAL :: mode
590	!! Optional octal permission to set for the new directory
591	LOGICAL, INTENT(in), OPTIONAL :: permissive
592	!! Optional boolean with .true. to create intermediate directories in the path
593	LOGICAL :: ret
594	!! True on success, false otherwise.
595	INTEGER :: zmode
596	LOGICAL :: zperm
597	IF (LEN_TRIM(path) == 0) THEN
598	ret = .false.
599	ELSE
600	zmode = oct_2_dec(744)
601	IF (PRESENT(mode)) THEN
602	IF (.NOT.chk_pm(mode)) THEN
603	ret = .false. ; RETURN
604	ENDIF
605	zmode = oct_2_dec(mode)
606	ENDIF
607	zperm = .false. ; IF (PRESENT(permissive)) zperm = permissive
608	IF (zperm) THEN
609	ret = INT(mkdirp_c(cstring(ADJUSTL(path)),INT(zmode,kind=C_INT))) == 0
610	ELSE
611	ret = INT(mkdir_c(cstring(ADJUSTL(path)),INT(zmode,kind=C_INT))) == 0
612	ENDIF
613	ENDIF
614	RETURN
615	END FUNCTION fs_mkdir
616
617	FUNCTION fs_rmdir(path,forced) RESULT(ret)
618	!! Remove directory
619	!!
620	!! By default, the function removes an __empty__ directory. If __forced__ is given and set
621	!! to .true. then the function recursively deletes the directory and __ALL__ its content.
622	CHARACTER(len=*), INTENT(in) :: path
623	!! The path of the directory to delete
624	LOGICAL, INTENT(in), OPTIONAL :: forced
625	!! Optional boolean with @ti{.true.} to remove all contents of the directory.
626	LOGICAL :: ret
627	!! True on success, false otherwise.
628	LOGICAL :: zforce
629	IF (LEN_TRIM(path) == 0) THEN
630	ret = .false.
631	ELSE
632	zforce = .false. ; IF (PRESENT(forced)) zforce = forced
633	IF (.NOT.zforce) THEN
634	ret = INT(rmdir_c(cstring(ADJUSTL(path)))) == 0
635	ELSE
636	ret = INT(rmdirf_c(cstring(ADJUSTL(path)))) == 0
637	ENDIF
638	ENDIF
639	RETURN
640	END FUNCTION fs_rmdir
641
642	FUNCTION fs_stat(path,type,perm,nlnks,uid,gid,fsize,atime,mtime,ctime) RESULT(ret)
643	!! Get some informations about a path
644	!!
645	!! The method retrieves various informations about the input path using fstat C function.
646	!! The type of path as returned in __type__ argument is can take the following values:
647	!!
648	!! - 0, a file
649	!! - 1, a link to a file
650	!! - 2, a directory
651	!! - 3, a link to a directory
652	!! - 4, other (fifo, socket, block special, char special...)
653	CHARACTER(len=*), INTENT(in) :: path !! Input path
654	INTEGER, INTENT(out), OPTIONAL :: type, & !! Optional type of path (see function documentation).
655	perm, & !! Optional permission of the path
656	nlnks, & !! Optional number of links to the path
657	uid, & !! Optional user id
658	gid !! Optional group id
659	INTEGER(kind=8), INTENT(out), OPTIONAL :: fsize !! Optional file size
660	CHARACTER(len=19), INTENT(out), OPTIONAL :: atime, & !! Optional last access time
661	mtime, & !! Optional last modification time
662	ctime !! Optional creation time
663	LOGICAL :: ret !! True on success, false otherwise.
664	INTEGER :: ty,pe,ln,ud,gd
665	INTEGER(kind=8) :: fs
666	CHARACTER(len=:), ALLOCATABLE :: at,mt,ct
667	INTEGER(kind=C_INT) :: p,l,t,u,g
668	INTEGER(kind=c_long) :: f
669	CHARACTER(len=20,kind=C_CHAR) :: ta,tm,tc
670	IF (LEN_TRIM(path) == 0) THEN
671	ret = .false.; RETURN
672	ELSE IF (.NOT.(PRESENT(type) .OR. PRESENT(perm) .OR. PRESENT(nlnks) .OR. &
673	PRESENT(uid) .OR. PRESENT(gid) .OR. PRESENT(fsize) .OR. &
674	PRESENT(atime) .OR. PRESENT(mtime) .OR. PRESENT(ctime))) THEN
675	ret = .true.
676	ELSE
677	! set default values
678	pe=-1 ; ty=-1 ; ud=-1 ; gd=-1 ; fs=-1 ; at="" ; mt="" ; ct=""
679	ret = INT(fstat_c(cstring(ADJUSTL(path)),p,l,t,u,g,f,ta,tm,tc)) == 0
680	IF (ret) THEN
681	pe=INT(p) ; ln=INT(l) ; ty=INT(t) ; ud=INT(u) ; gd=INT(g)
682	fs=INT(f,kind=8)
683	at = fstring(ta)
684	mt = fstring(tm)
685	ct = fstring(tc)
686	ENDIF
687	IF (PRESENT(type)) type = ty
688	IF (PRESENT(perm)) perm = pe
689	IF (PRESENT(nlnks)) nlnks = ln
690	IF (PRESENT(uid)) uid = ud
691	IF (PRESENT(gid)) gid = gd
692	IF (PRESENT(fsize)) fsize = fs
693	IF (PRESENT(atime)) atime = at
694	IF (PRESENT(mtime)) mtime = mt
695	IF (PRESENT(ctime)) ctime = ct
696	ENDIF
697	RETURN
698	END FUNCTION fs_stat
699
700	FUNCTION fs_isdir(path) RESULT (ret)
701	!! Check if a path is a directory
702	!!
703	!! The method is just a wrapper of [[fsystem(module):fs_stat(function)]] to get only specific
704	!! information about __path__ type.
705	CHARACTER(len=*), INTENT(in) :: path !! The path to check
706	LOGICAL :: ret !! .true. if the path is a directory, .false. otherwise.
707	INTEGER :: ty
708	ret = fs_stat(path,type=ty)
709	ret = ret.AND.(ty==2.or.ty==3)
710	RETURN
711	END FUNCTION fs_isdir
712
713	FUNCTION fs_isfile(path) RESULT (ret)
714	!! Check if a path is a file
715	!!
716	!! The method is just a wrapper of [[fsystem(module):fs_stat(function)]] to get only specific
717	!! information about __path__ type.
718	CHARACTER(len=*), INTENT(in) :: path !! The path to check
719	LOGICAL :: ret !! .true. if the path is a file, .false. otherwise.
720	INTEGER :: ty
721	ret=fs_stat(path,type=ty)
722	ret = ret.and.(ty==0.or.ty==1)
723	RETURN
724	END FUNCTION fs_isfile
725
726	FUNCTION fs_islink(path) RESULT (ret)
727	!! Check if a path is a link
728	!!
729	!! The method is just a wrapper of [[fsystem(module):fs_stat(function)]] to get only specific
730	!! information about __path__ type.
731	CHARACTER(len=*), INTENT(in) :: path !! The path to check
732	LOGICAL :: ret !! .true. if the path is a link, .false. otherwise.
733	INTEGER :: ty
734	ret=fs_stat(path,type=ty)
735	ret = ret.and.(ty==1.or.ty==3)
736	RETURN
737	END FUNCTION fs_islink
738
739	FUNCTION fs_access(path,permission) RESULT(ret)
740	!! Check if a path is accessible for current user
741	!!
742	!! The method checks if the given path is accessible for the current user. By default,
743	!! it does not check for specific permissions. If __permission__ is given it should be
744	!! an integer between 0 and 7 resulting from the possible combinations:
745	!!
746	!! - 0 : Checks for path existence (default)
747	!! - 1 : Checks for EXECUTE permission
748	!! - 2 : Checks for WRITE permission
749	!! - 4 : Checks for READ permission
750	CHARACTER(len=*), INTENT(in) :: path !! Path to check
751	INTEGER, INTENT(in), OPTIONAL :: permission !! Optional permission to check
752	LOGICAL :: ret !! True on success, false otherwise.
753	INTEGER(kind=C_INT) :: zp
754	IF (LEN_TRIM(path) == 0) THEN
755	ret = .false.
756	ELSE
757	zp = 0 ; IF (PRESENT(permission)) zp = INT(permission,kind=C_INT)
758	! Defaults are set in the C function.
759	ret = INT(access_c(cstring(ADJUSTL(path)),zp)) == 0
760	ENDIF
761	RETURN
762	END FUNCTION fs_access
763
764	FUNCTION fs_split_ext(path, base, ext, absolute) RESULT(ret)
765	!! Split given path into base,extension
766	!!
767	!! The __base__ of a path is conventionnally defined as all characters before the last dot of the path.
768	!! The extension (__ext__) of the path gathers consequently all characters from the last dot to the end
769	!! of the string.
770	!! @note
771	!! If the basename of the path begins by a dot then the path is assumed to be an hidden file (directory).
772	!! __ext__ will then be empty.
773	CHARACTER(len=*), INTENT(in) :: path !! Path to split
774	CHARACTER(len=:), INTENT(out), ALLOCATABLE :: base, & !! Output base of the path
775	ext !! Output extension of the path
776	LOGICAL, INTENT(in), OPTIONAL :: absolute !! .true. to return absolute path
777	LOGICAL :: ret !! .true. on success, .false. otherwise.
778	LOGICAL :: zabs
779	INTEGER :: p
780	CHARACTER(len=:), ALLOCATABLE :: d,b,apath
781	base = "" ; ext = ""
782	ret = .false.
783	IF (LEN_TRIM(path) == 0) THEN
784	RETURN
785	ENDIF
786	zabs = .false. ; IF (PRESENT(absolute)) zabs = absolute
787	apath = TRIM(path)
788	IF (zabs) THEN
789	apath = fs_realpath(path) ; IF (LEN_TRIM(apath) == 0) RETURN
790	ENDIF
791	d = fs_dirname(apath) ; IF (LEN_TRIM(d) == 0) RETURN
792	b = fs_basename(apath) ; IF (LEN_TRIM(b) == 0) RETURN
793	p = INDEX(b,".",.true.)
794	! If dot is set as first char of basename : it's an hidden file
795	IF (p > 1) THEN
796	ext = b(p:) ; base = TRIM(d)//"/"//b(:p-1)
797	ELSE
798	base = TRIM(apath)
799	ENDIF
800	ret = .true.
801	RETURN
802	END FUNCTION fs_split_ext
803
804	FUNCTION fs_create(path, mode, type, permissive) RESULT(ret)
805	!! Create a directory/file
806	!!
807	!! The method creates the file/directory pointed by given __path__.
808	!! If __type__ is not given, the method builds the path as :
809	!!
810	!! -# A file if the basename of the path contains an extension
811	!! -# A directory in any other cases.
812	!!
813	!! Otherwise __type__ should be set to "f" for file or "d" for directory.
814	!!
815	!! Unless __permissive__ is set to .true., the method will fails if intermediate
816	!! directories in the path do not exist.
817	CHARACTER(len=*), INTENT(in) :: path !! Path to create
818	INTEGER, INTENT(in), OPTIONAL :: mode !! Optional octal permisions to set
819	CHARACTER(len=1), INTENT(in), OPTIONAL :: type !! Optional type of path to create
820	LOGICAL, INTENT(in), OPTIONAL :: permissive !! .true. to create intermediate directories if not existing
821	LOGICAL :: ret !! True on success, false otherwise.
822	INTEGER :: zmd,zt,zp
823	CHARACTER(len=:), ALLOCATABLE :: b,e
824	ret = .false.
825	! Checking for existence
826	IF (LEN_TRIM(path) == 0) THEN
827	RETURN
828	ELSE IF (fs_access(path)) THEN
829	RETURN
830	ENDIF
831	! Set type of path
832	IF (PRESENT(type)) THEN
833	IF (.NOT.(type(1:1)=="f".OR.type(1:1)=="d")) THEN
834	RETURN
835	ELSE
836	zt=0 ; IF (type(1:1)=="f") zt = 1
837	ENDIF
838	ELSE
839	IF(.NOT.fs_split_ext(path,b,e)) RETURN
840	zt = 0 ; IF (LEN_TRIM(e) /= 0) zt=1
841	ENDIF
842	! set permissions according to type
843	IF (zt == 0) THEN
844	zmd = oct_2_dec(777)-get_umask()
845	ELSE
846	zmd = oct_2_dec(666) -get_umask()
847	ENDIF
848	! Check mode argument if present
849	IF (PRESENT(mode)) THEN
850	IF(.NOT.chk_pm(mode)) THEN
851	! not a valid permission : We raise an error and abort
852	RETURN
853	ELSE
854	zmd = oct_2_dec(mode)
855	ENDIF
856	ENDIF
857	zp = 0 ; IF(PRESENT(permissive)) THEN ; IF(permissive) zp=1 ; ENDIF
858	ret = INT(create_c(cstring(ADJUSTL(path)),INT(zmd,kind=C_INT),INT(zt,kind=C_INT),INT(zp,kind=C_INT))) == 0
859	RETURN
860	END FUNCTION fs_create
861
862	FUNCTION fs_get_parent(path, n) RESULT(opath)
863	!! Get the nth parent of the given path
864	!!
865	!! The method first resolves the given path using [[fsystem(module):fs_realpath(function)]]
866	!! to get an absolute path.
867	!! @note
868	!! If __n__ is greater than the maximum parent level of the path, "/" is returned.
869	CHARACTER(len=*), INTENT(in) :: path
870	!! Input path
871	INTEGER, INTENT(in), OPTIONAL :: n
872	!! The level of the parent to get
873	CHARACTER(len=:), ALLOCATABLE :: opath
874	!! The nth parent of the given path, or an empty string if the parent can not be computed
875	CHARACTER(len=:), ALLOCATABLE :: zp
876	INTEGER :: i,mx,zl,mzl
877	opath = ""
878	zl = 1 ; IF (PRESENT(n)) zl = MAX(n,1)
879	IF (LEN_TRIM(path) == 0) THEN
880	RETURN
881	ENDIF
882	! Gets the absolute path
883	zp = fs_realpath(TRIM(ADJUSTL(path)))
884	IF (LEN_TRIM(zp) == 0) RETURN
885	! removing trailing / (only if it's not the first ^^)
886	mx = LEN_TRIM(zp) ; IF (zp(mx:mx)=="/".AND.mx/=1) zp(mx:mx) = ""
887	! compute maximum level
888	mzl = 1 ; DO i=1,mx ; IF(zp(i:i) == '/') mzl=mzl+1 ; ENDDO
889	i=0
890	DO
891	mx = INDEX(zp(1:mx),'/',.true.) ; i=i+1
892	IF (mx==0.OR.i>=zl.OR.i>=mzl) EXIT
893	mx = mx - 1
894	ENDDO
895	IF (mx >= 1) THEN
896	opath = zp(1:MAX(1,mx-1))
897	ELSE
898	opath = "/"
899	ENDIF
900	RETURN
901	END FUNCTION fs_get_parent
902
903	SUBROUTINE fs_termsize(row, column)
904	!! Get the current terminal window size
905	!! @attention
906	!! If the program is redirected to a file (and maybe some other device), the C
907	!! function can raise an error. In that case, the default values (20,80) are
908	!! returned by the C function and thus the subroutine !
909	INTEGER, INTENT(out) :: row, & !! Number of rows of the window
910	column !! Number of columns of the window
911	INTEGER(kind=C_INT) :: r, c, ret
912	ret = termsize_c(r,c)
913	row = INT(r) ; column = INT(c)
914	RETURN
915	END SUBROUTINE fs_termsize
916
917	SUBROUTINE fs_usleep(usec)
918	!! Sleep for a given number of microseconds
919	!! @note
920	!! Currently if C usleep function failed, the system... does not sleep !
921	INTEGER, INTENT(in) :: usec !! The number of microseconds to sleep for
922	INTEGER(kind=C_INT) :: ret
923	! usleep expects useconds_t (unsigned int) which is given here as a 4-bytes int
924	ret = usleep_c(INT(usec,kind=C_INT))
925	END SUBROUTINE fs_usleep
926
927	SUBROUTINE fs_msleep(msec)
928	!! Sleep for a given number of milliseconds
929	INTEGER, INTENT(in) :: msec !! The number of milliseconds to sleep for
930	CALL fs_usleep(msec*1000)
931	END SUBROUTINE fs_msleep
932
933	FUNCTION fs_get_memory(peak,units) RESULT(mem)
934	!! Get the memory usage of the current process.
935	LOGICAL, INTENT(in), OPTIONAL :: peak !! True to retrieve the peak RSS memory, otherwise retrieve the current RSS memory. Default to False.
936	CHARACTER(len=*), INTENT(in), OPTIONAL :: units !! Output units: either 'B' (Bytes),'KB' (Kilo-),'MB' (Mega-),'GB' (Giga-). Default to 'B'.
937	REAL(kind=8) :: mem !! Memory usage.
938	LOGICAL :: zpeak
939	CHARACTER(len=2) :: zunits
940	zpeak = .false. ; IF (PRESENT(peak)) zpeak = peak
941	zunits = 'B ' ; IF (PRESENT(units)) zunits = units
942	IF (zunits /= 'B' .AND. zunits /= 'KB' .AND. zunits /= 'MB' .AND. zunits /= 'GB') zunits = 'B '
943	IF (zpeak) THEN
944	mem = REAL(getPeakRSS_c(),kind=8)
945	ELSE
946	mem = REAL(getCurrentRSS_c(),kind=8)
947	ENDIF
948	IF (zunits == 'KB') THEN
949	mem = mem / 1024d0
950	ELSE IF (zunits == 'MB') THEN
951	mem = mem / 1048576d0
952	ELSE IF (zunits == 'GB') THEN
953	mem = mem / 1073741824d0
954	ENDIF
955	RETURN
956	END FUNCTION fs_get_memory
957
958	FUNCTION fs_get_system_memory(total,available,free,units) RESULT(ret)
959	!! Get informations about system memory.
960	!!
961	!! If no informations is available, output arguments are set to 0 and the method returns false.
962	REAL(kind=8), INTENT(out), OPTIONAL :: total !! Total available memory.
963	REAL(kind=8), INTENT(out), OPTIONAL :: available !! Current available memory.
964	REAL(kind=8), INTENT(out), OPTIONAL :: free !! Current free memory.
965	CHARACTER(len=*), INTENT(in), OPTIONAL :: units !! Output units: either 'B' (Bytes),'KB' (Kilo-),'MB' (Mega-),'GB' (Giga-). Default to 'B'.
966	LOGICAL :: ret !! True on success, false otherwise.
967	LOGICAL :: zpeak
968	CHARACTER(len=2) :: zunits
969	INTEGER(kind=8) :: ztot,zava,zfre
970
971	zunits = 'B ' ; IF (PRESENT(units)) zunits = units
972	IF (zunits /= 'B' .AND. zunits /= 'KB' .AND. zunits /= 'MB' .AND. zunits /= 'GB') zunits = 'B '
973	ret = INT(getSystemMemory_c(ztot,zava,zfre),kind=4) == 0
974	ztot = ztot * 1024 ; zava = zava * 1024 ; zfre = zfre * 1024
975
976	IF (PRESENT(total)) total = ztot
977	IF (PRESENT(available)) available = zava
978	IF (PRESENT(free)) free = zfre
979	IF (.NOT.ret) RETURN
980
981	IF (zunits == 'KB') THEN
982	IF (PRESENT(total)) total = ztot / 1024d0
983	IF (PRESENT(available)) available = zava / 1024d0
984	IF (PRESENT(free)) free = zfre / 1024d0
985	ELSE IF (zunits == 'MB') THEN
986	IF (PRESENT(total)) total = ztot / 1048576d0
987	IF (PRESENT(available)) available = zava / 1048576d0
988	IF (PRESENT(free)) free = zfre / 1048576d0
989	ELSE IF (zunits == 'GB') THEN
990	IF (PRESENT(total)) total = ztot / 1073741824d0
991	IF (PRESENT(available)) available = zava / 1073741824d0
992	IF (PRESENT(free)) free = zfre / 1073741824d0
993	ENDIF
994	RETURN
995	END FUNCTION fs_get_system_memory
996
997
998	!===============================================================================
999	! MODULE MISCELLANEOUS METHODS
1000	!===============================================================================
1001
1002	FUNCTION oct_2_dec(octal) RESULT(res)
1003	!> Octal to decimal conversion
1004	!!
1005	!! The method converts the octal number ranging from 0 to 777 in the decimal system.
1006	!! @attention
1007	!! If the __octal__ number is out of range then the method returns 384 (600 in octal).
1008	INTEGER, INTENT(in) :: octal !! The octal value to convert
1009	INTEGER :: res !! The converted decimal value
1010	INTEGER :: o,d,i
1011	IF (octal < 0 .OR. octal > 777) THEN
1012	res = 384 ; RETURN ! --> 600 in octal : rw-------
1013	ENDIF
1014	d = 0 ; i = 0 ; o = octal
1015	DO WHILE(o/=0)
1016	d=d+mod(o,10)8*i ; i=i+1 ; o=o/10
1017	ENDDO
1018	res=d
1019	RETURN
1020	END FUNCTION oct_2_dec
1021
1022	FUNCTION dec_2_oct(decimal) RESULT(res)
1023	!! Decimal to octal conversion
1024	!! The method converts the decimal number ranging from 0 to 511 in the octal system.
1025	!! @attention
1026	!! If the __decimal__ number is out of range, then it the method returns 600 (384 in decimal).
1027	INTEGER, INTENT(in) :: decimal !! The decimal value to convert
1028	INTEGER :: res !! The converted octal value
1029	! - LOCAL
1030	INTEGER :: o,d,i,m
1031	IF (decimal < 0 .OR. decimal > 511) THEN
1032	res = 600 ; RETURN ! --> 384 in decimal : rw-------
1033	ENDIF
1034	o=0 ; d = decimal ; i=0 ; m=0
1035	DO WHILE(d/=0)
1036	d=d/8 ; m=m+1
1037	ENDDO
1038	m=m-1 ; d=decimal
1039	DO i=0,m
1040	o=o+mod(d,8)10*i ; d=d/8
1041	ENDDO
1042	res = o
1043	RETURN
1044	END FUNCTION dec_2_oct
1045
1046	FUNCTION sp_2_op(str) RESULT(oct)
1047	!! Get octal number of string representation's permission
1048	CHARACTER(len=3),INTENT(in) :: str !! The permission to convert
1049	INTEGER :: oct !! Octal value of the string permission on succes, -1 otherwise.
1050	oct = -1
1051	IF (LEN_TRIM(str) /= 3) RETURN
1052	SELECT CASE(str)
1053	CASE("---") ; oct = 0
1054	CASE("--x") ; oct = 1
1055	CASE("-w-") ; oct = 2
1056	CASE("-wx") ; oct = 3
1057	CASE("r--") ; oct = 4
1058	CASE("r-x") ; oct = 5
1059	CASE("rw-") ; oct = 6
1060	CASE("rwx") ; oct = 7
1061	CASE DEFAULT
1062	oct = -1 ; RETURN
1063	END SELECT
1064	RETURN
1065	END FUNCTION sp_2_op
1066
1067	FUNCTION op_2_sp(oct) RESULT(str)
1068	!! Get string representation of the octal number's permission
1069	INTEGER, INTENT(in) :: oct !! Octal number to convert
1070	CHARACTER(len=3) :: str !! String representation of the octal number on succes, 'ukn' otherwise
1071	SELECT CASE(oct)
1072	CASE(0) ; str="---"
1073	CASE(1) ; str="--x"
1074	CASE(2) ; str="-w-"
1075	CASE(3) ; str="-wx"
1076	CASE(4) ; str="r--"
1077	CASE(5) ; str="r-x"
1078	CASE(6) ; str="rw-"
1079	CASE(7) ; str="rwx"
1080	CASE DEFAULT
1081	str='ukn' ; RETURN
1082	END SELECT
1083	RETURN
1084	END FUNCTION op_2_sp
1085
1086	FUNCTION str_perm(oct_perm) RESULT(ret)
1087	!! Get the string representation of the given permission mask
1088	INTEGER, INTENT(in) :: oct_perm !! The octal representation of the permission
1089	CHARACTER(len=9) :: ret !! String representation of the octal number on succes, 'ukn' otherwise
1090	INTEGER :: u,g,o
1091	IF (.NOT.chk_pm(oct_perm)) THEN
1092	ret = "ukn" ; RETURN
1093	ENDIF
1094	u=int(oct_perm/100) ; g=int((oct_perm-u100)/10) ; o=int(oct_perm-u100-g*10)
1095	ret(1:3) = op_2_sp(u) ; ret(4:6) = op_2_sp(g) ; ret(7:9) = op_2_sp(o)
1096	RETURN
1097	END FUNCTION str_perm
1098
1099	FUNCTION oct_perm(str) RESULT(ret)
1100	!! Get the string representation of the given permission mask
1101	CHARACTER(len=9), INTENT(in) :: str !! The string representation of the permission
1102	INTEGER :: ret !! Octal permission on success, -1 otherwise
1103	! - LOCAL
1104	INTEGER :: u,g,o
1105	u = sp_2_op(str(1:3)) ; g = sp_2_op(str(4:6)) ; o = sp_2_op(str(7:9))
1106	IF (u==-1.OR.g==-1.OR.o==-1) THEN
1107	ret = -1 ; RETURN
1108	ELSE
1109	ret = u100 + g10 + o
1110	ENDIF
1111	RETURN
1112	END FUNCTION oct_perm
1113
1114	FUNCTION chk_pm(perm) RESULT(valid)
1115	!! Check if the given permission is valid
1116	INTEGER, INTENT(in) :: perm !! Octal permission mask
1117	LOGICAL :: valid !! .true. if the permission mask is valid, .false. otherwise
1118	INTEGER :: u,g,o
1119	u=int(perm/100) ; g=int((perm-u100)/10) ; o=int(perm-u100-g*10)
1120	valid = (u>=0.AND.u<=7).AND.(g>=0.AND.g<=7).AND.(o>=0.AND.o<=7)
1121	RETURN
1122	END FUNCTION chk_pm
1123
1124	FUNCTION get_umask() RESULT(mask)
1125	!! Get the umask value of the current session
1126	INTEGER :: mask !! Current umask value in decimal system
1127	mask = INT(umask_c())
1128	RETURN
1129	END FUNCTION get_umask
1130
1131	FUNCTION sz2str(file_size) RESULT(fstr)
1132	!! Get a human readable file size
1133	INTEGER(kind=8), INTENT(in) :: file_size !! File size (assumed to be bytes)
1134	CHARACTER(len=50) :: fstr !! Size in a human readable format
1135	! - LOCAL
1136	INTEGER :: cc
1137	REAL(kind=8) :: zfs
1138	CHARACTER(len=2), DIMENSION(6), PARAMETER :: sn = &
1139	(/'B ','KB','MB','GB','TB','PB'/)
1140	zfs=DBLE(file_size)
1141	DO cc=1,size(sn)-1 ; IF (zfs<1024.) EXIT ; zfs=zfs/1024. ; ENDDO
1142	IF (MOD(zfs,1.0) == 0) THEN
1143	WRITE(fstr,'(I50)') INT(zfs) ; fstr = TRIM(ADJUSTL(fstr))//sn(cc)
1144	ELSE
1145	WRITE(fstr,'(F50.2)') zfs ; fstr = TRIM(ADJUSTL(fstr))//sn(cc)
1146	ENDIF
1147	RETURN
1148	END FUNCTION sz2str
1149
1150	FUNCTION chrono_is_running(this) RESULT (ret)
1151	!! Get chrono's state.
1152	OBJECT(chrono), INTENT(in) :: this !! Chrono object reference.
1153	LOGICAL :: ret !! Running state.
1154	ret = this%on_run
1155	RETURN
1156	END FUNCTION chrono_is_running
1157
1158	SUBROUTINE chrono_start(this)
1159	!! Start the chrono.
1160	!!
1161	!! @note
1162	!! Calling the method multiple times without explicitly stopping the chrono
1163	!! [[chrono(type):stop(bound)]] does nothing (except for the first called).
1164	OBJECT(chrono), INTENT(inout) :: this !! Chrono object reference.
1165	IF (.NOT.this%on_run) THEN
1166	CALL CPU_TIME(this%cpu_start)
1167	CALL SYSTEM_CLOCK(this%clock_start)
1168	ENDIF
1169	this%on_run = .true.
1170	END SUBROUTINE chrono_start
1171
1172	SUBROUTINE chrono_stop(this)
1173	!! Stop the chrono.
1174	OBJECT(chrono), INTENT(inout) :: this !! Chrono object reference.
1175	REAL(kind=8) :: ecpu
1176	INTEGER(kind=8) :: eclk,nbm,nbr
1177	this%on_run = .false.
1178	END SUBROUTINE chrono_stop
1179
1180	SUBROUTINE chrono_reset(this)
1181	!! Reset the chrono's internal elapsed times.
1182	OBJECT(chrono), INTENT(inout) :: this !! Chrono object reference.
1183	CALL CPU_TIME(this%cpu_start)
1184	CALL SYSTEM_CLOCK(this%clock_start)
1185	END SUBROUTINE chrono_reset
1186
1187	SUBROUTINE chrono_get(this,cpu,clock,units)
1188	!! Get elapsed time since last call of start or reset methods.
1189	!!
1190	!! The method computes the time elapsed in two ways :
1191	!!
1192	!! - If the [[fsystem(module):chrono(type)]] is not running, the method retruns 0.
1193	!! - Otherwise, elapsed time since the last call of
1194	!! [[chrono(type):start(bound)]] (or [[chrono(type):reset(bound)]]).
1195	OBJECT(chrono), INTENT(in) :: this
1196	!! Chrono object reference.
1197	REAL(kind=8), INTENT(out), OPTIONAL :: cpu
1198	!! Elapsed cpu time in seconds by default (see units argument).
1199	REAL(kind=8), INTENT(out), OPTIONAL :: clock
1200	!! Elapsed system clock time in seconds by default (see units argument).
1201	CHARACTER(len=2), INTENT(in), OPTIONAL :: units
1202	!! A two characters wide string with the units to convert in. Units should
1203	!! be one of the following : 'ms', 's' (default), 'm', 'h' or 'd'.
1204	CHARACTER(len=2) :: zu
1205	REAL(kind=8) :: cu, fact
1206	INTEGER(kind=8) :: ck, r, m
1207	IF (this%on_run) THEN
1208	IF (PRESENT(cpu)) THEN
1209	CALL CPU_TIME(cu)
1210	cpu = (cu - this%cpu_start)
1211	ENDIF
1212	IF (PRESENT(clock)) THEN
1213	CALL SYSTEM_CLOCK(ck,r,m)
1214	clock = c2t(ck,this%clock_start,r,m)
1215	ENDIF
1216	ELSE
1217	IF (PRESENT(cpu)) cpu = 0d0
1218	IF (PRESENT(clock)) clock = 0d0
1219	ENDIF
1220	fact = 1d0
1221	zu = 's'
1222	IF (PRESENT(units)) THEN
1223	zu = units
1224	SELECT CASE(zu)
1225	CASE ('d') ; fact = 3600d0*24.
1226	CASE ('h') ; fact = 3600d0
1227	CASE ('m') ; fact = 60d0
1228	CASE ('ms') ; fact = 1d-3
1229	CASE DEFAULT ; fact = 1d0
1230	END SELECT
1231	ENDIF
1232	IF (PRESENT(cpu)) cpu = cpu / fact
1233	IF (PRESENT(clock)) clock = clock / fact
1234	END SUBROUTINE chrono_get
1235
1236	FUNCTION c2t(e,i,r,m) RESULT(time)
1237	!! Get the real-time between two clock counts from system_clock.
1238	INTEGER(kind=8), INTENT(in) :: e !! Final clock count
1239	INTEGER(kind=8), INTENT(in) :: i !! Initial clock count
1240	INTEGER(kind=8), INTENT(in) :: r !! Clock count rate
1241	INTEGER(kind=8), INTENT(in) :: m !! Maximum Clock count value
1242	REAL(kind=8) :: time !! Time in seconds
1243	INTEGER(kind=8) :: nc
1244	nc = e-i ; IF (e < i) nc = nc+m
1245	time = REAL(nc,kind=8)/r
1246	RETURN
1247	END FUNCTION c2t
1248	END MODULE FSYSTEM
1249

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

Download in other formats:

Original Format