Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Normal
Revision Log

swift_fsystem.F90 @ 3590

Last change on this file since 3590 was 3560, checked in by debatzbr, 5 weeks ago
Addition of the microphysics model in moments.
File size: 49.2 KB

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

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

Download in other formats:

Original Format