Context Navigation

fsystem.F90 @ 1897

Last change on this file since 1897 was 1897, checked in by jvatant, 7 years ago

Making Titan's hazy again - part II
+ Major updates of J.Burgalat YAMMS library and optical coupling, including :
++ Added the routines for haze optics inside YAMMS
++ Calling rad. transf. with interactive haze is plugged
in but should stay unactive as long as the microphysics is
in test phase : cf "uncoupl_optic_haze" flag : true for now !
++ Also some sanity checks for negative tendencies and
some others upkeep of YAMMS model
+ Also added a temporary CPP key USE_QTEST in physiq_mod
that enables to have microphysical tendencies separated
from dynamics for debugging and test phases
-- JVO and JB

File size: 48.8 KB

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

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

Download in other formats:

Original Format