source: trunk/LMDZ.TITAN/libf/muphytitan/fsystem.F90 @ 3580

Last change on this file since 3580 was 3318, checked in by slebonnois, 9 months ago

Titan PCM update : optics + microphysics

File size: 49.1 KB
RevLine 
[3090]1! Copyright (c) (2013-2015,2017,2022) Jeremie Burgalat (jeremie.burgalat@univ-reims.fr).
[3083]2!
3! This file is part of SWIFT
4!
5! Permission is hereby granted, free of charge, to any person obtaining a copy of
6! this software and associated documentation files (the "Software"), to deal in
7! the Software without restriction, including without limitation the rights to
8! use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
9! the Software, and to permit persons to whom the Software is furnished to do so,
10! subject to the following conditions:
11!
12! The above copyright notice and this permission notice shall be included in all
13! copies or substantial portions of the Software.
14!
15! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
16! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
17! FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
18! COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
19! IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
20! CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
[1793]21
22!! file: fsystem.F90
[1897]23!! summary: File system methods source file.
24!! author: J. Burgalat
[3083]25!! date: 2013-2015,2017,2022
[1793]26
[1897]27
[1793]28#include "defined.h"
29
30MODULE FSYSTEM
31  !! File system methods module
32  USE, INTRINSIC :: ISO_C_BINDING
33  USE ERRORS
34  IMPLICIT NONE
35
[3083]36  PUBLIC
[1793]37
38  PRIVATE :: get_umask
[1897]39  PRIVATE :: c2t
[1793]40
41  INTEGER, PARAMETER :: MAX_PATH = 512 !! Maximum length of a path
42
[1897]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.
[3083]47    REAL(kind=8), PRIVATE    :: cpu_start = 0d0
[1897]48      !! Starting CPU time
[3083]49    INTEGER(kind=8), PRIVATE :: clock_start = 0d0
[1897]50      !! Starting clock time
51    LOGICAL, PRIVATE         :: on_run = .false.
52      !! Chrono running state.
53#if HAVE_FTNPROC
[3083]54    CONTAINS
55      PROCEDURE :: is_running => chrono_is_running
[1897]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
[1793]62
[1897]63#ifndef FORD_DOC
64  ! C interfaces
[1793]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")
[1897]80      !! Get last error numero
[1793]81      IMPORT C_INT
82      INTEGER(kind=C_INT) :: errno_c !! Last errno
83    END FUNCTION errno_c
84
[3083]85    FUNCTION usleep_c(usec) BIND(C,name="usleep")
[1793]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")
[3083]117      !! Check if path is accessible for current user
[1793]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
[3083]124    FUNCTION create_c(path,mode,asfile,forced) BIND(C,name="c_create")
[1793]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
[3083]139    END FUNCTION uname_c
[1793]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
[3083]146    END FUNCTION gname_c
[1793]147
[3083]148    FUNCTION dirname_c(path) BIND(C,name="c_dirname")
[1793]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
[3083]162    FUNCTION getcwd_c() BIND(C,name="c_getcwd")
[1793]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
[3083]188      INTEGER(kind=C_INT)                :: rename_c  !! 0 on success, last errno on failure
[1793]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
[3083]196      INTEGER(kind=C_INT)                    :: chmod_c !! 0 on success, last errno on failure
[1793]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
[3083]203      INTEGER(kind=C_INT)                 :: chdir_c !! 0 on success, last errno on failure
[1793]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
[3083]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
[1793]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
[3083]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
[1793]220    END FUNCTION mkdirp_c
221
[3083]222    FUNCTION copy_c(to,from) BIND(C,name="c_copy")
[1897]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
[3083]230    FUNCTION remove_c(path) BIND(C,name="c_remove")
[1793]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
[3083]234      INTEGER(kind=C_INT)                 :: remove_c !! 0 on success, last errno on failure
[1793]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
[3083]241      INTEGER(kind=C_INT)                :: rmdir_c    !! 0 on success, last errno on failure
[1793]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
[3083]248      INTEGER(kind=C_INT)                :: rmdirf_c   !! 0 on success, last errno on failure
[1793]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
[3083]272      INTEGER(kind=C_INT)              :: termsize_c !! 0 on success, last errno on failure
[1793]273    END FUNCTION termsize_c
274
[1897]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).
[3083]279    END FUNCTION getCurrentRSS_c
[1897]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).
[3083]285    END FUNCTION getPeakRSS_c
[1897]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.
[3083]293      INTEGER(kind=C_INT)                    :: getSystemMemory_c !! status, 0 on success, 1 otherwise.
[1897]294    END FUNCTION getSystemMemory_c
[1793]295  END INTERFACE
[1897]296#endif
[1793]297
298  CONTAINS
299
300  FUNCTION fstring(string) RESULT(str)
[3083]301    !! Convert C string to  Fortran string
[1793]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.
[3083]306    CHARACTER(len=*), INTENT(in) :: string !! A string from C
[1793]307    CHARACTER(len=:), ALLOCATABLE :: str   !! Converted fortran string
[3083]308    INTEGER :: i,idx
[1793]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
[3083]325    !! C char\* pointer string.
[1793]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
[3083]330    !! The method does not free the underlying C string and it should be free using
[1897]331    !! the subroutine free_c(_cstr_).
[1793]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)
[3083]356    !> convert Fortran string to cstring
[1793]357    !!
358    !! The method returns a copy of the input string suitable for C functions argument.
[3083]359    !! @note
[1793]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
[3083]375  FUNCTION fs_getgid() RESULT(ret)
[1793]376    !! Get Group ID
377    INTEGER(kind=4) :: ret !! An integer with the group identifier
[3083]378    ret = INT(getgid_c(),kind=4)
[1793]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
[3083]389  FUNCTION fs_getuid() RESULT(ret)
[1793]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
[3083]403      gname = ""
[1793]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
[3083]417      uname = ""
[1793]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
[3083]428    CHARACTER(len=:), ALLOCATABLE :: opath
[1793]429      !! A Fortran allocated string with the parent directory path or an empty string if method fails
[3318]430    CHARACTER(len=:), ALLOCATABLE :: cpath
[1793]431    TYPE(C_PTR) :: zpath
432    IF (LEN_TRIM(path) == 0) THEN
433      opath = ""
434      RETURN
435    ENDIF
[3318]436    cpath = cstring(ADJUSTL(path))
437    zpath = dirname_c(cpath)
[1793]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
[3083]450    CHARACTER(len=:), ALLOCATABLE :: opath
[1793]451      !! The basename of the path or an empty string if method fails
[3318]452    CHARACTER(len=:), ALLOCATABLE :: cpath
[1793]453    TYPE(C_PTR) :: zpath
454    IF (LEN_TRIM(path) == 0) THEN
455      opath = ""
456      RETURN
457    ENDIF
[3318]458    cpath = cstring(ADJUSTL(path))
459    zpath = basename_c(cpath)
[1793]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.
[3083]472    !! @note
[1793]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
[3083]476    CHARACTER(len=:), ALLOCATABLE :: opath
[1793]477      !! The absolute of the path or an empty string if method fails
[3318]478    CHARACTER(len=:), ALLOCATABLE :: cpath
[1793]479    TYPE(C_PTR) :: zpath
[3318]480    cpath = cstring(ADJUSTL(path))
481    zpath = realpath_c(cpath)
[1793]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    !!
[3083]493    !! The method computes the relative representation of __path__ from __reldir__ if possible.
[1793]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
[3318]498    CHARACTER(len=:), ALLOCATABLE :: cpath1,cpath2
[1793]499    TYPE(C_PTR) :: zpath
[3318]500    cpath1 = cstring(ADJUSTL(path))
501    cpath2 = cstring(ADJUSTL(reldir))
502    zpath = relpath_c(cpath1,cpath2)
[1793]503    IF (.NOT.C_ASSOCIATED(zpath)) THEN
504      res = TRIM(ADJUSTL(path))
505    ELSE
506      res = cstr2fstr(zpath)
[3083]507    ENDIF
[1793]508    CALL free_c(zpath)
509  END FUNCTION fs_relpath
510
[3083]511  FUNCTION fs_getcwd() RESULT(path)
[1793]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
[1897]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.
[3318]531    CHARACTER(len=:), ALLOCATABLE :: cpath1,cpath2
532
[1897]533    IF (LEN_TRIM(input) == 0 .OR. LEN_TRIM(output) == 0 .OR. input == output) THEN
534      ret = .false.
535    ELSE
[3318]536      cpath1 = cstring(ADJUSTL(output))
537      cpath2 = cstring(ADJUSTL(input))
538      ret = INT(copy_c(cpath1,cpath2)) == 0
[1897]539    ENDIF
540    RETURN
541  END FUNCTION fs_copy
542
[1793]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.
[3318]547    CHARACTER(len=:), ALLOCATABLE :: cpath
[1793]548    IF (LEN_TRIM(path) == 0) THEN
549      ret = .false.
550    ELSE
[3318]551      cpath = cstring(ADJUSTL(path))
552      ret = INT(remove_c(cpath)) == 0
[1793]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.
[3318]562    CHARACTER(len=:), ALLOCATABLE :: cpath1,cpath2
[1793]563    IF (LEN_TRIM(old) == 0.OR.LEN_TRIM(new) == 0) THEN
[3083]564      ret = .false.
[1793]565    ELSE
[3318]566      cpath1 = cstring(ADJUSTL(old))
567      cpath2 = cstring(ADJUSTL(new))
568      ret = INT(rename_c(cpath1,cpath2)) == 0
[1793]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
[3318]579    CHARACTER(len=:), ALLOCATABLE :: cpath
[1793]580    IF (LEN_TRIM(path) == 0) THEN
[3083]581      ret = .false.
[1793]582    ELSE
583      zmode = INT(oct_2_dec(mode),kind=C_INT)
[3318]584      cpath = cstring(ADJUSTL(path))
585      ret = INT(chmod_c(cpath, zmode)) == 0
[1793]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.
[3318]594    CHARACTER(len=:), ALLOCATABLE :: cpath
[1793]595    IF (LEN_TRIM(path) == 0) THEN
[3083]596      ret = .false.
[1793]597    ELSE
[3318]598      cpath = cstring(ADJUSTL(path))
599      ret = INT(chdir_c(cpath)) == 0
[1793]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.
[3083]609    CHARACTER(len=*), INTENT(in)  :: path
[1793]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
[3318]619    CHARACTER(len=:), ALLOCATABLE :: cpath
620
[1793]621    IF (LEN_TRIM(path) == 0) THEN
[3083]622      ret = .false.
[1793]623    ELSE
[3083]624      zmode = oct_2_dec(744)
[1793]625      IF (PRESENT(mode)) THEN
[3083]626        IF (.NOT.chk_pm(mode)) THEN
[1793]627          ret = .false. ; RETURN
628        ENDIF
629        zmode = oct_2_dec(mode)
630      ENDIF
[3318]631      cpath = cstring(ADJUSTL(path))
[3083]632      zperm = .false. ; IF (PRESENT(permissive)) zperm = permissive
[1793]633      IF (zperm) THEN
[3318]634        ret = INT(mkdirp_c(cpath,INT(zmode,kind=C_INT))) == 0
[1793]635      ELSE
[3318]636        ret = INT(mkdir_c(cpath,INT(zmode,kind=C_INT))) == 0
[1793]637      ENDIF
638    ENDIF
639    RETURN
640  END FUNCTION fs_mkdir
641
642  FUNCTION fs_rmdir(path,forced) RESULT(ret)
643    !! Remove directory
644    !!
[3083]645    !! By default, the function removes an __empty__ directory. If __forced__ is given and set
[1793]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.
[3083]653    LOGICAL :: zforce
[3318]654    CHARACTER(len=:), ALLOCATABLE :: cpath
[1793]655    IF (LEN_TRIM(path) == 0) THEN
[3083]656      ret = .false.
[1793]657    ELSE
658      zforce = .false. ; IF (PRESENT(forced)) zforce = forced
[3318]659      cpath = cstring(ADJUSTL(path))
[1793]660      IF (.NOT.zforce) THEN
[3318]661        ret = INT(rmdir_c(cpath)) == 0
[1793]662      ELSE
[3318]663        ret = INT(rmdirf_c(cpath)) == 0
[1793]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    !!
[3083]672    !! The method retrieves various informations about the input path using fstat C function.
[1793]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
[3083]683                                                nlnks, & !! Optional number of links to the path
[1793]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.
[3083]691    INTEGER                       :: ty,pe,ln,ud,gd
[1793]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
[3318]697    CHARACTER(len=:), ALLOCATABLE :: cpath
[1793]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=""
[3318]707      cpath = cstring(ADJUSTL(path))
708      ret = INT(fstat_c(cpath,p,l,t,u,g,f,ta,tm,tc)) == 0
[1793]709      IF (ret) THEN
[3083]710        pe=INT(p) ; ln=INT(l) ; ty=INT(t) ; ud=INT(u) ; gd=INT(g)
711        fs=INT(f,kind=8)
[1793]712        at = fstring(ta)
713        mt = fstring(tm)
714        ct = fstring(tc)
715      ENDIF
[3083]716      IF (PRESENT(type))  type  = ty
[1793]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    !!
[3083]732    !! The method is just a wrapper of [[fsystem(module):fs_stat(function)]] to get only specific
[1793]733    !! information about __path__ type.
734    CHARACTER(len=*), INTENT(in) :: path !! The path to check
[3083]735    LOGICAL :: ret                       !! .true. if the path is a directory, .false. otherwise.
[1793]736    INTEGER :: ty
737    ret = fs_stat(path,type=ty)
[3083]738    ret = ret.AND.(ty==2.or.ty==3)
[1793]739    RETURN
740  END FUNCTION fs_isdir
741
742  FUNCTION fs_isfile(path) RESULT (ret)
[3083]743    !! Check if a path is a file
[1793]744    !!
[3083]745    !! The method is just a wrapper of [[fsystem(module):fs_stat(function)]] to get only specific
[1793]746    !! information about __path__ type.
747    CHARACTER(len=*), INTENT(in) :: path !! The path to check
[3083]748    LOGICAL :: ret                       !! .true. if the path is a file, .false. otherwise.
[1793]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)
[3083]756    !! Check if a path is a link
[1793]757    !!
[3083]758    !! The method is just a wrapper of [[fsystem(module):fs_stat(function)]] to get only specific
[1793]759    !! information about __path__ type.
760    CHARACTER(len=*), INTENT(in) :: path !! The path to check
[3083]761    LOGICAL :: ret                       !! .true. if the path is a link, .false. otherwise.
762    INTEGER :: ty
[1793]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
[3083]778    !! - 4 : Checks for READ permission
[1793]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
[3318]783    CHARACTER(len=:), ALLOCATABLE :: cpath
[1793]784    IF (LEN_TRIM(path) == 0) THEN
[3083]785      ret = .false.
[1793]786    ELSE
787      zp = 0 ; IF (PRESENT(permission)) zp = INT(permission,kind=C_INT)
788      ! Defaults are set in the C function.
[3318]789      cpath = cstring(ADJUSTL(path))
790      ret = INT(access_c(cpath,zp)) == 0
[1793]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    !!
[3083]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
[1793]800    !! of the string.
801    !! @note
[3083]802    !! If the basename of the path begins by a dot then the path is assumed to be an hidden file (directory).
[1793]803    !! __ext__ will then be empty.
[3083]804    CHARACTER(len=*), INTENT(in)               :: path     !! Path to split
[1793]805    CHARACTER(len=:), INTENT(out), ALLOCATABLE :: base, &  !! Output base of the path
806                                                  ext      !! Output extension of the path
[3083]807    LOGICAL, INTENT(in), OPTIONAL              :: absolute !! .true. to return absolute path
808    LOGICAL                       :: ret                   !! .true. on success, .false. otherwise.
[1793]809    LOGICAL                       :: zabs
810    INTEGER                       :: p
811    CHARACTER(len=:), ALLOCATABLE :: d,b,apath
[3083]812    base = "" ; ext = ""
[1793]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
[3083]821    ENDIF
[1793]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
[3083]827      ext = b(p:) ; base = TRIM(d)//"/"//b(:p-1)
[1793]828    ELSE
[3083]829      base = TRIM(apath)
[1793]830    ENDIF
831    ret = .true.
832    RETURN
833  END FUNCTION fs_split_ext
834
835  FUNCTION fs_create(path, mode, type, permissive) RESULT(ret)
[3083]836    !! Create a directory/file
[1793]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.
[3083]848    CHARACTER(len=*), INTENT(in)           :: path        !! Path to create
[1793]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
[3083]854    CHARACTER(len=:), ALLOCATABLE :: b,e
[3318]855    CHARACTER(len=:), ALLOCATABLE :: cpath
[1793]856    ret = .false.
857    ! Checking for existence
858    IF (LEN_TRIM(path) == 0) THEN
859      RETURN
860    ELSE IF (fs_access(path)) THEN
[3083]861      RETURN
[1793]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
[3083]866        RETURN
[1793]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
[3083]876      zmd = oct_2_dec(777)-get_umask()
[1793]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
[3318]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
[1793]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
[3083]898    !!
899    !! The method first resolves the given path using [[fsystem(module):fs_realpath(function)]]
[1793]900    !! to get an absolute path.
[3083]901    !! @note
[1793]902    !! If __n__ is greater than the maximum parent level of the path, "/" is returned.
903    CHARACTER(len=*), INTENT(in)  :: path
904      !! Input path
[3083]905    INTEGER, INTENT(in), OPTIONAL :: n
[1793]906      !! The level of the parent to get
907    CHARACTER(len=:), ALLOCATABLE :: opath
[3083]908      !! The nth parent of the given path, or an empty string if the parent can not be computed
[1793]909    CHARACTER(len=:), ALLOCATABLE :: zp
910    INTEGER                       :: i,mx,zl,mzl
[3083]911    opath = ""
[1793]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
[3083]924    DO
[1793]925      mx = INDEX(zp(1:mx),'/',.true.) ; i=i+1
[3083]926      IF (mx==0.OR.i>=zl.OR.i>=mzl) EXIT
[1793]927      mx = mx - 1
928    ENDDO
929    IF (mx >= 1) THEN
930      opath = zp(1:MAX(1,mx-1))
[3083]931    ELSE
932      opath = "/"
[1793]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
[3083]953    !! @note
954    !! Currently if C usleep function failed, the system... does not sleep !
[1793]955    INTEGER, INTENT(in) :: usec !! The number of microseconds to sleep for
[3083]956    INTEGER(kind=C_INT) :: ret
[1793]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
[1897]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
[3083]1003    INTEGER(kind=8)  :: ztot,zava,zfre
[1897]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
[3083]1008    ztot = ztot * 1024 ; zava = zava * 1024 ; zfre = zfre * 1024
[1897]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
[1793]1032!===============================================================================
1033! MODULE MISCELLANEOUS METHODS
1034!===============================================================================
1035
1036  FUNCTION oct_2_dec(octal) RESULT(res)
1037    !> Octal to decimal conversion
[3083]1038    !!
[1793]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
[3083]1053    RETURN
[1793]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
[3083]1083    INTEGER :: oct                     !! Octal value of the string permission on succes, -1 otherwise.
[1793]1084    oct = -1
1085    IF (LEN_TRIM(str) /= 3) RETURN
1086    SELECT CASE(str)
[3083]1087      CASE("---")  ; oct = 0
[1793]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
[3083]1095      CASE DEFAULT
[1793]1096        oct = -1 ; RETURN
[3083]1097    END SELECT
[1793]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"
[3083]1114      CASE DEFAULT
[1793]1115        str='ukn' ; RETURN
[3083]1116    END SELECT
[1793]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
[3083]1122    INTEGER, INTENT(in) :: oct_perm !! The octal representation of the permission
[1793]1123    CHARACTER(len=9) :: ret      !! String representation of the octal number on succes, 'ukn' otherwise
1124    INTEGER :: u,g,o
[3083]1125    IF (.NOT.chk_pm(oct_perm)) THEN
[1793]1126      ret = "ukn" ; RETURN
1127    ENDIF
1128    u=int(oct_perm/100) ; g=int((oct_perm-u*100)/10) ; o=int(oct_perm-u*100-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 = u*100 + g*10 + 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-u*100)/10) ; o=int(perm-u*100-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
[1897]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)
[3083]1193    !! Start the chrono.
[1897]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.
[3083]1204  END SUBROUTINE chrono_start
[1897]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
[3083]1221  SUBROUTINE chrono_get(this,cpu,clock,units)
[1897]1222    !! Get elapsed time since last call of start or reset methods.
[3083]1223    !!
[1897]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.
[3083]1227    !! - Otherwise, elapsed time since the last call of
[1897]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).
[3083]1233    REAL(kind=8), INTENT(out), OPTIONAL    :: clock
[1897]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
[3083]1237      !! be one of the following : 'ms', 's' (default), 'm', 'h' or 'd'.
[1897]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
[3083]1247        CALL SYSTEM_CLOCK(ck,r,m)
[1897]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
[3083]1255    zu = 's'
[1897]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
[3083]1266    IF (PRESENT(cpu)) cpu = cpu / fact
[1897]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
[3083]1273    INTEGER(kind=8), INTENT(in) :: i !! Initial clock count
[1897]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
[1793]1282END MODULE FSYSTEM
[1897]1283
Note: See TracBrowser for help on using the repository browser.