Fortran Wiki
m_system

M_system module

OVERVIEW

As the C interface provided by the ISO_C_BINDING module has matured, it is becoming relatively easy to incorporate C-based libraries into Fortran programs. The following is a collection of interfaces to common C POSIX system functions. These have recently only been tested with GNU Fortran 7.4.0 but should be portable to other modern Fortran compilers.

Many were written early in the availability of the ISO_C_BINDING and could be simplified or improved upon (I used what worked at the time); please feel free to do so. This is intended to be a seed for others to build on.

There is a cursory example program included in the source for each of the procedures.

Using the GNU compiler as an example and the three following files a demonstration of the M_system(3f) module can be tested using

 gfortran -c M_system.f90
 gcc      -c C-M_system.c
 gfortran  -I. demo.f90 C-M_system.o M_system.o -o demo
 ./demo

This is a subset of the procedures available in the GPF (General Purpose Fortran) collection, which includes sample codes and man(1) pages for these routines and others.

NAME

M_system(3f) - Fortran interface to C system interface procedures (mostly POSIX)

SYNOPSIS

**Public objects:**

 use m_system, only : set_environment_variable, system_unsetenv, &
 system_putenv, system_getenv

 use m_system, only :  system_intenv, system_readenv, system_clearenv

 use M_system, only : system_getcwd, system_link,       &
 system_mkfifo, system_remove, system_rename,           &
 system_umask, system_unlink,                           &
 system_rmdir, system_chdir, system_mkdir,              &
 system_stat, system_isdir, system_islnk, system_isreg, &
 system_isblk, system_ischr, system_isfifo,             &
 system_realpath,                                       &
 system_access,                                         &
 system_utime,                                          &
 system_issock, system_perm

 use M_system, only : system_errno, system_perror

 use M_system, only : system_getegid, system_geteuid, system_getgid, &
 system_gethostname, system_getpid, system_getppid, system_getsid, &
 system_getuid, system_uname

 use M_system, only : system_kill

 use M_system, only : system_rand, system_srand

 use M_system, only : system_cpu_time

DESCRIPTION

M_system(3fm) is a collection of Fortran procedures that call C or a C wrapper using the ISO_C_BINDING interface to access system calls. System calls are a special set of functions used by programs to communicate directly with an operating system.

Generally, system calls are slower than normal function calls because when you make a call control is relinquished to the operating system to perform the system call. In addition, depending on the nature of the system call, your program may be blocked by the OS until the system call has finished, thus making the execution time of your program even longer.

ENVIRONMENT ACCESS

  • system_putenv(3f): call putenv(3c)

  • system_getenv(3f): function call to get_environment_variable(3f)

  • system_unsetenv(3f): call unsetenv(3c) to remove variable from environment

  • set_environment_variable(3f): set environment variable by calling setenv(3c)

  • system_initenv(3f): initialize environment table for reading

  • system_readenv(3f): read next entry from environment table

  • system_clearenv(3f): emulate clearenv(3c) to clear environment

FILE SYSTEM

  • system_chdir(3f): call chdir(3c) to change current directory of a process

  • system_getcwd(3f): call getcwd(3c) to get pathname of current working directory

  • system_stat(3f): determine system information of file by name

  • system_perm(3f): create string representing file permission and type

  • system_access(3f): determine filename access or existence

  • system_isdir(3f): determine if filename is a directory

  • system_islnk(3f): determine if filename is a link

  • system_isreg(3f): determine if filename is a regular file

  • system_isblk(3f): determine if filename is a block device

  • system_ischr(3f): determine if filename is a character device

  • system_isfifo(3f): determine if filename is a fifo - named pipe

  • system_issock(3f): determine if filename is a socket

  • system_realpath(3f): resolve a pathname

  • system_chmod(3f): call chmod(3c) to set file permission mode

  • system_chown(3f): call chown(3c) to set file owner

  • system_getumask(3f): call umask(3c) to get process permission mask

  • system_setumask(3f): call umask(3c) to set process permission mask

  • system_mkdir(3f): call mkdir(3c) to create empty directory

  • system_mkfifo(3f): call mkfifo(3c) to create a special FIFO file

  • system_link(3f): call link(3c) to create a filename link

  • system_rename(3f): call rename(3c) to change filename

  • system_remove(3f): call remove(3c) to remove file

  • system_rmdir(3f): call rmdir(3c) to remove empty directory

  • system_unlink(3f): call unlink(3c) to remove a link to a file

  • system_utime(3f): call utime(3c) to set file access and modification times

RANDOM NUMBERS

  • system_srand(3f): call srand(3c)
  • system_rand(3f): call rand(3c)

C ERROR INFORMATION

  • system_errno(3f): return errno(3c)
  • system_perror(3f): call perror(3c) to display last C error message

QUERIES

  • system_geteuid(3f): call geteuid(3c)
  • system_getuid(3f): call getuid(3c)
  • system_getegid(3f): call getegid(3c)
  • system_getgid(3f): call getgid(3c)
  • system_getpid(3f): call getpid(3c)
  • system_getppid(3f): call getppid(3c)
  • system_gethostname(3f): get name of current host
  • system_uname(3f): call my_uname(3c) which calls uname(3c)
  • system_getlogin(3f): get login name
  • system_getpwuid(3f): get login name associated with given UID
  • system_getgrgid(3f): get group name associated with given GID
  • system_cpu_time(3f) : get processor time in seconds using times(3c)

SEE ALSO

Some vendors provide their own way to access POSIX functions and make those available as modules; for instance …

  • the IFPORT module of Intel
  • or the f90_* modules of NAG.
  • There are also other compiler-independent efforts to make the POSIX procedures accessible from Fortran…
    • Posix90 (doc),
    • flib.a platform/files and directories,
    • fortranposix.

module M_system
use,intrinsic     :: iso_c_binding, only: c_float, c_int, c_char
use,intrinsic     :: iso_c_binding, only: c_ptr, c_f_pointer, c_null_char, c_null_ptr
use,intrinsic     :: iso_c_binding
use iso_fortran_env, only : int8, int16, int32, int64

implicit none
private
! C types. Might be platform dependent
integer,parameter,public :: mode_t=int32

public :: system_rand
public :: system_srand

public :: system_getpid                  ! return process ID
public :: system_getppid                 ! return parent process ID
public :: system_getuid, system_geteuid  ! return user ID
public :: system_getgid, system_getegid  ! return group ID
public :: system_getsid
public :: system_kill                    ! (pid, signal) kill process (defaults: pid=0, signal=SIGTERM)

public :: system_errno
public :: system_perror

public :: system_putenv
public :: system_getenv
public :: set_environment_variable
public :: system_unsetenv

public :: system_initenv
public :: system_readenv
public :: system_clearenv

public :: system_stat                    ! call stat(3c) to determine system information of file by name
public :: system_perm                    ! create string representing file permission and type
public :: system_access                  ! determine filename access or existence
public :: system_isdir                   ! determine if filename is a directory
public :: system_islnk                   ! determine if filename is a link
public :: system_isreg                   ! determine if filename is a regular file
public :: system_isblk                   ! determine if filename is a block device
public :: system_ischr                   ! determine if filename is a character device
public :: system_isfifo                  ! determine if filename is a fifo - named pipe
public :: system_issock                  ! determine if filename is a socket
public :: system_realpath                ! resolve pathname

public :: system_chdir
public :: system_rmdir
public :: system_remove
public :: system_rename

public :: system_mkdir
public :: system_mkfifo
public :: system_chmod
public :: system_chown
public :: system_link
public :: system_unlink

public :: system_setumask
public :: system_getumask
private :: system_umask

public :: system_getcwd

public :: system_opendir
public :: system_readdir
public :: system_rewinddir
public :: system_closedir

public :: system_cpu_time

public :: system_uname
public :: system_gethostname
public :: system_getlogin
public :: system_getpwuid
public :: system_getgrgid

public :: R_GRP,R_OTH,R_USR,R_WXG,R_WXO,R_WXU,W_GRP,W_OTH,W_USR,X_GRP,X_OTH,X_USR,DEFFILEMODE,ACCESSPERMS
public :: R_OK,W_OK,X_OK,F_OK  ! for system_access
!===================================================================================================================================
type, bind(C) :: dirent_SYSTEMA
  integer(c_long)    :: d_ino
  integer(c_long)    :: d_off; ! __off_t, check size
  integer(c_short)   :: d_reclen
  character(len=1,kind=c_char) :: d_name(256)
end type

type, bind(C) :: dirent_CYGWIN
  integer(c_int)       :: d_version
  integer(c_long)      :: d_ino
  character(kind=c_char)    :: d_type
  character(kind=c_char)    :: d_unused1(3)
  integer(c_int)       :: d_internal1
  character(len=1,kind=c_char) ::  d_name(256)
end type
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!    system_srand(3f) - [M_system] set seed for pseudo-random number generator system_rand(3f)
!!
!!##SYNOPSIS
!!
!!    subroutine system_srand()
!!
!!##DESCRIPTION
!!    system_srand(3f) calls the C routine srand(3c) The
!!    srand(3c)/system_srand(3f) function uses its argument as the seed
!!    for a new sequence of pseudo-random integers to be returned by
!!    system_rand(3f)/rand(3c). These sequences are repeatable by calling
!!    system_srand(3f) with the same seed value. If no seed value is
!!    provided, the system_rand(3f) function is automatically seeded with
!!    a value of 1.
!!
!!##EXAMPLE
!!
!!    Sample program:
!!
!!       program demo_system_srand
!!       use M_system, only : system_srand, system_rand
!!       implicit none
!!       integer :: i,j
!!       do j=1,2
!!          call system_srand(1001)
!!          do i=1,10
!!             write(*,*)system_rand()
!!          enddo
!!          write(*,*)
!!       enddo
!!       end program demo_system_srand
!!   expected results:
!!
!!      1512084687
!!      1329390995
!!      1874040748
!!        60731048
!!       239808950
!!      2017891911
!!        22055588
!!      1105177318
!!       347750200
!!      1729645355
!!
!!      1512084687
!!      1329390995
!!      1874040748
!!        60731048
!!       239808950
!!      2017891911
!!        22055588
!!      1105177318
!!       347750200
!!      1729645355
!!
!!##SEE ALSO
!!    drand48(3c), random(3c)
!===================================================================================================================================
character(len=*),parameter :: ident_srand="@(#) M_system::system_srand(3f): call srand(3c)"
! void srand_system(int *seed)
interface
   subroutine system_srand(seed) bind(c,name='srand')
      import c_int
      integer(kind=c_int),intent(in) :: seed
   end subroutine system_srand
end interface
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!    system_kill(3f) - [M_system] send a signal to a process or a group of processes
!!
!!##SYNOPSIS
!!
!!    integer(kind=c_int) function system_kill(pid,sig)
!!
!!       integer,intent(in) :: pid
!!       integer,intent(in) :: sig
!!
!!##DESCRIPTION
!!
!!    The kill() function shall send a signal to a process or a group of
!!    processes specified by pid. The signal to be sent is specified by sig
!!    and is either one from the list given in <signal.h> or 0. If sig is 0
!!    (the null signal), error checking is performed but no signal is actually
!!    sent. The null signal can be used to check the validity of pid.
!!
!!    For a process to have permission to send a signal to a process designated
!!    by pid, unless the sending process has appropriate privileges, the real
!!    or effective user ID of the sending process shall match the real or
!!    saved set-user-ID of the receiving process.
!!
!!    If pid is greater than 0, sig shall be sent to the process whose process
!!    ID is equal to pid.
!!
!!    If pid is 0, sig shall be sent to all processes (excluding an unspecified
!!    set of system processes) whose process group ID is equal to the process
!!    group ID of the sender, and for which the process has permission to send
!!    a signal.
!!
!!    If pid is -1, sig shall be sent to all processes (excluding an unspecified
!!    set of system processes) for which the process has permission to send
!!    that signal.
!!
!!    If pid is negative, but not -1, sig shall be sent to all processes
!!    (excluding an unspecified set of system processes) whose process group
!!    ID is equal to the absolute value of pid, and for which the process has
!!    permission to send a signal.
!!
!!    If the value of pid causes sig to be generated for the sending process,
!!    and if sig is not blocked for the calling thread and if no other thread
!!    has sig unblocked or is waiting in a sigwait() function for sig, either
!!    sig or at least one pending unblocked signal shall be delivered to the
!!    sending thread before kill() returns.
!!
!!    The user ID tests described above shall not be applied when sending
!!    SIGCONT to a process that is a member of the same session as the sending
!!    process.
!!
!!    An implementation that provides extended security controls may impose
!!    further implementation-defined restrictions on the sending of signals,
!!    including the null signal. In particular, the system may deny the
!!    existence of some or all of the processes specified by pid.
!!
!!    The kill() function is successful if the process has permission to send
!!    sig to any of the processes specified by pid. If kill() fails, no signal
!!    shall be sent.
!!
!!
!!##RETURN VALUE
!!
!!    Upon successful completion, 0 shall be returned. Otherwise, -1 shall be
!!    returned and errno set to indicate the error.
!!
!!##ERRORS
!!    The kill() function shall fail if:
!!
!!    EINVAL  The value of the sig argument is an invalid or unsupported
!!            signal number.
!!    EPERM   The process does not have permission to send the signal to
!!            any receiving process.
!!    ESRCH   No process or process group can be found corresponding to
!!            that specified by pid. The following sections are informative.
!!
!!##EXAMPLE
!!
!!   Sample program:
!!
!!    program demo_system_kill
!!    use M_system, only : system_kill
!!    use M_system, only : system_perror
!!    implicit none
!!    integer           :: i,pid,ios,ierr,signal=9
!!    character(len=80) :: argument
!!
!!       do i=1,command_argument_count()
!!          ! get arguments from command line
!!          call get_command_argument(i, argument)
!!          ! convert arguments to integers assuming they are PID numbers
!!          read(argument,'(i80)',iostat=ios) pid
!!          if(ios.ne.0)then
!!             write(*,*)'bad PID=',trim(argument)
!!          else
!!             write(*,*)'kill SIGNAL=',signal,' PID=',pid
!!          ! send signal SIGNAL to pid PID
!!             ierr=system_kill(pid,signal)
!!          ! write message if an error was detected
!!             if(ierr.ne.0)then
!!                call system_perror('*demo_system_kill*')
!!             endif
!!          endif
!!       enddo
!!    end program demo_system_kill
!!
!!##SEE ALSO
!!    getpid(), raise(), setsid(), sigaction(), sigqueue(),
!===================================================================================================================================
character(len=*),parameter :: ident_kill="@(#) M_system::system_kill(3f): call kill(3c) to send a signal to a process"
! int kill(pid_t pid, int sig);
interface
   function system_kill(c_pid,c_signal) bind(c,name="kill") result(c_ierr)
      import c_int
      integer(kind=c_int),value,intent(in)   :: c_pid
      integer(kind=c_int),value,intent(in)   :: c_signal
      integer(kind=c_int)                    :: c_ierr
   end function
end interface
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!    system_errno(3f) - [M_system] C error return value
!!##SYNOPSIS
!!
!!    integer(kind=c_int) function system_errno()
!!
!!##DESCRIPTION
!!    Many C routines return an error code which can be queried by errno.
!!    The M_system(3fm) is primarily composed of Fortran routines that call
!!    C routines. In the cases where an error code is returned vi system_errno(3f)
!!    these routines will indicate it.
!!
!!##EXAMPLE
!!
!!   Sample program:
!!
!!    program demo_system_errno
!!    use M_system, only: system_errno, system_unlink, system_perror
!!    implicit none
!!    integer :: stat
!!    stat=system_unlink('not there/OR/anywhere')
!!    if(stat.ne.0)then
!!            write(*,*)'err=',system_errno()
!!            call system_perror('*demo_system_errno*')
!!    endif
!!    end program demo_system_errno
!!
!!   Typical Results:
!!
!!    err=           2
!!    *demo_system_errno*: No such file or directory
!===================================================================================================================================
character(len=*),parameter :: ident_errno="@(#) M_system::system_errno(3f): return errno(3c)"

interface
   integer(kind=c_int) function system_errno() bind (C,name="my_errno")
      import c_int
   end function system_errno
end interface
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!    system_geteuid(3f) - [M_system:QUERY] get effective UID of current process from Fortran by calling geteuid(3c)
!!##SYNOPSIS
!!
!!    integer(kind=c_int) function system_geteuid()
!!
!!##DESCRIPTION
!!        The system_geteuid(3f) function shall return the effective user
!!        ID of the calling process. The geteuid() function shall always be
!!        successful and no return value is reserved to indicate the error.
!!##EXAMPLE
!!
!!   Get group ID from Fortran:
!!
!!    program demo_system_geteuid
!!    use M_system, only: system_geteuid
!!    implicit none
!!       write(*,*)'EFFECTIVE UID=',system_geteuid()
!!    end program demo_system_geteuid
!===================================================================================================================================
character(len=*),parameter :: ident_euid="@(#) M_system::system_geteuid(3f): call geteuid(3c)"
interface
   integer(kind=c_int) function system_geteuid() bind (C,name="geteuid")
      import c_int
   end function system_geteuid
end interface
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!    system_getuid(3f) - [M_system:QUERY] get real UID of current process from Fortran by calling getuid(3c)
!!##SYNOPSIS
!!
!!    integer(kind=c_int) function system_getuid()
!!
!!##DESCRIPTION
!!        The system_getuid(3f) function shall return the real user ID
!!        of the calling process. The getuid() function shall always be
!!        successful and no return value is reserved to indicate the error.
!!##EXAMPLE
!!
!!   Get group ID from Fortran:
!!
!!    program demo_system_getuid
!!    use M_system, only: system_getuid
!!    implicit none
!!       write(*,*)'UID=',system_getuid()
!!    end program demo_system_getuid
!!
!!   Results:
!!
!!    UID=      197609
!===================================================================================================================================
character(len=*),parameter :: ident_uid="@(#) M_system::system_getuid(3f): call getuid(3c)"
interface
   integer(kind=c_int) function system_getuid() bind (C,name="getuid")
      import c_int
   end function system_getuid
end interface
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!    system_getegid(3f) - [M_system:QUERY] get the effective group ID (GID) of current process from Fortran by calling getegid(3c)
!!##SYNOPSIS
!!
!!    integer(kind=c_int) function system_getegid()
!!##DESCRIPTION
!!        The getegid() function returns the effective group ID of the
!!        calling process.
!!
!!##RETURN VALUE
!!        The getegid() should always be successful and no return value is
!!        reserved to indicate an error.
!!
!!##ERRORS
!!        No errors are defined.
!!
!!##SEE ALSO
!!        getegid(), system_geteuid(), getuid(), setegid(), seteuid(), setgid(),
!!        setregid(), setreuid(), setuid()
!!
!!##EXAMPLE
!!
!!   Get group ID from Fortran
!!
!!    program demo_system_getegid
!!    use M_system, only: system_getegid
!!    implicit none
!!       write(*,*)'GID=',system_getegid()
!!    end program demo_system_getegid
!===================================================================================================================================
character(len=*),parameter :: ident_egid="@(#) M_system::system_getegid(3f): call getegid(3c)"
interface
   integer(kind=c_int) function system_getegid() bind (C,name="getegid")
      import c_int
   end function system_getegid
end interface
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!    system_getgid(3f) - [M_system:QUERY] get the real group ID (GID) of current process from Fortran by calling getgid(3c)
!!##SYNOPSIS
!!
!!    integer(kind=c_int) function system_getgid()
!!##DESCRIPTION
!!        The getgid() function returns the real group ID of the calling process.
!!
!!##RETURN VALUE
!!        The getgid() should always be successful and no return value is
!!        reserved to indicate an error.
!!
!!##ERRORS
!!        No errors are defined.
!!
!!##SEE ALSO
!!        getegid(), system_geteuid(), getuid(), setegid(), seteuid(), setgid(),
!!        setregid(), setreuid(), setuid()
!!
!!##EXAMPLE
!!
!!   Get group ID from Fortran
!!
!!    program demo_system_getgid
!!    use M_system, only: system_getgid
!!    implicit none
!!       write(*,*)'GID=',system_getgid()
!!    end program demo_system_getgid
!===================================================================================================================================
character(len=*),parameter :: ident_gid="@(#) M_system::system_getgid(3f): call getgid(3c)"
interface
   integer(kind=c_int) function system_getgid() bind (C,name="getgid")
      import c_int
   end function system_getgid
end interface
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!        system_getsid(3f) - [M_system:QUERY] get the process group ID of a session leader
!!##SYNOPSIS
!!
!!        integer(kind=c_int) function system_getsid(pid)
!!        integer(kind=c_int) :: pid
!!##DESCRIPTION
!!        The system_getsid() function obtains the process group ID of the
!!        process that is the session leader of the process specified by pid.
!!        If pid is 0, it specifies the calling process.
!!##RETURN VALUE
!!        Upon successful completion, system_getsid() shall return the process group
!!        ID of the session leader of the specified process. Otherwise,
!!        it shall return -1 and set errno to indicate the error.
!!##EXAMPLE
!!
!!   Get SID from Fortran
!!
!!    program demo_system_getsid
!!    use M_system,      only : system_getsid
!!    use ISO_C_BINDING, only : c_int
!!    implicit none
!!       write(*,*)'SID=',system_getsid(0_c_int)
!!    end program demo_system_getsid
!===================================================================================================================================
character(len=*),parameter :: ident_getsid="@(#) M_system::system_getsid(3f): call getsid(3c) to get session leader for given pid"
interface
   integer(kind=c_int) function system_getsid(c_pid) bind (C,name="getsid")
      import c_int
      integer(kind=c_int) :: c_pid
   end function system_getsid
end interface
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!    system_getpid(3f) - [M_system:QUERY] get PID (process ID) of current process from Fortran by calling getpid(3c)
!!##SYNOPSIS
!!
!!    integer function system_getpid()
!!##DESCRIPTION
!!        The system_getpid() function returns the process ID of the
!!        calling process.
!!##RETURN VALUE
!!        The value returned is the integer process ID. The system_getpid()
!!        function shall always be successful and no return value is reserved
!!        to indicate an error.
!!##EXAMPLE
!!
!!   Get process PID from Fortran
!!
!!    program demo_system_getpid
!!    use M_system, only: system_getpid
!!    implicit none
!!       write(*,*)'PID=',system_getpid()
!!    end program demo_system_getpid
!===================================================================================================================================
character(len=*),parameter :: ident_pid="@(#) M_system::system_getpid(3f): call getpid(3c)"

interface
   integer(kind=c_int) function system_getpid() bind (C,name="getpid")
      import c_int
   end function system_getpid
end interface
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!    system_getppid(3f) - [M_system:QUERY] get parent process ID (PPID) of current process from Fortran by calling getppid(3c)
!!##SYNOPSIS
!!
!!    integer(kind=c_int) function system_getppid()
!!##DESCRIPTION
!!        The system_getppid() function returns the parent process ID of
!!        the calling process.
!!
!!##RETURN VALUE
!!        The system_getppid() function should always be successful and no
!!        return value is reserved to indicate an error.
!!
!!##ERRORS
!!        No errors are defined.
!!
!!##SEE ALSO
!!        exec, fork(), getpgid(), getpgrp(), getpid(), kill(),
!!        setpgid(), setsid()
!!
!!##EXAMPLE
!!
!!   Get parent process PID (PPID) from Fortran
!!
!!    program demo_system_getppid
!!    use M_system, only: system_getppid
!!    implicit none
!!
!!    write(*,*)'PPID=',system_getppid()
!!
!!    end program demo_system_getppid
!===================================================================================================================================
character(len=*),parameter :: ident_ppid="@(#) M_system::system_getppid(3f): call getppid(3c)"
interface
   integer(kind=c_int) function system_getppid() bind (C,name="getppid")
   import c_int
   end function system_getppid
end interface
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!    system_umask(3fp) - [M_system] set and get the file mode creation mask
!!##SYNOPSIS
!!
!!    integer(kind=c_int) function system_umask(umask_value)
!!
!!##DESCRIPTION
!!        The umask() function shall set the file mode creation mask of the
!!        process to cmask and return the previous value of the mask. Only
!!        the file permission bits of cmask (see <sys/stat.h>) are used;
!!        the meaning of the other bits is implementation-defined.
!!
!!        The file mode creation mask of the process is used to turn off
!!        permission bits in the mode argument supplied during calls to
!!        the following functions:
!!
!!         *  open(), openat(), creat(), mkdir(), mkdirat(), mkfifo(), and mkfifoat()
!!         *  mknod(), mknodat()
!!         *  mq_open()
!!         *  sem_open()
!!
!!        Bit positions that are set in cmask are cleared in the mode of the created file.
!!
!!##RETURN VALUE
!!        The file permission bits in the value returned by umask() shall be
!!        the previous value of the file mode creation mask. The state of any
!!        other bits in that value is unspecified, except that a subsequent
!!        call to umask() with the returned value as cmask shall leave the
!!        state of the mask the same as its state before the first call,
!!        including any unspecified use of those bits.
!!
!!##EXAMPLE
!!
!!   Sample program:
!!
!!    program demo_system_umask
!!    use M_system, only: system_getumask, system_setumask
!!    implicit none
!!    integer value
!!    value=system_getumask(002)
!!    write(*,*)'VALUE=',value
!!    value=system_setumask(value)
!!    write(*,*)'VALUE=',value
!!    end program demo_system_umask
!===================================================================================================================================
character(len=*),parameter :: ident_umask="@(#) M_system::system_umask(3f): call umask(3c)"
interface
   integer(kind=c_int) function system_umask(umask_value) bind (C,name="umask")
   import c_int
   integer(kind=c_int),value :: umask_value
   end function system_umask
end interface
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!    system_rand(3f) - [M_system] call pseudo-random number generator rand(3c)
!!##SYNOPSIS
!!
!!    integer(kind=c_int) :: function system_rand()
!!##DESCRIPTION
!!    Use rand(3c) to generate pseudo-random numbers.
!!
!!##EXAMPLE
!!
!!    Sample program:
!!
!!       program demo_system_srand
!!       use M_system, only : system_srand, system_rand
!!       implicit none
!!       integer :: i
!!
!!       call system_srand(1001)
!!       do i=1,10
!!          write(*,*)system_rand()
!!       enddo
!!       write(*,*)
!!
!!       end program demo_system_srand
!!   expected results:
!!
!!      1512084687
!!      1329390995
!!      1874040748
!!        60731048
!!       239808950
!!      2017891911
!!        22055588
!!      1105177318
!!       347750200
!!      1729645355
!!
!!      1512084687
!!      1329390995
!!      1874040748
!!        60731048
!!       239808950
!!      2017891911
!!        22055588
!!      1105177318
!!       347750200
!!      1729645355
!===================================================================================================================================
character(len=*),parameter :: ident_rand="@(#) M_system::system_rand(3f): call rand(3c)"
interface
   integer(kind=c_int) function system_rand() bind (C,name="rand")
      import c_int
   end function system_rand
end interface
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
interface
  subroutine c_flush() bind(C,name="my_flush")
  end subroutine c_flush
end interface
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!    system_initenv(3f) - [M_system:ENVIRONMENT] initialize environment table pointer and size so table can be read by readenv(3f)
!!##SYNOPSIS
!!
!!       subroutine system_initenv()
!!##DESCRIPTION
!!    A simple interface allows reading the environment variable table
!!    of the process. Call system_initenv(3f) to initialize reading the
!!    environment table, then call system_readenv(3f) until a blank line
!!    is returned. If more than one thread reads the environment or the
!!    environment is changed while being read the results are undefined.
!!
!!##EXAMPLE
!!
!!   Sample program:
!!
!!    program demo_system_initenv
!!    use M_system, only : system_initenv, system_readenv
!!    character(len=:),allocatable :: string
!!       call system_initenv()
!!       do
!!          string=system_readenv()
!!          if(string.eq.'')then
!!             exit
!!          else
!!             write(*,'(a)')string
!!          endif
!!       enddo
!!    end program demo_system_initenv
!!
!!   Sample results:
!!
!!    USERDOMAIN_ROAMINGPROFILE=buzz
!!    HOMEPATH=\Users\JSU
!!    APPDATA=C:\Users\JSU\AppData\Roaming
!!    MANPATH=/home/urbanjs/V600/LIBRARY/libGPF/download/tmp/man:/home/urbanjs/V600/doc/man:::
!!    DISPLAYNUM=0
!!    ProgramW6432=C:\Program Files
!!    HOSTNAME=buzz
!!    XKEYSYMDB=/usr/share/X11/XKeysymDB
!!    PUBLISH_CMD=
!!    OnlineServices=Online Services
!!         :
!!         :
!!         :
!===================================================================================================================================

integer(kind=c_long),bind(c,name="longest_env_variable") :: longest_env_variable

!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
character(len=*),parameter :: ident_initenv="@(#) M_system::system_initenv(3f): initialize environment table for reading"
interface
   subroutine system_initenv() bind (C,NAME='my_initenv')
   end subroutine system_initenv
end interface
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!!type(c_ptr),bind(c,name="environ") :: c_environ

integer(kind=mode_t),bind(c,name="FS_IRGRP") ::R_GRP
integer(kind=mode_t),bind(c,name="FS_IROTH") ::R_OTH
integer(kind=mode_t),bind(c,name="FS_IRUSR") ::R_USR
integer(kind=mode_t),bind(c,name="FS_IRWXG") ::R_WXG
integer(kind=mode_t),bind(c,name="FS_IRWXO") ::R_WXO
integer(kind=mode_t),bind(c,name="FS_IRWXU") ::R_WXU
integer(kind=mode_t),bind(c,name="FS_IWGRP") ::W_GRP
integer(kind=mode_t),bind(c,name="FS_IWOTH") ::W_OTH
integer(kind=mode_t),bind(c,name="FS_IWUSR") ::W_USR
integer(kind=mode_t),bind(c,name="FS_IXGRP") ::X_GRP
integer(kind=mode_t),bind(c,name="FS_IXOTH") ::X_OTH
integer(kind=mode_t),bind(c,name="FS_IXUSR") ::X_USR
integer(kind=mode_t),bind(c,name="FDEFFILEMODE") :: DEFFILEMODE
integer(kind=mode_t),bind(c,name="FACCESSPERMS") :: ACCESSPERMS

! Host names are limited to {HOST_NAME_MAX} bytes.
integer(kind=mode_t),bind(c,name="FHOST_NAME_MAX") :: HOST_NAME_MAX
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
! for system_access(3f)
!integer(kind=c_int),bind(c,name="F_OK") :: F_OK
!integer(kind=c_int),bind(c,name="R_OK") :: R_OK
!integer(kind=c_int),bind(c,name="W_OK") :: W_OK
!integer(kind=c_int),bind(c,name="X_OK") :: X_OK
! not sure these will be the same on all systems, but above did not work
integer(kind=c_int),parameter           :: F_OK=0
integer(kind=c_int),parameter           :: R_OK=4
integer(kind=c_int),parameter           :: W_OK=2
integer(kind=c_int),parameter           :: X_OK=1
!===================================================================================================================================
contains
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!    system_access(3f) - [M_system] checks accessibility or existence of a pathname
!!
!!##SYNOPSIS
!!
!!   logical function system_access(pathname,amode)
!!
!!    character(len=*),intent(in) :: pathname
!!    integer,intent(in)          :: amode
!!
!!##DESCRIPTION
!!
!!    The system_access(3f) function checks pathname existence and access
!!    permissions. The function checks the pathname for accessibility
!!    according to the bit pattern contained in amode, using the real user
!!    ID in place of the effective user ID and the real group ID in place
!!    of the effective group ID.
!!
!!    The value of amode is either the bitwise-inclusive OR of the access
!!    permissions to be checked (R_OK, W_OK, X_OK) or the existence test (F_OK).
!!
!!##OPTIONS
!!        pathname   a character string representing a directory pathname. Trailing spaces are ignored.
!!        amode      bitwise-inclusive OR of the values R_OK, W_OK, X_OK, or F_OK.
!!
!!##RETURN VALUE
!!        If not true an error occurred or the requested access is not granted
!!
!!##EXAMPLE
!!
!!   check if filename is accessible
!!
!!        Sample program:
!!
!!           program demo_system_access
!!           Use M_system, only : system_access, F_OK, R_OK, W_OK, X_OK
!!           implicit none
!!           integer                     :: i
!!           character(len=80),parameter :: names(*)=[ &
!!           '/usr/bin/bash   ', &
!!           '/tmp/NOTTHERE   ', &
!!           '/usr/local      ', &
!!           '.               ', &
!!           'PROBABLY_NOT    ']
!!           do i=1,size(names)
!!              write(*,*)' does ',trim(names(i)),' exist?    ', system_access(names(i),F_OK)
!!              write(*,*)' is ',trim(names(i)),' readable?     ', system_access(names(i),R_OK)
!!              write(*,*)' is ',trim(names(i)),' writeable?    ', system_access(names(i),W_OK)
!!              write(*,*)' is ',trim(names(i)),' executable?   ', system_access(names(i),X_OK)
!!           enddo
!!           end program demo_system_access
!===================================================================================================================================
function system_access(pathname,amode)
implicit none

character(len=*),parameter::ident_1="@(#)M_system::system_access(3f): checks accessibility or existence of a pathname"

character(len=*),intent(in) :: pathname
integer,intent(in)          :: amode
logical                     :: system_access

interface
  function c_access(c_pathname,c_amode) bind (C,name="my_access") result (c_ierr)
  import c_char,c_int
  character(kind=c_char,len=1),intent(in) :: c_pathname(*)
  integer(kind=c_int),value               :: c_amode
  integer(kind=c_int)                     :: c_ierr
  end function c_access
end interface

   if(c_access(str2arr(trim(pathname)),int(amode,kind=c_int)).eq.0)then
      system_access=.true.
   else
      system_access=.false.
    !!if(system_errno().ne.0)then
    !!   call perror('*system_access*')
    !!endif
   endif

end function system_access
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!       system_realpath(3f) - [M_system] call realpath(3c) to resolve a pathname
!!##SYNOPSIS
!!
!!       subroutine system_realpath(input,output,ierr)
!!
!!        character(len=*),intent(in)              :: input
!!        character(len=:),allocatable,intent(out) :: output
!!        integer,intent(out)                      :: ierr
!!##DESCRIPTION
!!        system_realpath(3f) calls the C routine realpath(3c) to obtain the absolute pathname of given path
!!##OPTIONS
!!
!!        INPUT     pathname to resolve
!!##RETURN VALUE
!!        OUTPUT    The absolute pathname of the given input pathname.
!!                  The pathname shall contain no components that are dot or dot-dot,
!!                  or are symbolic links.
!!        IERR      is not zero if an error occurs.
!!
!!##EXAMPLE
!!
!!   Sample program:
!!
!!    program demo_system_realpath
!!    use M_system, only : system_realpath, system_perror
!!    implicit none
!!    ! resolve each pathname given on command line
!!    character(len=:),allocatable :: pathi,patho
!!    integer                      :: i
!!    integer                      :: filename_length
!!    integer                      :: ierr
!!       do i = 1, command_argument_count()
!!          ! get pathname from command line arguments
!!          call get_command_argument (i , length=filename_length)
!!          allocate(character(len=filename_length) :: pathi)
!!          call get_command_argument (i , value=pathi)
!!          !
!!          ! resolve each pathname
!!          call system_realpath(pathi,patho,ierr)
!!          if(ierr.eq.0)then
!!             write(*,*)trim(pathi),'=>',trim(patho)
!!          else
!!             call system_perror('*system_realpath* error for pathname '//trim(pathi)//':')
!!             write(*,*)trim(pathi),'=>',trim(patho)
!!          endif
!!          deallocate(pathi)
!!       enddo
!!       ! if there were no pathnames give resolve the pathname "."
!!       if(i.eq.1)then
!!          call system_realpath('.',patho,ierr)
!!          write(*,*)'.=>',trim(patho)
!!       endif
!!    end program demo_system_realpath
!!
!!  Example usage:
!!
!!   demo_system_realpath
!!   .=>/home/urbanjs/V600
!!
!!   cd /usr/share/man
!!   demo_system_realpath . .. NotThere
!!   .=>/usr/share/man
!!   ..=>/usr/share
!!   *system_realpath* error for pathname NotThere:: No such file or directory
!!   NotThere=>NotThere
!===================================================================================================================================
subroutine system_realpath(input,output,ierr)

character(len=*),parameter::ident_3="&
&@(#)M_system::system_realpath(3f):call realpath(3c) to get pathname of current working directory"

character(len=*),intent(in)              :: input
character(len=:),allocatable,intent(out) :: output
integer,intent(out)                      :: ierr
integer(kind=c_long),parameter           :: length=4097_c_long
character(kind=c_char,len=1)             :: buffer(length)
interface
   function c_realpath(c_input,c_output) bind(c,name="my_realpath") result(ierr)
      import c_char, c_size_t, c_ptr, c_int
      character(kind=c_char) ,intent(in)  :: c_input(*)
      character(kind=c_char) ,intent(out) :: c_output(*)
      integer(c_int)                      :: ierr
   end function
end interface
!-----------------------------------------------------------------------------------------------------------------------------------
   buffer=' '
   ierr=c_realpath(str2arr(trim(input)),buffer)
   if(ierr.ne.0)then
      output=input
      ierr=-1
   else
      output=trim(arr2str(buffer))
      ierr=0
   endif
end subroutine system_realpath
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!    system_issock(3f) - [M_system] checks if argument is a socket
!!
!!##SYNOPSIS
!!
!!   logical function system_issock(pathname)
!!
!!    character(len=*),intent(in) :: pathname
!!    logical                     :: system_issock
!!
!!##DESCRIPTION
!!        The issock(3f) function checks if path is a path to a socket
!!
!!##OPTIONS
!!        path   a character string representing a socket pathname. Trailing spaces are ignored.
!!
!!##RETURN VALUE
!!        The system_issock() function should always be successful and no
!!        return value is reserved to indicate an error.
!!
!!##ERRORS
!!        No errors are defined.
!!
!!##SEE ALSO
!!    system_isreg(3f), system_stat(3f), system_isdir(3f), system_perm(3f)
!!
!!##EXAMPLE
!!
!!   check if filename is a socket
!!
!!    program demo_system_issock
!!    Use M_system, only : system_issock
!!    implicit none
!!    integer                     :: i
!!    character(len=80),parameter :: names(*)=[ &
!!    '/tmp            ', &
!!    '/tmp/NOTTHERE   ', &
!!    '/usr/local      ', &
!!    '.               ', &
!!    'sock.test       ', &
!!    'PROBABLY_NOT    ']
!!    do i=1,size(names)
!!       write(*,*)' is ',trim(names(i)),' a socket? ', system_issock(names(i))
!!    enddo
!!    end program demo_system_issock
!===================================================================================================================================
function system_issock(pathname)
implicit none

character(len=*),parameter::ident_4="@(#)M_system::system_issock(3f): determine if pathname is a socket"

character(len=*),intent(in) :: pathname
logical                     :: system_issock

interface
  function c_issock(pathname) bind (C,name="my_issock") result (c_ierr)
  import c_char,c_int
  character(kind=c_char,len=1),intent(in) :: pathname(*)
  integer(kind=c_int)                     :: c_ierr
  end function c_issock
end interface

   if(c_issock(str2arr(trim(pathname))).eq.1)then
      system_issock=.true.
   else
      system_issock=.false.
   endif

end function system_issock
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!    system_isfifo(3f) - [M_system] checks if argument is a fifo - named pipe
!!
!!##SYNOPSIS
!!
!!   logical function system_isfifo(pathname)
!!
!!    character(len=*),intent(in) :: pathname
!!    logical                     :: system_isfifo
!!
!!##DESCRIPTION
!!        The isfifo(3f) function checks if path is a path to a fifo - named pipe.
!!
!!##OPTIONS
!!        path   a character string representing a fifo - named pipe pathname. Trailing spaces are ignored.
!!
!!##RETURN VALUE
!!        The system_isfifo() function should always be successful and no
!!        return value is reserved to indicate an error.
!!
!!##ERRORS
!!        No errors are defined.
!!
!!##SEE ALSO
!!    system_isreg(3f), system_stat(3f), system_isdir(3f), system_perm(3f)
!!
!!##EXAMPLE
!!
!!   check if filename is a FIFO file
!!
!!    program demo_system_isfifo
!!    Use M_system, only : system_isfifo
!!    implicit none
!!    integer                     :: i
!!    character(len=80),parameter :: names(*)=[ &
!!    '/tmp            ', &
!!    '/tmp/NOTTHERE   ', &
!!    '/usr/local      ', &
!!    '.               ', &
!!    'fifo.test       ', &
!!    'PROBABLY_NOT    ']
!!    do i=1,size(names)
!!       write(*,*)' is ',trim(names(i)),' a fifo(named pipe)? ', system_isfifo(names(i))
!!    enddo
!!    end program demo_system_isfifo
!===================================================================================================================================
function system_isfifo(pathname)
implicit none

character(len=*),parameter::ident_5="@(#)M_system::system_isfifo(3f): determine if pathname is a fifo(named pipe)"

character(len=*),intent(in) :: pathname
logical                     :: system_isfifo

interface
  function c_isfifo(pathname) bind (C,name="my_isfifo") result (c_ierr)
  import c_char,c_int
  character(kind=c_char,len=1),intent(in) :: pathname(*)
  integer(kind=c_int)                     :: c_ierr
  end function c_isfifo
end interface

   if(c_isfifo(str2arr(trim(pathname))).eq.1)then
      system_isfifo=.true.
   else
      system_isfifo=.false.
   endif

end function system_isfifo
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!    system_ischr(3f) - [M_system] checks if argument is a character device
!!
!!##SYNOPSIS
!!
!!   logical function system_ischr(pathname)
!!
!!    character(len=*),intent(in) :: pathname
!!    logical                     :: system_ischr
!!
!!##DESCRIPTION
!!        The ischr(3f) function checks if path is a path to a character device.
!!
!!##OPTIONS
!!        path   a character string representing a character device pathname. Trailing spaces are ignored.
!!
!!##RETURN VALUE
!!        The system_ischr() function should always be successful and no
!!        return value is reserved to indicate an error.
!!
!!##ERRORS
!!        No errors are defined.
!!
!!##SEE ALSO
!!    system_isreg(3f), system_stat(3f), system_isdir(3f), system_perm(3f)
!!
!!##EXAMPLE
!!
!!   check if filename is a character file
!!
!!    program demo_system_ischr
!!    Use M_system, only : system_ischr
!!    implicit none
!!    integer                     :: i
!!    character(len=80),parameter :: names(*)=[ &
!!    '/tmp            ', &
!!    '/tmp/NOTTHERE   ', &
!!    '/usr/local      ', &
!!    '.               ', &
!!    'char_dev.test   ', &
!!    'PROBABLY_NOT    ']
!!    do i=1,size(names)
!!       write(*,*)' is ',trim(names(i)),' a character device? ', system_ischr(names(i))
!!    enddo
!!    end program demo_system_ischr
!!
!!   Results:
!===================================================================================================================================
function system_ischr(pathname)
implicit none

character(len=*),parameter::ident_6="@(#)M_system::system_ischr(3f): determine if pathname is a link"

character(len=*),intent(in) :: pathname
logical                     :: system_ischr

interface
  function c_ischr(pathname) bind (C,name="my_ischr") result (c_ierr)
  import c_char,c_int
  character(kind=c_char,len=1),intent(in) :: pathname(*)
  integer(kind=c_int)                     :: c_ierr
  end function c_ischr
end interface

   if(c_ischr(str2arr(trim(pathname))).eq.1)then
      system_ischr=.true.
   else
      system_ischr=.false.
   endif

end function system_ischr
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!    system_isreg(3f) - [M_system] checks if argument is a regular file
!!
!!##SYNOPSIS
!!
!!   logical function system_isreg(pathname)
!!
!!    character(len=*),intent(in) :: pathname
!!    logical                     :: system_isreg
!!
!!##DESCRIPTION
!!        The isreg(3f) function checks if path is a regular file
!!
!!##OPTIONS
!!        path   a character string representing a pathname. Trailing spaces are ignored.
!!
!!##RETURN VALUE
!!        The system_isreg() function should always be successful and no
!!        return value is reserved to indicate an error.
!!
!!##ERRORS
!!        No errors are defined.
!!
!!##SEE ALSO
!!    system_islnk(3f), system_stat(3f), system_isdir(3f), system_perm(3f)
!!
!!##EXAMPLE
!!
!!   check if filename is a regular file
!!
!!    program demo_system_isreg
!!    Use M_system, only : system_isreg
!!    implicit none
!!    integer                     :: i
!!    character(len=80),parameter :: names(*)=[ &
!!    '/tmp            ', &
!!    'test.txt        ', &
!!    '.               ']
!!    do i=1,size(names)
!!       write(*,*)' is ',trim(names(i)),' a regular file? ', system_isreg(names(i))
!!    enddo
!!    end program demo_system_isreg
!===================================================================================================================================
function system_isreg(pathname)
implicit none

character(len=*),parameter::ident_7="@(#)M_system::system_isreg(3f): determine if pathname is a regular file"

character(len=*),intent(in) :: pathname
logical                     :: system_isreg

interface
  function c_isreg(pathname) bind (C,name="my_isreg") result (c_ierr)
  import c_char,c_int
  character(kind=c_char,len=1),intent(in) :: pathname(*)
  integer(kind=c_int)                     :: c_ierr
  end function c_isreg
end interface

   if(c_isreg(str2arr(trim(pathname))).eq.1)then
      system_isreg=.true.
   else
      system_isreg=.false.
   endif

end function system_isreg
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!    system_islnk(3f) - [M_system] checks if argument is a link
!!
!!##SYNOPSIS
!!
!!    logical function system_islnk(pathname)
!!
!!    character(len=*),intent(in) :: pathname
!!    logical                     :: system_islnk
!!
!!##DESCRIPTION
!!        The islnk(3f) function checks if path is a path to a link.
!!
!!##OPTIONS
!!        path   a character string representing a link pathname. Trailing spaces are ignored.
!!
!!##RETURN VALUE
!!        The system_islnk() function should always be successful and no
!!        return value is reserved to indicate an error.
!!
!!##ERRORS
!!        No errors are defined.
!!
!!##SEE ALSO
!!    system_isreg(3f), system_stat(3f), system_isdir(3f), system_perm(3f)
!!
!!##EXAMPLE
!!
!!
!!   Sample program:
!!
!!    program demo_system_islnk
!!    Use M_system, only : system_islnk
!!    implicit none
!!    integer                     :: i
!!    character(len=80),parameter :: names(*)=[ &
!!    '/tmp            ', &
!!    '/tmp/NOTTHERE   ', &
!!    '/usr/local      ', &
!!    '.               ', &
!!    'link.test       ', &
!!    'PROBABLY_NOT    ']
!!    do i=1,size(names)
!!       write(*,*)' is ',trim(names(i)),' a link? ', system_islnk(names(i))
!!    enddo
!!    end program demo_system_islnk
!!
!!   Results:
!===================================================================================================================================
function system_islnk(pathname)
implicit none

character(len=*),parameter::ident_8="@(#)M_system::system_islnk(3f): determine if pathname is a link"

character(len=*),intent(in) :: pathname
logical                     :: system_islnk

interface
  function c_islnk(pathname) bind (C,name="my_islnk") result (c_ierr)
  import c_char,c_int
  character(kind=c_char,len=1),intent(in) :: pathname(*)
  integer(kind=c_int)                     :: c_ierr
  end function c_islnk
end interface

   if(c_islnk(str2arr(trim(pathname))).eq.1)then
      system_islnk=.true.
   else
      system_islnk=.false.
   endif

end function system_islnk
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!! system_isblk(3f) - [M_system] checks if argument is a block device
!!
!!##SYNOPSIS
!!
!!   logical function system_isblk(pathname)
!!
!!    character(len=*),intent(in) :: pathname
!!    logical                     :: system_isblk
!!
!!##DESCRIPTION
!! The isblk(3f) function checks if path is a path to a block device.
!!
!!##OPTIONS
!! path   a character string representing a block device pathname. Trailing spaces are ignored.
!!
!!##RETURN VALUE
!!        The system_isblk() function should always be successful and no
!!        return value is reserved to indicate an error.
!!
!!##ERRORS
!!        No errors are defined.
!!
!!##SEE ALSO
!!    system_isreg(3f), system_stat(3f), system_isdir(3f), system_perm(3f)
!!
!!##EXAMPLE
!!
!!   check if filename is a block device
!!
!!    program demo_system_isblk
!!    Use M_system, only : system_isblk
!!    implicit none
!!    integer                     :: i
!!    character(len=80),parameter :: names(*)=[ &
!!    '/tmp            ', &
!!    '/tmp/NOTTHERE   ', &
!!    '/usr/local      ', &
!!    '.               ', &
!!    'block_device.tst', &
!!    'PROBABLY_NOT    ']
!!    do i=1,size(names)
!!        write(*,*)' is ',trim(names(i)),' a block device? ', system_isblk(names(i))
!!    enddo
!!    end program demo_system_isblk
!!
!!   Results:
!===================================================================================================================================
function system_isblk(pathname)
implicit none

character(len=*),parameter::ident_9="@(#)M_system::system_isblk(3f): determine if pathname is a block device"

character(len=*),intent(in) :: pathname
logical                     :: system_isblk

interface
  function c_isblk(pathname) bind (C,name="my_isblk") result (c_ierr)
  import c_char,c_int
  character(kind=c_char,len=1),intent(in) :: pathname(*)
  integer(kind=c_int)                     :: c_ierr
  end function c_isblk
end interface

   if(c_isblk(str2arr(trim(pathname))).eq.1)then
      system_isblk=.true.
   else
      system_isblk=.false.
   endif

end function system_isblk
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!    system_chown(3f) - [M_system] change file owner and group
!!
!!##SYNOPSIS
!!
!!   logical function system_chown(path,owner,group)
!!
!!    character(len=*),intent(in) :: path
!!    integer,intent(in)          :: owner
!!    integer,intent(in)          :: group
!!
!!##DESCRIPTION
!!        The chown(3f) function changes owner and group of a file
!!
!!        The path argument points to a pathname naming a file. The
!!        user ID and group ID of the named file shall be set to the numeric
!!        values contained in owner and group, respectively.
!!
!!        Only processes with an effective user ID equal to the user ID of
!!        the file or with appropriate privileges may change the ownership
!!        of a file.
!!
!!##OPTIONS
!!        path   a character string representing a file pathname.
!!               Trailing spaces are ignored.
!!        owner  UID of owner that ownership is to be changed to
!!        group  GID of group that ownership is to be changed to
!!
!!##RETURN VALUE
!!        The system_chown() function should return zero (0) if successful.
!!        Otherwise, these functions shall return    1 and set errno to
!!        indicate the error. If    1 is returned, no changes are made in
!!        the user ID and group ID of the file.
!!
!!##EXAMPLE
!!
!!
!!   Sample program:
!!
!!    program demo_system_chown
!!    Use M_system, only : system_chown
!!    Use M_system, only : system_getuid
!!    Use M_system, only : system_getgid
!!    use M_system, only : system_perror
!!    implicit none
!!    integer                     :: i
!!    character(len=80),parameter :: names(*)=[character(len=80) :: 'myfile1','/usr/local']
!!    do i=1,size(names)
!!       if(.not.  system_chown(&
!!       & trim(names(i)),  &
!!       & system_getuid(), &
!!       & system_getgid()) &
!!          )then
!!          call system_perror('*demo_system_chown* '//trim(names(i)))
!!       endif
!!    enddo
!!    end program demo_system_chown
!===================================================================================================================================

function system_chown(dirname,owner,group)
implicit none

character(len=*),parameter::ident_10="&
&@(#)M_system::system_chown(3f): change owner and group of a file relative to directory file descriptor"

character(len=*),intent(in) :: dirname
integer,intent(in)          :: owner
integer,intent(in)          :: group
logical                     :: system_chown

! int chown(const char *path, uid_t owner, gid_t group);
interface
  function c_chown(c_dirname,c_owner,c_group) bind (C,name="my_chown") result (c_ierr)
  import c_char,c_int
  character(kind=c_char,len=1),intent(in) :: c_dirname(*)
  integer(kind=c_int),intent(in),value    :: c_owner
  integer(kind=c_int),intent(in),value    :: c_group
  integer(kind=c_int)                     :: c_ierr
  end function c_chown
end interface

   if(c_chown(str2arr(trim(dirname)),int(owner,kind=c_int),int(group,kind=c_int)).eq.1)then
      system_chown=.true.
   else
      system_chown=.false.
   endif

end function system_chown
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!    system_isdir(3f) - [M_system] checks if argument is a directory path
!!
!!##SYNOPSIS
!!
!!   logical function system_isdir(pathname)
!!
!!    character(len=*),intent(in) :: pathname
!!    logical                     :: system_isdir
!!
!!##DESCRIPTION
!!        The isdir(3f) function checks if path is a path to a directory.
!!
!!##OPTIONS
!!        path   a character string representing a directory pathname. Trailing spaces are ignored.
!!
!!##RETURN VALUE
!!        The system_isdir() function should always be successful and no
!!        return value is reserved to indicate an error.
!!
!!##ERRORS
!!        No errors are defined.
!!
!!##SEE ALSO
!!    system_islnk(3f), system_stat(3f), isreg(3f), system_perm(3f)
!!
!!##EXAMPLE
!!
!!   check if filename is a directory
!!
!!      program demo_system_isdir
!!      Use M_system, only : system_isdir
!!      implicit none
!!      integer                     :: i
!!      character(len=80),parameter :: names(*)=[ &
!!      '/tmp            ', &
!!      '/tmp/NOTTHERE   ', &
!!      '/usr/local      ', &
!!      '.               ', &
!!      'PROBABLY_NOT    ']
!!      do i=1,size(names)
!!         write(*,*)' is ',trim(names(i)),' a directory? ', system_isdir(names(i))
!!      enddo
!!      end program demo_system_isdir
!!
!!   Results:
!!
!!      is /tmp a directory?  T
!!      is /tmp/NOTTHERE a directory?  F
!!      is /usr/local a directory?  T
!!      is . a directory?  T
!!      is PROBABLY_NOT a directory?  F
!===================================================================================================================================
function system_isdir(dirname)
implicit none

character(len=*),parameter::ident_11="@(#)M_system::system_isdir(3f): determine if DIRNAME is a directory name"

character(len=*),intent(in) :: dirname
logical                     :: system_isdir

interface
  function c_isdir(dirname) bind (C,name="my_isdir") result (c_ierr)
  import c_char,c_int
  character(kind=c_char,len=1),intent(in) :: dirname(*)
  integer(kind=c_int)                     :: c_ierr
  end function c_isdir
end interface

   if(c_isdir(str2arr(trim(dirname))).eq.1)then
      system_isdir=.true.
   else
      system_isdir=.false.
   endif

end function system_isdir
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!        system_cpu_time(3f) - [M_system] get processor time by calling times(3c)
!!
!!##SYNOPSIS
!!
!!        subroutine system_cpu_time(c_user, c_system, c_total)
!!
!!         real,intent(out) :: c_total
!!         real,intent(out) :: c_user
!!         real,intent(out) :: c_system
!!
!!##DESCRIPTION
!!
!!##OUTPUT
!!         c_total   total processor time ( c_user + c_system )
!!         c_user    processor user time
!!         c_system  processor system time
!!
!!##ERRORS
!!        No errors are defined.
!!
!!##EXAMPLES
!!
!!
!!   Sample program:
!!
!!    program demo_system_cpu_time
!!
!!    use M_system, only : system_cpu_time
!!    use ISO_C_BINDING, only : c_float
!!    implicit none
!!    real    :: user_start, system_start, total_start
!!    real    :: user_finish, system_finish, total_finish
!!    integer :: i
!!    real    :: value
!!
!!       call system_cpu_time(total_start,user_start,system_start)
!!
!!       value=0.0
!!       do i=1,1000000
!!          value=sqrt(real(i)+value)
!!          write(10,*)value
!!       enddo
!!       flush(10)
!!       write(*,*)'average sqrt value=',value/10000.0
!!       call system_cpu_time(total_finish,user_finish,system_finish)
!!       write(*,*)'USER ......',user_finish-user_start
!!       write(*,*)'SYSTEM ....',system_finish-system_start
!!       write(*,*)'TOTAL .....',total_finish-total_start
!!
!!    end program demo_system_cpu_time
!!
!!   Typical Results:
!===================================================================================================================================
!! GET ERRORS ABOUT MISSING LONGEST_ENV_VARIABLE IN GFORTRAN 6.4.0 IF JUST USE INTERFACE INSTEAD OF MAKING SUBROUTINE
!!character(len=*),parameter :: ident_cpu_time="@(#) M_system::system_cpu_time(3f): get processor time using times(3c)"
!!interface
!!   subroutine system_cpu_time(c_total,c_user,c_system) bind (C,NAME='my_cpu_time')
!!      import c_float
!!      real(kind=c_float) :: c_user,c_system,c_total
!!   end subroutine system_cpu_time
!!end interface
subroutine system_cpu_time(total,user,system)

character(len=*),parameter :: ident_cpu_time="@(#) M_system::system_cpu_time(3f): get processor time using times(3c)"

real,intent(out)   :: user,system,total
real(kind=c_float) :: c_user,c_system,c_total

interface
   subroutine c_cpu_time(c_total,c_user,c_system) bind (C,NAME='my_cpu_time')
      import c_float
      real(kind=c_float) :: c_total,c_user,c_system
   end subroutine c_cpu_time
end interface

call c_cpu_time(c_total,c_user,c_system)
user=c_user
system=c_system
total=c_total
end subroutine system_cpu_time
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!        system_link(3f) - [M_system] link one file to another file relative to two directory file descriptors
!!
!!##SYNOPSIS
!!
!!    integer function link(oldpath,newpath);
!!
!!     character(len=*),intent(in) :: oldpath
!!     character(len=*),intent(in) :: newpath
!!
!!##DESCRIPTION
!!        The link() function shall create a new link (directory entry) for the existing file, path1.
!!
!!        The path1 argument points to a pathname naming an existing file. The path2 argument points to a pathname naming the new
!!        directory entry to be created. The link() function shall atomically create a new link for the existing file and the link
!!        count of the file shall be incremented by one.
!!
!!        If path1 names a directory, link() shall fail unless the process has appropriate privileges and the implementation
!!        supports
!!        using link() on directories.
!!
!!        If path1 names a symbolic link, it is implementation-defined whether link() follows the symbolic link, or creates a new
!!        link to the symbolic link itself.
!!
!!        Upon successful completion, link() shall mark for update the last file status change timestamp of the file. Also, the
!!        last data modification and last file status change timestamps of the directory that contains the new entry shall be
!!        marked for update.
!!
!!        If link() fails, no link shall be created and the link count of the file shall remain unchanged.
!!
!!        The implementation may require that the calling process has permission to access the existing file.
!!
!!        The linkat() function shall be equivalent to the link() function except that symbolic links shall be handled as specified
!!        by the value of flag (see below) and except in the case where either path1 or path2 or both are relative paths. In this
!!        case a relative path path1 is interpreted relative to the directory associated with the file descriptor fd1 instead of
!!        the current working directory and similarly for path2 and the file descriptor fd2. If the file descriptor was opened
!!        without O_SEARCH, the function shall check whether directory searches are permitted using the current permissions of the
!!        directory underlying the file descriptor. If the file descriptor was opened with O_SEARCH, the function shall not perform
!!        the check.
!!
!!        Values for flag are constructed by a bitwise-inclusive OR of flags from the following list, defined in <fcntl.h>:
!!
!!        AT_SYMLINK_FOLLOW
!!              If path1 names a symbolic link, a new link for the target of the symbolic link is created.
!!
!!        If linkat() is passed the special value AT_FDCWD in the fd1 or fd2 parameter, the current working directory shall be used
!!        for the respective path argument. If both fd1 and fd2 have value AT_FDCWD, the behavior shall be identical to a call to
!!        link(), except that symbolic links shall be handled as specified by the value of flag.
!!
!!        Some implementations do allow links between file systems.
!!
!!        If path1 refers to a symbolic link, application developers should use linkat() with appropriate flags to select whether
!!        or not the symbolic link should be resolved.
!!
!!        If the AT_SYMLINK_FOLLOW flag is clear in the flag argument and the path1 argument names a symbolic link, a new link is
!!        created for the symbolic link path1 and not its target.
!!
!!##RETURN VALUE
!!        Upon successful completion, these functions shall return 0. Otherwise, these functions shall return -1 and set errno to
!!        indicate the error.
!!
!!##EXAMPLES
!!
!!   Creating a Link to a File
!!
!!    program demo_system_link
!!    use M_system, only : system_link, system_perror
!!    ierr = system_link('myfile1','myfile2')
!!    if(ierr.ne.0)then
!!       call system_perror('*demo_system_link*')
!!    endif
!!    end program demo_system_link
!===================================================================================================================================
function system_link(oldname,newname) result(ierr)

character(len=*),parameter::ident_12="@(#)M_system::system_link(3f): call link(3c) to create a file link"

character(len=*),intent(in) :: oldname
character(len=*),intent(in) :: newname
integer                     :: ierr
integer(kind=c_int)         :: c_ierr

interface
  function c_link(c_oldname,c_newname) bind (C,name="link") result (c_ierr)
  import c_char,c_int
  character(kind=c_char,len=1),intent(in) :: c_oldname(*)
  character(kind=c_char,len=1),intent(in) :: c_newname(*)
  integer(kind=c_int)                     :: c_ierr
  end function c_link
end interface

   c_ierr=c_link(str2arr(trim(oldname)),str2arr(trim(newname)))
   ierr=c_ierr

end function system_link
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!        system_unlink(3f) - [M_system] remove a directory entry relative to directory file descriptor
!!
!!##SYNOPSIS
!!
!!    integer function unlink(path);
!!
!!     character(len=*) :: path
!!
!!##DESCRIPTION
!!    The unlink() function shall remove a link to a file. If path names a
!!    symbolic link, unlink() shall remove the symbolic link named by path
!!    and shall not affect any file or directory named by the contents of
!!    the symbolic link. Otherwise, unlink() shall remove the link named by
!!    the pathname pointed to by path and shall decrement the link count of
!!    the file referenced by the link.
!!
!!    When the file's link count becomes 0 and no process has the file open,
!!    the space occupied by the file shall be freed and the file shall no
!!    longer be accessible. If one or more processes have the file open when
!!    the last link is removed, the link shall be removed before unlink()
!!    returns, but the removal of the file contents shall be postponed until
!!    all references to the file are closed.
!!
!!    The path argument shall not name a directory unless the process has
!!    appropriate privileges and the implementation supports using unlink()
!!    on directories.
!!
!!    Upon successful completion, unlink() shall mark for update the last
!!    data modification and last file status change timestamps of the parent
!!    directory. Also, if the file's link count is not 0, the last file status
!!    change timestamp of the file shall be marked for update.
!!
!!    Values for flag are constructed by a bitwise-inclusive OR of flags from
!!    the following list, defined in <fcntl.h>:
!!
!!       AT_REMOVEDIR
!!
!!     Remove the directory entry specified by fd and path as a
!!     directory, not a normal file.
!!
!!##RETURN VALUE
!!
!!    Upon successful completion, these functions shall return 0. Otherwise,
!!    these functions shall return -1 and set errno to indicate the error. If
!!    -1 is returned, the named file shall not be changed.
!!
!!##EXAMPLES
!!
!!   Removing a link to a file
!!
!!    program demo_system_unlink
!!    use M_system, only : system_unlink, system_perror
!!    ierr = system_unlink('myfile1')
!!    if(ierr.ne.0)then
!!       call system_perror('*demo_system_unlink*')
!!    endif
!!    end program demo_system_unlink
!===================================================================================================================================
function system_unlink(fname) result (ierr)

character(len=*),parameter::ident_13="@(#)M_system::system_unlink(3f): call unlink(3c) to rm file link"

character(len=*),intent(in) :: fname
integer                     :: ierr

interface
  function c_unlink(c_fname) bind (C,name="unlink") result (c_ierr)
  import c_char, c_int
  character(kind=c_char,len=1) :: c_fname(*)
  integer(kind=c_int)          :: c_ierr
  end function c_unlink
end interface
   ierr=c_unlink(str2arr(trim(fname)))
end function system_unlink
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!    system_setumask(3f) - [M_system] set the file mode creation umask
!!##SYNOPSIS
!!
!!    integer function system_setumask(new_umask) result (old_umask)
!!
!!     integer,intent(in)  :: new_umask
!!     integer(kind=c_int) :: umask_c
!!
!!##DESCRIPTION
!!        The system_umask(3f) function sets the file mode creation mask of the
!!        process to cmask and return the previous value of the mask. Only
!!        the file permission bits of cmask (see <sys/stat.h>) are used;
!!        the meaning of the other bits is implementation-defined.
!!
!!        The file mode creation mask of the process is used to turn off
!!        permission bits in the mode argument supplied during calls to
!!        the following functions:
!!
!!         *  open(), openat(), creat(), mkdir(), mkdirat(), mkfifo(), and mkfifoat()
!!         *  mknod(), mknodat()
!!         *  mq_open()
!!         *  sem_open()
!!
!!        Bit positions that are set in cmask are cleared in the mode of
!!        the created file.
!!
!!##RETURN VALUE
!!        The file permission bits in the value returned by umask() shall be
!!        the previous value of the file mode creation mask. The state of any
!!        other bits in that value is unspecified, except that a subsequent
!!        call to umask() with the returned value as cmask shall leave the
!!        state of the mask the same as its state before the first call,
!!        including any unspecified use of those bits.
!!
!!##ERRORS
!!        No errors are defined.
!!
!!##EXAMPLE
!!
!!   Sample program
!!
!!    program demo_setumask
!!    use M_system, only : system_getumask, system_setumask
!!    integer :: newmask
!!    write(*,101)(system_getumask(),i=1,4)
!!    101 format(1x,i0,1x,"O'",o4.4,"'",1x,'Z"',z0,"'",1x,"B'",b12.12,"'")
!!    newmask=63
!!    old_umask=system_setumask(newmask)
!!    write(*,*)'NEW'
!!    write(*,101)(system_getumask(),i=1,4)
!!    end program demo_setumask
!!
!!   Expected output
!!
!!     18 O'022' Z"12' B'000010010"
!!     NEW
!!     63 O'077' Z"3F' B'000111111"
!===================================================================================================================================
integer function system_setumask(umask_value) result (old_umask)
integer,intent(in)  :: umask_value
integer(kind=c_int) :: umask_c

   umask_c=umask_value
   old_umask=system_umask(umask_c) ! set current umask

end function system_setumask
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!    system_getumask(3f) - [M_system] get current umask
!!##SYNOPSIS
!!
!!   integer function system_getumask() result (umask_value)
!!##DESCRIPTION
!!   The return value from getumask(3f) is the value of the file
!!   creation mask, obtained by using umask(3c).
!!##EXAMPLE
!!
!!   Sample program
!!
!!    program demo_getumask
!!    use M_system, only : system_getumask, system_setumask
!!    integer :: newmask
!!    write(*,101)(system_getumask(),i=1,4)
!!    101 format(1x,i0,1x,"O'",o4.4,"'",1x,'Z"',z0,"'",1x,"B'",b12.12,"'")
!!    end program demo_getumask
!!
!!   Expected output
!!
!!     18 O'022' Z"12' B'000010010"
!===================================================================================================================================
integer function system_getumask() result (umask_value)
! The return value from umask() is just the previous value of the file
! creation mask, so that this system call can be used both to get and
! set the required values. Sadly, however, there is no way to get the old
! umask value without setting a new value at the same time.

! This means that in order just to see the current value, it is necessary
! to execute a piece of code like the following function:
integer             :: idum
integer(kind=c_int) :: old_umask
   old_umask=system_umask(0_c_int) ! get current umask but by setting umask to 0 (a conservative mask so no vulnerability is open)
   idum=system_umask(old_umask)      ! set back to original mask
   umask_value=old_umask
end function system_getumask
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!      perror(3f) - [M_system] print error message for last C error on stderr
!!##SYNOPSIS
!!
!!      subroutine system_perror(prefix)
!!
!!       character(len=*),intent(in) :: prefix
!!
!!##DESCRIPTION
!!    Use system_perror(3f) to print an error message on stderr
!!    corresponding to the current value of the C global variable errno.
!!    Unless you use NULL as the argument prefix, the error message will
!!    begin with the prefix string, followed by a colon and a space
!!    (:). The remainder of the error message produced is one of the
!!    strings described for strerror(3c).
!!
!!##EXAMPLE
!!
!!   Sample program:
!!
!!    program demo_system_perror
!!    use M_system, only : system_perror,system_rmdir
!!    implicit none
!!    character(len=:),allocatable :: DIRNAME
!!    DIRNAME='/NOT/THERE/OR/ANYWHERE'
!!    ! generate an error with a routine that supports errno and perror(3c)
!!    if(system_rmdir(DIRNAME).ne.0)then
!!       call system_perror('*demo_system_perror*:'//DIRNAME)
!!    endif
!!    write(*,'(a)')"That's all Folks!"
!!    end program demo_system_perror
!!
!!   Expected results:
!!
!!    *demo_system_perror*:/NOT/THERE/OR/ANYWHERE: No such file or directory
!!    That's all Folks!
!===================================================================================================================================
subroutine system_perror(prefix)
use iso_fortran_env, only : ERROR_UNIT, INPUT_UNIT, OUTPUT_UNIT     ! access computing environment

character(len=*),parameter::ident_14="@(#)M_system::system_perror(3f): call perror(3c) to display error message"

character(len=*),intent(in) :: prefix
   integer                  :: ios

interface
  subroutine c_perror(c_prefix) bind (C,name="perror")
  import c_char
  character(kind=c_char) :: c_prefix(*)
  end subroutine c_perror
end interface

   flush(unit=ERROR_UNIT,iostat=ios)
   flush(unit=OUTPUT_UNIT,iostat=ios)
   flush(unit=INPUT_UNIT,iostat=ios)
   call c_perror(str2arr((trim(prefix))))
   call c_flush()

end subroutine system_perror
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!    system_chdir(3f) - [M_system] call chdir(3c) from Fortran to change working directory
!!##SYNOPSIS
!!
!!    subroutine system_chdir(path, err)
!!
!!     character(len=*)               :: path
!!     integer, optional, intent(out) :: err
!!
!!##DESCRIPTION
!!
!!    system_chdir(3f) changes the current working directory of the calling
!!    process to the directory specified in path. The current working
!!    directory is the starting point for interpreting relative pathnames
!!    (those not starting with '/').
!!
!!##RETURN VALUE
!!
!!    On success, zero is returned. On error, -1 is returned, and errno is
!!    set appropriately.
!!
!!
!!    Depending on the file system, other errors can be returned. The more
!!    general errors for chdir() are listed below, by their C definitions:
!!
!!    Errors
!!    EACCES        Search permission is denied for one of the components of path.
!!                  (See also path_resolution(7).)
!!    EFAULT        path points outside your accessible address space.
!!    EIO           An I/O error occurred.
!!    ELOOP         Too many symbolic links were encountered in resolving path.
!!    ENAMETOOLONG  path is too long.
!!    ENOENT        The file does not exist.
!!    ENOMEM        Insufficient kernel memory was available.
!!    ENOTDIR       A component of path is not a directory.
!!
!!##SEE ALSO
!!
!!    chroot(2), getcwd(3), path_resolution(7)
!!
!!##EXAMPLE
!!
!!    Change working directory from Fortran
!!
!!      program demo_system_chdir
!!      use M_system, only : system_chdir
!!      implicit none
!!      integer :: ierr
!!
!!      call execute_command_line('pwd')
!!      call system_chdir('/tmp',ierr)
!!      call execute_command_line('pwd')
!!      write(*,*)'*CHDIR TEST* IERR=',ierr
!!
!!      end program demo_system_chdir
!!
!!##RESULTS:
!!   Sample run output:
!!
!!      /home/urbanjs/V600
!!      /tmp
!!      *CHDIR TEST* IERR=           0
!===================================================================================================================================
subroutine system_chdir(path, err)

character(len=*),parameter::ident_15="@(#)M_system::system_chdir(3f): call chdir(3c)"

character(len=*)               :: path
integer, optional, intent(out) :: err

interface
   integer(kind=c_int)  function c_chdir(c_path) bind(C,name="chdir")
      import c_char, c_int
      character(kind=c_char)   :: c_path(*)
   end function
end interface
   integer                     :: loc_err
!-----------------------------------------------------------------------------------------------------------------------------------
   loc_err=c_chdir(str2arr(trim(path)))
   if(present(err))then
      err=loc_err
   endif
end subroutine system_chdir
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!      system_remove(3f) - [M_system] call remove(3c) to remove file
!!##SYNOPSIS
!!
!!   function system_remove(path) result(err)
!!
!!    character(*),intent(in) :: path
!!    integer(c_int)          :: err
!!
!!##DESCRIPTION
!!    Fortran supports scratch files via the OPEN(3c) command; but does
!!    not otherwise allow for removing files. The system_remove(3f) command
!!    allows for removing files by name that the user has the authority to
!!    remove by calling the C remove(3c) function.
!!
!!##EXAMPLE
!!
!!   Sample program:
!!
!!    program demo_system_remove
!!    use M_system, only : system_remove
!!    character(len=*),parameter :: FILE='MyJunkFile.txt'
!!    write(*,*)'BEFORE CREATED '//FILE
!!    call execute_command_line('ls -l '//FILE)
!!    write(*,*)
!!
!!    ! note intentionally causes error if file exists
!!    open(unit=10,file=FILE,status='NEW')
!!    write(*,*)'AFTER OPENED '//FILE
!!    call execute_command_line('ls -l '//FILE)
!!    write(*,*)
!!
!!    write(10,'(a)') 'This is a file I want to delete'
!!    close(unit=10)
!!    write(*,*)'AFTER CLOSED '
!!    call execute_command_line('ls -l '//FILE)
!!    write(*,*)
!!
!!    ierr=system_remove(FILE)
!!    write(*,*)'AFTER REMOVED',IERR
!!    call execute_command_line('ls -l '//FILE)
!!    write(*,*)
!!
!!    end program demo_system_remove
!!
!!   Expected Results:
!!
!!    >  BEFORE CREATED MyJunkFile.txt
!!    > ls: cannot access 'MyJunkFile.txt': No such file or directory
!!    >
!!    >  AFTER OPENED MyJunkFile.txt
!!    > -rw-r--r-- 1 JSU None 0 Nov 19 19:32 MyJunkFile.txt
!!    >
!!    >  AFTER CLOSED
!!    > -rw-r--r-- 1 JSU None 32 Nov 19 19:32 MyJunkFile.txt
!!    >
!!    >  AFTER REMOVED           0
!!    > ls: cannot access 'MyJunkFile.txt': No such file or directory
!!
!===================================================================================================================================
function system_remove(path) result(err)

character(len=*),parameter::ident_16="@(#)M_system::system_remove(3f): call remove(3c) to remove file"

character(*),intent(in) :: path
integer(c_int)          :: err

interface
   function c_remove(c_path) bind(c,name="remove") result(c_err)
      import c_char,c_int
      character(kind=c_char,len=1),intent(in) :: c_path(*)
      integer(c_int)                          :: c_err
   end function
end interface
!-----------------------------------------------------------------------------------------------------------------------------------
   err= c_remove(str2arr(trim(path)))
end function system_remove
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!      system_rename(3f) - [M_system] call rename(3c) to rename a system file
!!##SYNOPSIS
!!
!!   function system_rename(input,output) result(ierr)
!!
!!    character(*),intent(in)    :: input,output
!!    integer                    :: ierr
!!##DESCRIPTION
!!     Rename a file by calling rename(3c). It is not recommended that the
!!     rename occur while either filename is being used on a file currently
!!     OPEN(3f) by the program.
!!##OPTIONS
!!     INPUT   system filename of an existing file to rename
!!     OUTPUT  system filename to be created or overwritten by INPUT file
!!##RETURNS
!!     IERR    zero (0) if no error occurs. If not zero a call to
!!             system_errno(3f) or system_perror(3f) is supported
!!             to diagnose error
!!##EXAMPLE
!!
!!    Sample program:
!!
!!      program demo_system_rename
!!      use M_system, only : system_rename
!!      use M_system, only : system_remove
!!      use M_system, only : system_perror
!!      implicit none
!!      character(len=256) :: string
!!      integer            :: ios, ierr
!!
!!      ! try to remove junk files just in case
!!      ierr=system_remove('_scratch_file_')
!!      write(*,'(a,i0)') 'should not be zero ',ierr
!!      call system_perror('*demo_system_rename*')
!!      ierr=system_remove('_renamed_scratch_file_')
!!      write(*,'(a,i0)') 'should not be zero ',ierr
!!      call system_perror('*demo_system_rename*')
!!
!!      ! create scratch file to rename
!!      open(unit=10,file='_scratch_file_',status='new')
!!      write(10,'(a)') 'Test by renaming "_scratch_file_" to "_renamed_scratch_file_"'
!!      write(10,'(a)') 'IF YOU SEE THIS ON OUTPUT THE RENAME WORKED'
!!      close(10)
!!      ! rename scratch file
!!      ierr=system_rename('_scratch_file_','_renamed_scratch_file_')
!!      if(ierr.ne.0)then
!!         write(*,*)'ERROR RENAMING FILE ',ierr
!!      endif
!!      ! read renamed file
!!      open(unit=11,file='_renamed_scratch_file_',status='old')
!!      INFINITE: do
!!         read(11,'(a)',iostat=ios)string
!!         if(ios.ne.0)exit INFINITE
!!         write(*,'(a)')trim(string)
!!      enddo INFINITE
!!      close(unit=11)
!!
!!      ! clean up
!!      ierr=system_remove('_scratch_file_')
!!      write(*,'(a,i0)') 'should not be zero ',ierr
!!      ierr=system_remove('_renamed_scratch_file_')
!!      write(*,'(a,i0)') 'should be zero ',ierr
!!
!!      end program demo_system_rename
!!
!!   Expected output:
!!
!!    > should not be zero -1
!!    > *demo_system_rename*: No such file or directory
!!    > should not be zero -1
!!    > *demo_system_rename*: No such file or directory
!!    > Test by renaming "_scratch_file_" to "_renamed_scratch_file_"
!!    > IF YOU SEE THIS ON OUTPUT THE RENAME WORKED
!!    > should not be zero -1
!!    > should be zero 0
!===================================================================================================================================
function system_rename(input,output) result(ierr)

character(len=*),parameter::ident_17="@(#)M_system::system_rename(3f): call rename(3c) to change filename"

character(*),intent(in)    :: input,output
integer                    :: ierr
interface
   function c_rename(c_input,c_output) bind(c,name="rename") result(c_err)
      import c_char, c_int
      character(kind=c_char),intent(in) :: c_input(*)
      character(kind=c_char),intent(in) :: c_output(*)
      integer(c_int)                    :: c_err
   end function
end interface
!-----------------------------------------------------------------------------------------------------------------------------------
   ierr= c_rename(str2arr(trim(input)),str2arr(trim(output)))
end function system_rename
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!       system_chmod(3f) - [M_system] call chmod(3c) to change permission mode of a file relative to directory file descriptor
!!##SYNOPSIS
!!
!!    function system_chmod(filename,mode) result(ierr)
!!
!!       character(len=*),intent(in)  :: filename
!!       integer,value,intent(in)     :: mode
!!       integer                      :: ierr
!!
!!##DESCRIPTION
!!        The system_chmod(3f) function shall change UID, _ISGID, S_ISVTX, and the
!!        file permission bits of the file named by the pathname pointed
!!        to by the path argument to the corresponding bits in the mode
!!        argument. The application shall ensure that the effective user
!!        ID of the process matches the owner of the file or the process
!!        has appropriate privileges in order to do this.
!!
!!        S_ISUID, S_ISGID, S_ISVTX, and the file permission bits are
!!        described in <sys/stat.h>.
!!
!!        If the calling process does not have appropriate privileges,
!!        and if the group ID of the file does not match the effective
!!        group ID or one of the supplementary group IDs and if the file
!!        is a regular file, bit S_ISGID (set-group-ID on execution) in the
!!        file's mode shall be cleared upon successful return from chmod().
!!
!!        Additional implementation-defined restrictions may cause the
!!        S_ISUID and S_ISGID bits in mode to be ignored.
!!
!!        Upon successful completion, system_chmod() marks for update the
!!        last file status change timestamp of the file.
!!
!!        Values for flag are constructed by a bitwise-inclusive OR of
!!        flags from the following list, defined in <fcntl.h>:
!!
!!        AT_SYMLINK_NOFOLLOW
!!              If path names a symbolic link, then the mode of the symbolic
!!              link is changed.
!!
!!
!!##RETURN VALUE
!!        Upon successful completion, system_chmod(3f) returns 0.
!!        Otherwise, it returns -1 and sets errno to indicate the error. If
!!        -1 is returned, no change to the file mode occurs.
!!
!!##EXAMPLES
!!
!!   Sample program:
!!
!!    program demo_system_chmod
!!    use M_system, only : system_chmod
!!    use M_system, only : system_stat
!!    use M_system, only : R_GRP,R_OTH,R_USR,R_WXG,R_WXO
!!    use M_system, only : R_WXU,W_GRP,W_OTH,W_USR,X_GRP,X_OTH,X_USR
!!    use M_system, only : DEFFILEMODE, ACCESSPERMS
!!    implicit none
!!    integer         :: ierr
!!    integer         :: status
!!    integer(kind=8) :: buffer(13)
!!       !Setting Read Permissions for User, Group, and Others
!!       ! The following example sets read permissions for the owner, group, and others.
!!       open(file='_test1',unit=10)
!!       write(10,*)'TEST FILE 1'
!!       close(unit=10)
!!       ierr=system_chmod('_test1', IANY([R_USR,R_GRP,R_OTH]))
!!
!!       !Setting Read, Write, and Execute Permissions for the Owner Only
!!       ! The following example sets read, write, and execute permissions for the owner, and no permissions for group and others.
!!       open(file='_test2',unit=10)
!!       write(10,*)'TEST FILE 2'
!!       close(unit=10)
!!       ierr=system_chmod('_test2', R_WXU)
!!
!!       !Setting Different Permissions for Owner, Group, and Other
!!       ! The following example sets owner permissions for CHANGEFILE to read, write, and execute, group permissions to read and
!!       ! execute, and other permissions to read.
!!       open(file='_test3',unit=10)
!!       write(10,*)'TEST FILE 3'
!!       close(unit=10)
!!       ierr=system_chmod('_test3', IANY([R_WXU,R_GRP,X_GRP,R_OTH]));
!!
!!       !Setting and Checking File Permissions
!!       ! The following example sets the file permission bits for a file named /home/cnd/mod1, then calls the stat() function to
!!       ! verify the permissions.
!!
!!       ierr=system_chmod("home/cnd/mod1", IANY([R_WXU,R_WXG,R_OTH,W_OTH]))
!!       call system_stat("home/cnd/mod1", buffer,status)
!!
!!       ! In order to ensure that the S_ISUID and S_ISGID bits are set, an application requiring this should use stat() after a
!!       ! successful chmod() to verify this.
!!
!!       !    Any files currently open could possibly become invalid if the mode
!!       !    of the file is changed to a value which would deny access to
!!       !    that process.
!!
!!    end program demo_system_chmod
!!
!===================================================================================================================================
function system_chmod(filename,mode) result(ierr)
   character(len=*),intent(in)  :: filename
   integer,value,intent(in)     :: mode
   integer                      :: ierr
   interface
      function c_chmod(c_filename,c_mode) bind(c,name="chmod") result(c_err)
         import c_char,c_int
         character(kind=c_char),intent(in) :: c_filename(*)
         integer(c_int),value,intent(in)   :: c_mode
         integer(c_int)                    :: c_err
      end function
   end interface
!-----------------------------------------------------------------------------------------------------------------------------------
   ierr=c_chmod(str2arr(trim(filename)),int(mode,kind(0_c_int)))
end function system_chmod
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!       system_getcwd(3f) - [M_system] call getcwd(3c) to get the pathname of the current working directory
!!##SYNOPSIS
!!
!!       subroutine system_getcwd(output,ierr)
!!
!!        character(len=:),allocatable,intent(out) :: output
!!        integer,intent(out)                      :: ierr
!!##DESCRIPTION
!!        system_getcwd(3f) calls the C routine getcwd(3c) to obtain the absolute pathname of the current working directory.
!!
!!##RETURN VALUE
!!        OUTPUT   The absolute pathname of the current working directory
!!                 The pathname shall contain no components that are dot or dot-dot,
!!                 or are symbolic links.
!!        IERR     is not zero if an error occurs.
!!
!!##EXAMPLE
!!
!!   Sample program:
!!
!!      program demo_system_getcwd
!!      use M_system, only : system_getcwd
!!      implicit none
!!      character(len=:),allocatable :: dirname
!!      integer                      :: ierr
!!      call system_getcwd(dirname,ierr)
!!      if(ierr.eq.0)then
!!         write(*,*)'CURRENT DIRECTORY ',trim(dirname)
!!      else
!!         write(*,*)'ERROR OBTAINING CURRENT DIRECTORY NAME'
!!      endif
!!      end program demo_system_getcwd
!===================================================================================================================================
subroutine system_getcwd(output,ierr)

character(len=*),parameter::ident_18="@(#)M_system::system_getcwd(3f):call getcwd(3c) to get pathname of current working directory"

character(len=:),allocatable,intent(out) :: output
integer,intent(out)                      :: ierr
integer(kind=c_long),parameter           :: length=4097_c_long
character(kind=c_char,len=1)             :: buffer(length)
type(c_ptr)                              :: buffer2
interface
   function c_getcwd(buffer,size) bind(c,name="getcwd") result(buffer_result)
      import c_char, c_size_t, c_ptr
      character(kind=c_char) ,intent(out) :: buffer(*)
      integer(c_size_t),value,intent(in)  :: size
      type(c_ptr)                         :: buffer_result
   end function
end interface
!-----------------------------------------------------------------------------------------------------------------------------------
   buffer=' '
   buffer2=c_getcwd(buffer,length)
   if(.not.c_associated(buffer2))then
      output=''
      ierr=-1
   else
      output=trim(arr2str(buffer))
      ierr=0
   endif
end subroutine system_getcwd
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!       system_rmdir(3f) - [M_system] call rmdir(3c) to remove empty directories
!!
!!##SYNOPSIS
!!
!!    function system_rmdir(dirname) result(err)
!!
!!     character(*),intent(in) :: dirname
!!     integer(c_int) :: err
!!
!!##DESCRIPTION
!!        DIRECTORY  The name of a directory to remove if it is empty
!!        err        zero (0) if no error occurred
!!
!!##EXAMPLE
!!
!!   Sample program:
!!
!!    program demo_system_rmdir
!!    use M_system, only : system_perror
!!    use M_system, only : system_rmdir, system_mkdir
!!    implicit none
!!    integer :: ierr
!!    write(*,*)'BEFORE TRY TO CREATE _scratch/'
!!    call execute_command_line('ls -ld _scratch')
!!
!!    write(*,*)'TRY TO CREATE _scratch/'
!!    ierr=system_mkdir('_scratch',0+8*0+7)
!!    write(*,*)'IERR=',ierr
!!    call execute_command_line('ls -ld _scratch')
!!
!!    write(*,*)'TRY TO REMOVE _scratch/'
!!    ierr=system_rmdir('_scratch')
!!    write(*,*)'IERR=',ierr
!!    call execute_command_line('ls -ld _scratch')
!!
!!    write(*,*)'TRY TO REMOVE _scratch when it should be gone/'
!!    ierr=system_rmdir('_scratch')
!!    call system_perror('*test of system_rmdir*')
!!    write(*,*)'IERR=',ierr
!!    call execute_command_line('ls -ld _scratch')
!!
!!    end program demo_system_rmdir
!!
!!   Expected output:
!===================================================================================================================================
function system_rmdir(dirname) result(err)

character(len=*),parameter::ident_19="@(#)M_system::system_rmdir(3f): call rmdir(3c) to remove empty directory"

character(*),intent(in) :: dirname
integer(c_int) :: err

interface
   function c_rmdir(c_path) bind(c,name="rmdir") result(c_err)
      import c_char,c_int
      character(kind=c_char,len=1),intent(in) :: c_path(*)
      integer(c_int)                          :: c_err
   end function
end interface
!-----------------------------------------------------------------------------------------------------------------------------------
   err= c_rmdir(str2arr(trim(dirname)))
   if(err.ne.0) err=system_errno()
end function system_rmdir
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!        system_mkfifo(3f)  - [M_system] make a FIFO special file relative to directory file descriptor
!!##SYNOPSIS
!!
!!   function system_mkfifo(pathname,mode) result(ierr)
!!
!!    character(len=*),intent(in)       :: pathname
!!    integer,intent(in)                :: mode
!!    integer :: ierr
!!
!!##DESCRIPTION
!!    The mkfifo() function creates a new FIFO special file named by the
!!    pathname.
!!
!!    The file permission bits of the new FIFO are initialized from mode.
!!
!!    The file permission bits of the mode argument are modified by the
!!    process' file creation mask.
!!
!!    When bits in mode other than the file permission bits are set, the
!!    effect is implementation-defined.
!!
!!    If path names a symbolic link, mkfifo() shall fail and set errno to
!!    [EEXIST].
!!
!!    The FIFO's user ID will be set to the process' effective user ID.
!!
!!    The FIFO's group ID shall be set to the group ID of the parent
!!    directory or to the effective group ID of the process.
!!
!!    Implementations shall provide a way to initialize the FIFO's group
!!    ID to the group ID of the parent directory.
!!
!!    Implementations may, but need not, provide an implementation-defined
!!    way to initialize the FIFO's group ID to the effective group ID of
!!    the calling process.
!!
!!    Upon successful completion, mkfifo() shall mark for update the
!!    last data access, last data modification, and last file status change
!!    timestamps of the file.
!!
!!    Also, the last data modification and last file status change
!!    timestamps of the directory that contains the new entry shall be
!!    marked for update.
!!
!!    Predefined variables are typically used to set permission modes.
!!
!!    You can bytewise-OR together these variables to to create the most
!!    common permissions mode:
!!
!!     User:    R_USR  (read),  W_USR  (write),  X_USR(execute)
!!     Group:   R_GRP  (read),  W_GRP  (write),  X_GRP(execute)
!!     Others:  R_OTH  (read),  W_OTH  (write),  X_OTH(execute)
!!
!!    Additionally, some shortcuts are provided (basically a bitwise-OR
!!    combination of the above):
!!
!!      Read + Write + Execute: R_WXU (User), R_WXG (Group), R_WXO (Others)
!!      DEFFILEMODE: Equivalent of 0666 =rw-rw-rw-
!!      ACCESSPERMS: Equivalent of 0777 = rwxrwxrwx
!!
!!    Therefore, to give only the user rwx (read+write+execute) rights whereas
!!    group members and others may not do anything, you can use any of the
!!    following mkfifo() calls equivalently:
!!
!!      ierr= mkfifo("myfile", IANY([R_USR, W_USR, X_USR]));
!!      ierr= mkfifo("myfile", R_WXU);
!!
!!    In order to give anyone any rights (mode 0777 = rwxrwxrwx), you can
!!    use any of the following calls equivalently:
!!
!!      ierr= mkfifo("myfile",IANY([R_USR,W_USR,X_USR,R_GRP,W_GRP,X_GRP,R_OTH,W_OTH,X_OTH]));
!!      ierr= mkfifo("myfile",IANY([R_WXU,R_WXG,R_WXO]));
!!      ierr= mkfifo("myfile",ACCESSPERMS);
!!##RETURN VALUE
!!    Upon successful completion, return 0.
!!    Otherwise, return -1 and set errno to indicate the error.
!!    If -1 is returned, no FIFO is created.
!!
!!##EXAMPLES
!!
!!   The following example shows how to create a FIFO file named
!!   /home/cnd/mod_done, with read/write permissions for owner, and
!!   with read permissions for group and others.
!!
!!    program demo_system_mkfifo
!!    use M_system, only : system_mkfifo, system_perror
!!    use M_system, only : R_GRP,R_OTH,R_USR,R_WXG,R_WXO
!!    use M_system, only : R_WXU,W_GRP,W_OTH,W_USR,X_GRP,X_OTH,X_USR
!!    use M_system, only : DEFFILEMODE, ACCESSPERMS
!!    implicit none
!!       integer :: status
!!       status = system_mkfifo("/home/cnd/mod_done", IANY([W_USR, R_USR, R_GRP, R_OTH]))
!!       if(status.ne.0)then
!!          call system_perror('*mkfifo* error:')
!!       endif
!!    end program demo_system_mkfifo
!===================================================================================================================================
function system_mkfifo(pathname,mode) result(err)

character(len=*),parameter::ident_20="@(#)M_system::system_mkfifo(3f): call mkfifo(3c) to create a new FIFO special file"

character(len=*),intent(in)       :: pathname
integer,intent(in)                :: mode
   integer                        :: c_mode
   integer                        :: err

interface
   function c_mkfifo(c_path,c_mode) bind(c,name="mkfifo") result(c_err)
      import c_char, c_int
      character(len=1,kind=c_char),intent(in) :: c_path(*)
      integer(c_int),intent(in),value         :: c_mode
      integer(c_int)                          :: c_err
   end function c_mkfifo
end interface
!-----------------------------------------------------------------------------------------------------------------------------------
   c_mode=mode
   err= c_mkfifo(str2arr(trim(pathname)),c_mode)
end function system_mkfifo
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!        system_mkdir(3f) - [M_system] call mkdir(3c) to create a new directory
!!##SYNOPSIS
!!
!!##DESCRIPTION
!!
!!    Predefined variables are typically used to set permission modes.
!!    You can bytewise-OR together these variables to to create the most common
!!    permissions mode:
!!
!!     User:    R_USR  (read),  W_USR  (write),  X_USR(execute)
!!     Group:   R_GRP  (read),  W_GRP  (write),  X_GRP(execute)
!!     Others:  R_OTH  (read),  W_OTH  (write),  X_OTH(execute)
!!
!!    Additionally, some shortcuts are provided (basically a bitwise-OR combination of the above):
!!
!!      Read + Write + Execute: R_WXU (User), R_WXG (Group), R_WXO (Others)
!!      DEFFILEMODE: Equivalent of 0666 =rw-rw-rw-
!!      ACCESSPERMS: Equivalent of 0777 = rwxrwxrwx
!!
!!    Therefore, to give only the user rwx (read+write+execute) rights whereas
!!    group members and others may not do anything, you can use any of the
!!    following mkdir() calls equivalently:
!!
!!      ierr= mkdir("mydir", IANY([R_USR, W_USR, X_USR]));
!!      ierr= mkdir("mydir", R_WXU);
!!
!!    In order to give anyone any rights (mode 0777 = rwxrwxrwx), you can
!!    use any of the following calls equivalently:
!!
!!      ierr= mkdir("mydir",IANY([R_USR,W_USR,X_USR,R_GRP,W_GRP,X_GRP,R_OTH,W_OTH,X_OTH]));
!!      ierr= mkdir("mydir",IANY([R_WXU,R_WXG,R_WXO]));
!!      ierr= mkdir("mydir",ACCESSPERMS);
!!
!!##EXAMPLE
!!
!!   Sample program:
!!
!!    program demo_system_mkdir
!!    use M_system, only : system_perror
!!    use M_system, only : system_mkdir
!!    use M_system, only : R_GRP,R_OTH,R_USR,R_WXG,R_WXO
!!    use M_system, only : R_WXU,W_GRP,W_OTH,W_USR,X_GRP,X_OTH,X_USR
!!    use M_system, only : DEFFILEMODE, ACCESSPERMS
!!    implicit none
!!    integer :: ierr
!!    ierr=system_mkdir('_scratch',IANY([R_USR,W_USR,X_USR]))
!!    end program demo_system_mkdir
!===================================================================================================================================
function system_mkdir(dirname,mode) result(ierr)

character(len=*),parameter::ident_21="@(#)M_system::system_mkdir(3f): call mkdir(3c) to create empty directory"

character(len=*),intent(in)       :: dirname
integer,intent(in)                :: mode
   integer                        :: c_mode
   integer(kind=c_int)            :: err
   integer                        :: ierr

interface
   function c_mkdir(c_path,c_mode) bind(c,name="mkdir") result(c_err)
      import c_char, c_int
      character(len=1,kind=c_char),intent(in) :: c_path(*)
      integer(c_int),intent(in),value         :: c_mode
      integer(c_int)                          :: c_err
   end function c_mkdir
end interface
interface
    subroutine my_mkdir(string,c_mode,c_err) bind(C, name="my_mkdir")
      use iso_c_binding, only: c_char, c_int
      character(kind=c_char) :: string(*)
      integer(c_int),intent(in),value         :: c_mode
      integer(c_int)                          :: c_err
    end subroutine my_mkdir
end interface
!-----------------------------------------------------------------------------------------------------------------------------------
   c_mode=mode
   if(index(dirname,'/').ne.0)then
      call my_mkdir(str2arr(trim(dirname)),c_mode,err)
   else
      err= c_mkdir(str2arr(trim(dirname)),c_mode)
   endif
   ierr=err                                          ! c_int to default integer kind
end function system_mkdir
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!    system_opendir(3f) - [M_system] open directory stream by calling opendir(3c)
!!##SYNOPSIS
!!
!!   subroutine system_opendir(dirname,dir,ierr)
!!
!!    character(len=*), intent(in) :: dirname
!!    type(c_ptr)                  :: dir
!!    integer,intent(out)          :: ierr
!!
!!##DESCRIPTION
!!        The system_opendir(3f) procedure opens a directory stream
!!        corresponding to the directory named by the dirname argument.
!!        The directory stream is positioned at the first entry.
!!
!!##RETURN VALUE
!!        Upon successful completion, a pointer to a C dir type is returned.
!!        Otherwise, these functions shall return a null pointer and set
!!        IERR to indicate the error.
!!
!!##ERRORS
!!
!!        An error corresponds to a condition described in opendir(3c):
!!
!!        EACCES    Search permission is denied for the component of the
!!                  path prefix of dirname or read permission is denied
!!                  for dirname.
!!
!!        ELOOP     A loop exists in symbolic links encountered during
!!                  resolution of the dirname argument.
!!
!!        ENAMETOOLONG  The length of a component of a pathname is longer than {NAME_MAX}.
!!
!!        ENOENT        A component of dirname does not name an existing directory or dirname is an empty string.
!!
!!        ENOTDIR       A component of dirname names an existing file that is neither a directory nor a symbolic link to a directory.
!!
!!        ELOOP         More than {SYMLOOP_MAX} symbolic links were encountered during resolution of the dirname argument.
!!
!!        EMFILE        All file descriptors available to the process are currently open.
!!
!!        ENAMETOOLONG  The length of a pathname exceeds {PATH_MAX},
!!                      or pathname resolution of a symbolic link produced an intermediate
!!                      result with a length that exceeds {PATH_MAX}.
!!
!!        ENFILE        Too many files are currently open in the system.
!!
!!##APPLICATION USAGE
!!        The opendir() function should be used in conjunction with readdir(), closedir(), and rewinddir() to examine the contents
!!        of the directory (see the EXAMPLES section in readdir()). This method is recommended for portability.
!!##OPTIONS
!!       dirname name of directory to open a directory stream for
!!##RETURNS
!!       dir   pointer to directory stream. If an
!!             error occurred, it will not be associated.
!!       ierr  0 indicates no error occurred
!!##EXAMPLE
!!
!!   Sample program:
!!
!!    program demo_system_opendir
!!    use M_system, only : system_opendir,system_readdir
!!    use M_system, only : system_closedir
!!    use iso_c_binding
!!    implicit none
!!    type(c_ptr)                  :: dir
!!    character(len=:),allocatable :: filename
!!    integer                      :: ierr
!!    !--- open directory stream to read from
!!    call system_opendir('.',dir,ierr)
!!    !--- read directory stream
!!    do
!!       call system_readdir(dir,filename,ierr)
!!       if(filename.eq.' ')exit
!!       write(*,*)filename
!!    enddo
!!    !--- close directory stream
!!    call system_closedir(dir,ierr)
!!    end program demo_system_opendir
!===================================================================================================================================
subroutine system_opendir(dirname,dir,ierr)
character(len=*), intent(in) :: dirname
type(c_ptr)                  :: dir
integer,intent(out)          :: ierr

interface
   function c_opendir(c_dirname) bind(c,name="opendir") result(c_dir)
      import c_char, c_int, c_ptr
      character(kind=c_char),intent(in) :: c_dirname(*)
      type(c_ptr)                       :: c_dir
   end function c_opendir
end interface

   ierr=0
   dir = c_opendir(str2arr(trim(dirname)))
   if(.not.c_associated(dir)) then
      write(*,'(a)')'*system_opendir* Error opening '//trim(dirname)
      ierr=-1
   endif

end subroutine system_opendir
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!    system_readdir(3f) - [M_system] read a directory using readdir(3c)
!!##SYNOPSIS
!!
!! subroutine system_readdir(dir,filename,ierr)
!!
!!  type(c_ptr),value                         :: dir
!!  character(len=:),intent(out),allocatable  :: filename
!!  integer,intent(out)                       :: ierr
!!
!!##DESCRIPTION
!!    system_readdir(3f) returns the name of the directory entry at the
!!    current position in the directory stream specified by the argument
!!    DIR, and positions the directory stream at the next entry. It returns
!!    a null name upon reaching the end of the directory stream.
!!
!!    The readdir() function does not return directory entries containing
!!    empty names. If entries for dot or dot-dot exist, one entry is returned
!!    for dot and one entry is returned for dot-dot.
!!
!!    The entry is marked for update of the last data access timestamp each
!!    time it is read.
!!
!!    If IERR is set to non-zero on return, an error occurred.
!!
!!    least {NAME_MAX}+1 elements.
!!
!!    reaching the end of the directory stream, the name is a blank name.
!!
!!
!!##EXAMPLE
!!
!!   Sample program:
!!
!!    program demo_system_readdir
!!    use M_system, only : system_opendir,system_readdir
!!    use M_system, only : system_rewinddir,system_closedir
!!    use iso_c_binding
!!    implicit none
!!
!!    type(c_ptr)                  :: dir
!!    character(len=:),allocatable :: filename
!!    integer                      :: i, ierr
!!    !--- open directory stream to read from
!!    call system_opendir('.',dir,ierr)
!!    !--- read directory stream twice
!!    do i=1,2
!!       write(*,'(a,i0)')'PASS ',i
!!       do
!!          call system_readdir(dir,filename,ierr)
!!          if(filename.eq.' ')exit
!!          write(*,*)filename
!!       enddo
!!       call system_rewinddir(dir)
!!    enddo
!!    !--- close directory stream
!!    call system_closedir(dir,ierr)
!!
!!    end program demo_system_readdir
!===================================================================================================================================
subroutine system_readdir(dir,filename,ierr)
type(c_ptr),value                         :: dir
character(len=:),intent(out),allocatable  :: filename
integer,intent(out)                       :: ierr
integer(kind=c_int)                       :: ierr_local

   character(kind=c_char,len=1)           :: buf(4097)

interface
   subroutine c_readdir(c_dir, c_filename,c_ierr) bind (C,NAME='my_readdir')
      import c_char, c_int, c_ptr
      type(c_ptr),value                   :: c_dir
      character(kind=c_char),intent(out)  :: c_filename(*)
      integer(kind=c_int),intent(out)     :: c_ierr
   end subroutine c_readdir
end interface

   buf=' '
   ierr_local=0
   call c_readdir(dir,buf,ierr_local)
   filename=trim(arr2str(buf))
   ierr=ierr_local

end subroutine system_readdir
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!       system_rewinddir(3f) - [M_system] call rewinddir(3c) to rewind directory stream
!!##SYNOPSIS
!!
!!    subroutine system_rewinddir(dir)
!!
!!     type(c_ptr),value :: dir
!!
!!##DESCRIPTION
!!     Return to pointer to the beginning of the list for a currently open directory list.
!!
!!##OPTIONS
!!     DIR  A C_pointer assumed to have been allocated by a call to SYSTEM_OPENDIR(3f).
!!
!!##EXAMPLE
!!
!!   Sample program:
!!
!!    program demo_system_rewinddir
!!    use M_system, only : system_opendir,system_readdir
!!    use M_system, only : system_rewinddir,system_closedir
!!    use iso_c_binding
!!    implicit none
!!
!!    type(c_ptr)                  :: dir
!!    character(len=:),allocatable :: filename
!!    integer                      :: i, ierr
!!    !>>> open directory stream to read from
!!    call system_opendir('.',dir,ierr)
!!    !>>> read directory stream twice
!!    do i=1,2
!!       write(*,'(a,i0)')'PASS ',i
!!       do
!!          call system_readdir(dir,filename,ierr)
!!          if(filename.eq.' ')exit
!!          write(*,*)filename
!!       enddo
!!       !>>> rewind directory stream
!!       call system_rewinddir(dir)
!!    enddo
!!    !>>> close directory stream
!!    call system_closedir(dir,ierr)
!!
!!    end program demo_system_rewinddir
!===================================================================================================================================
subroutine system_rewinddir(dir)
type(c_ptr),value            :: dir

interface
   subroutine c_rewinddir(c_dir) bind(c,name="rewinddir")
      import c_char, c_int, c_ptr
      type(c_ptr),value :: c_dir
   end subroutine c_rewinddir
end interface

   call c_rewinddir(dir)

end subroutine system_rewinddir
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!        system_closedir(3f) - [M_system] close a directory stream by calling closedir(3c)
!!##SYNOPSIS
!!
!!        subroutine system_closedir(dir,ierr)
!!
!!         type(c_ptr)         :: dir
!!         integer,intent(out) :: ierr
!!##DESCRIPTION
!!        The SYSTEM_CLOSEDIR(3f) function closes the directory stream referred to by the argument DIR.
!!        Upon return, the value of DIR may no longer point to an accessible object.
!!##OPTIONS
!!        dir     directory stream pointer opened by SYSTEM_OPENDIR(3f).
!!        ierr    Upon successful completion, SYSTEM_CLOSEDIR(3f) returns 0;
!!                otherwise, an error has occurred.
!!##ERRORS
!!        system_closedir(3f) may fail if:
!!
!!        EBADF    The dirp argument does not refer to an open directory stream.
!!        EINTR    The closedir() function was interrupted by a signal.
!!##EXAMPLE
!!
!!   Sample program
!!
!!    program demo_system_closedir
!!    use M_system, only : system_opendir,system_readdir
!!    use M_system, only : system_closedir, system_rewinddir
!!    use iso_c_binding, only : c_ptr
!!    implicit none
!!    type(c_ptr)                  :: dir
!!    character(len=:),allocatable :: filename
!!    integer                      :: ierr
!!    !--- open directory stream to read from
!!    call system_opendir('.',dir,ierr)
!!    !--- read directory stream
!!    do
!!       call system_readdir(dir,filename,ierr)
!!       if(filename.eq.' ')exit
!!       write(*,*)filename
!!    enddo
!!    call system_rewinddir(dir)
!!    !--- close directory stream
!!    call system_closedir(dir,ierr)
!!    end program demo_system_closedir
!===================================================================================================================================
subroutine system_closedir(dir,ierr)
use iso_c_binding
type(c_ptr),value            :: dir
integer,intent(out),optional :: ierr
   integer                   :: ierr_local

interface
   function c_closedir(c_dir) bind(c,name="closedir") result(c_err)
      import c_char, c_int, c_ptr
      type(c_ptr),value      :: c_dir
      integer(kind=c_int)    :: c_err
   end function c_closedir
end interface

    ierr_local = c_closedir(dir)
    if(present(ierr))then
       ierr=ierr_local
    else
       if(ierr_local /= 0) then
          print *, "*system_closedir* error", ierr_local
          stop 3
       endif
    endif

end subroutine system_closedir
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!    system_putenv(3f) - [M_system:ENVIRONMENT] set environment variable from Fortran by calling putenv(3c)
!!
!!##SYNOPSIS
!!
!!    subroutine system_putenv(string, err)
!!
!!     character(len=*),intent(in)    :: string
!!     integer, optional, intent(out) :: err
!!
!!##DESCRIPTION
!!    The system_putenv() function adds or changes the value of environment variables.
!!
!!##OPTIONS
!!    string  string of format "NAME=value".
!!            If name does not already exist in the environment, then string is added to the environment.
!!            If name does exist, then the value of name in the environment is changed to value.
!!            The string passed to putenv(3c) becomes part of the environment,
!!            so this routine creates a string each time it is called that increases the amount of
!!            memory the program uses.
!!    err     The system_putenv() function returns zero on success, or nonzero if an error occurs.
!!            A non-zero error usually indicates sufficient memory does not exist to store the
!!            variable.
!!
!!##EXAMPLE
!!
!!   Sample setting an environment variable from Fortran:
!!
!!     program demo_system_putenv
!!     use M_system, only: system_putenv
!!     use iso_c_binding
!!     implicit none
!!     integer :: ierr
!!        !
!!        write(*,'(a)')'no environment variables containing "GRU":'
!!        call execute_command_line('env|grep GRU')
!!        !
!!        call system_putenv('GRU=this is the value',ierr)
!!        write(*,'(a,i0)')'now "GRU" should be defined: ',ierr
!!        call execute_command_line('env|grep GRU')
!!        !
!!        call system_putenv('GRU2=this is the second value',ierr)
!!        write(*,'(a,i0)')'now "GRU" and "GRU2" should be defined: ',ierr
!!        call execute_command_line('env|grep GRU')
!!        !
!!        call system_putenv('GRU2',ierr)
!!        call system_putenv('GRU',ierr)
!!        write(*,'(a,i0)')'should be gone, varies with different putenv(3c): ',ierr
!!        call execute_command_line('env|grep GRU')
!!        write(*,'(a)')'system_unsetenv(3f) is a better way to remove variables'
!!        !
!!     end program demo_system_putenv
!!
!!   Results:
!!
!!    no environment variables containing "GRU":
!!    now "GRU" should be defined: 0
!!    GRU=this is the value
!!    now "GRU" and "GRU2" should be defined: 0
!!    GRU2=this is the second value
!!    GRU=this is the value
!!    should be gone, varies with different putenv(3c): 0
!!    system_unsetenv(3f) is a better way to remove variables
!===================================================================================================================================
subroutine system_putenv(string, err)

character(len=*),parameter::ident_22="@(#)M_system::system_putenv(3f): call putenv(3c)"

interface
   integer(kind=c_int)  function c_putenv(c_string) bind(C,name="putenv")
      import c_int, c_char
      character(kind=c_char)   :: c_string(*)
   end function
end interface

character(len=*),intent(in)    :: string
integer, optional, intent(out) :: err
   integer                     :: loc_err
   integer                     :: i

   ! PUTENV actually adds the data to the environment so the string passed should be saved or will vanish on exit
   character(len=1,kind=c_char),save, pointer :: memleak(:)

   allocate(memleak(len(string)+1))
   do i=1,len(string)
      memleak(i)=string(i:i)
   enddo
   memleak(len(string)+1)=c_null_char

   loc_err =  c_putenv(memleak)
   if (present(err)) err = loc_err

end subroutine system_putenv
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!    system_getenv(3f) - [M_system:ENVIRONMENT] get environment variable from Fortran by calling get_environment_variable(3f)
!!
!!##SYNOPSIS
!!
!!    function system_getenv(name)
!!
!!     character(len=:),allocatable   :: system_getenv
!!     character(len=*),intent(in)    :: name
!!
!!##DESCRIPTION
!!    The system_getenv() function gets the value of an environment variable.
!!
!!##OPTIONS
!!    name    Return the value of the specified environment variable or
!!            blank if the variable is not defined.
!!
!!##EXAMPLE
!!
!!   Sample setting an environment variable from Fortran:
!!
!!    program demo_system_getenv
!!    use M_system, only: system_getenv
!!    implicit none
!!    integer :: ierr
!!
!!       write(*,'("USER     : ",a)')system_getenv('USER')
!!       write(*,'("LOGNAME  : ",a)')system_getenv('LOGNAME')
!!       write(*,'("USERNAME : ",a)')system_getenv('USERNAME')
!!
!!    end program demo_system_getenv
!===================================================================================================================================
function system_getenv(name) result(var)

character(len=*),parameter::ident_23="@(#)M_system::system_getenv(3f): call get_environment_variable(3f)"

character(len=*),intent(in)  :: name
integer                      :: howbig
character(len=:),allocatable :: var

   call get_environment_variable(name, length=howbig)  ! get length required to hold value
   if(howbig.ne.0)then
      allocate(character(len=howbig) :: var)           ! make string to hold value of sufficient size
      var(:)=' '
      call get_environment_variable(name, var)         ! get value
   else
      var=''
   endif

end function system_getenv
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!    set_environment_variable(3f) - [M_system:ENVIRONMENT] call setenv(3c) to set environment variable
!!
!!##SYNOPSIS
!!
!!   subroutine set_environment_variable(NAME, VALUE, STATUS)
!!
!!    character(len=*)               :: NAME
!!    character(len=*)               :: VALUE
!!    integer, optional, intent(out) :: STATUS
!!
!!##DESCRIPTION
!!    The set_environment_variable() procedure adds or changes the value of environment variables.
!!
!!##OPTIONS
!!    NAME    If name does not already exist in the environment, then string is added to the environment.
!!            If name does exist, then the value of name in the environment is changed to value.
!!    VALUE   Value to assign to environment variable NAME
!!    STATUS  returns zero on success, or nonzero if an error occurs.
!!            A non-zero error usually indicates sufficient memory does not exist to store the
!!            variable.
!!
!!##EXAMPLE
!!
!!   Sample setting an environment variable from Fortran:
!!
!!    program demo_set_environment_variable
!!    use M_system, only: set_environment_variable
!!    use iso_c_binding
!!    implicit none
!!    integer :: ierr
!!       !!
!!       write(*,'(a)')'no environment variables containing "GRU":'
!!       call execute_command_line('env|grep GRU')
!!       !!
!!       call set_environment_variable('GRU','this is the value',ierr)
!!       write(*,'(a,i0)')'now "GRU" should be defined, status=',ierr
!!       call execute_command_line('env|grep GRU')
!!       !!
!!       call set_environment_variable('GRU2','this is the second value',ierr)
!!       write(*,'(a,i0)')'now "GRU" and "GRU2" should be defined, status =',ierr
!!       !!
!!       call execute_command_line('env|grep GRU')
!!    end program demo_set_environment_variable
!!
!!   Results:
!!
!!    no environment variables containing "GRU":
!!    now "GRU" should be defined, status=0
!!    GRU=this is the value
!!    now "GRU" and "GRU2" should be defined, status =0
!!    GRU2=this is the second value
!!    GRU=this is the value
!===================================================================================================================================
subroutine set_environment_variable(NAME, VALUE, STATUS)

character(len=*),parameter::ident_24="@(#)M_system::set_environment_variable(3f): call setenv(3c) to set environment variable"

   character(len=*)               :: NAME
   character(len=*)               :: VALUE
   integer, optional, intent(out) :: STATUS
   integer                        :: loc_err

interface
   integer(kind=c_int) function c_setenv(c_name,c_VALUE) bind(C,NAME="setenv")
      import c_int, c_char
      character(kind=c_char)   :: c_name(*)
      character(kind=c_char)   :: c_VALUE(*)
   end function
end interface

   loc_err =  c_setenv(str2arr(trim(NAME)),str2arr(VALUE))
   if (present(STATUS)) STATUS = loc_err
end subroutine set_environment_variable
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!    system_clearenv(3f) - [M_system:ENVIRONMENT] clear environment by calling clearenv(3c)
!!
!!
!!##SYNOPSIS
!!
!!    subroutine system_clearenv(ierr)
!!
!!     integer,intent(out),optional :: ierr
!!
!!##DESCRIPTION
!!    The clearenv() procedure clears the environment of all name-value
!!    pairs.  Typically used in security-conscious applications or ones where
!!    configuration control requires ensuring specific variables are set.
!!
!!##RETURN VALUES
!!    ierr  returns zero on success, and a nonzero value on failure. Optional.
!!          If not present and an error occurs the program stops.
!!
!!##EXAMPLE
!!
!!
!!   Sample program:
!!
!!      program demo_system_clearenv
!!      use M_system, only : system_clearenv
!!      implicit none
!!      ! environment before clearing
!!      call execute_command_line('env|wc')
!!      ! environment after clearing (not necessarily blank!!)
!!      call system_clearenv()
!!      call execute_command_line('env')
!!      end program demo_system_clearenv
!!
!!   Typical output:
!!
!!      89     153    7427
!!      PWD=/home/urbanjs/V600
!!      SHLVL=1
!===================================================================================================================================
subroutine system_clearenv(ierr)
!  emulating because not available on some platforms

character(len=*),parameter::ident_25="@(#)M_system::system_clearenv(3f): emulate clearenv(3c) to clear environment"

integer,intent(out),optional    :: ierr
   character(len=:),allocatable :: string
   integer                      :: ierr_local1, ierr_local2
   ierr_local2=0
   INFINITE: do
      call system_initenv()                     ! important -- changing table causes undefined behavior so reset after each unsetenv
      string=system_readenv()                                           ! get first name=value pair
      if(string.eq.'') exit INFINITE
      call system_unsetenv(string(1:index(string,'=')-1) ,ierr_local1)  ! remove first name=value pair
      if(ierr_local1.ne.0)ierr_local2=ierr_local1
   enddo INFINITE
   if(present(ierr))then
      ierr=ierr_local2
   elseif(ierr_local2.ne.0)then                                         ! if error occurs and not being returned, stop
      write(*,*)'*system_clearenv* error=',ierr_local2
      stop
   endif
end subroutine system_clearenv
!--subroutine system_clearenv(ierr)
!--! clearenv(3c) not available on some systems I tried
!--! Found reference that if it is unavailable the assignment "environ = NULL;" will probably do but emulating instead
!--$@ (#)M_system::system_clearenv(3f): call clearenv(3c) to clear environment"
!--integer,intent(out),optional :: ierr
!--   integer                   :: ierr_local
!--
!--interface
!--   integer(kind=c_int) function c_clearenv() bind(C,NAME="clearenv")
!--   import c_int
!--   end function
!--end interface
!--
!--   ierr_local = c_clearenv()
!--   if(present(ierr))then
!--      ierr=ierr_local
!--   elseif(ierr_local.ne.0)then ! if error occurs and not being returned, stop
!--      write(*,*)'*system_clearenv* error=',ierr_local
!--      stop
!--   endif
!--
!--end subroutine system_clearenv
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!    system_unsetenv(3f) - [M_system:ENVIRONMENT] delete an environment variable by calling unsetenv(3c)
!!##SYNOPSIS
!!
!!   subroutine system_unsetenv(name,ierr)
!!
!!    character(len=*),intent(in)  :: name
!!    integer,intent(out),optional :: ierr
!!
!!##DESCRIPTION
!!
!!    The system_unsetenv(3f) function deletes the variable name from the
!!    environment.
!!
!!##OPTIONS
!!    name   name of variable to delete.
!!           If name does not exist in the environment, then the
!!           function succeeds, and the environment is unchanged.
!!
!!    ierr   The system_unsetenv(3f) function returns zero on success, or -1 on error.
!!           name is NULL, points to a string of length 0, or contains an '=' character.
!!           Insufficient memory to add a new variable to the environment.
!!
!!##EXAMPLE
!!
!!   Sample program:
!!
!!      program demo_system_unsetenv
!!      use M_system, only : system_unsetenv, system_putenv
!!      implicit none
!!      call system_putenv('GRU=this is the value')
!!      write(*,'(a)')'The variable GRU should be set'
!!      call execute_command_line('env|grep GRU')
!!      call system_unsetenv('GRU')
!!      write(*,'(a)')'The variable GRU should not be set'
!!      call execute_command_line('env|grep GRU')
!!      end program demo_system_unsetenv
!===================================================================================================================================
subroutine system_unsetenv(name,ierr)

character(len=*),parameter::ident_26="@(#)M_system::system_unsetenv(3f): call unsetenv(3c) to remove variable from environment"

character(len=*),intent(in)  :: name
integer,intent(out),optional :: ierr
   integer                   :: ierr_local

! int unsetenv(void)
interface
   integer(kind=c_int) function c_unsetenv(c_name) bind(C,NAME="unsetenv")
   import c_int, c_char
   character(len=1,kind=c_char) :: c_name(*)
   end function
end interface

   ierr_local =  c_unsetenv(str2arr(trim(NAME)))

   if(present(ierr))then
      ierr=ierr_local
   elseif(ierr_local.ne.0)then ! if error occurs and not being returned, stop
      write(*,*)'*system_unsetenv* error=',ierr_local
      stop
   endif

end subroutine system_unsetenv
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!    system_readenv(3f) - [M_system:ENVIRONMENT] step thru and read environment table
!!##SYNOPSIS
!!
!!       function system_readenv() result(string)
!!
!!        character(len=:),allocatable  :: string
!!##DESCRIPTION
!!    A simple interface allows reading the environment variable table of the process. Call
!!    system_initenv(3f) to initialize reading the environment table, then call system_readenv(3f) can
!!    be called until a blank line is returned. If more than one thread
!!    reads the environment or the environment is changed while being read the results are undefined.
!!##OPTIONS
!!    string  the string returned from the environment of the form "NAME=VALUE"
!!
!!##EXAMPLE
!!
!!   Sample program:
!!
!!    program demo_system_readenv
!!    use M_system, only : system_initenv, system_readenv
!!    character(len=:),allocatable :: string
!!       call system_initenv()
!!       do
!!          string=system_readenv()
!!          if(string.eq.'')then
!!             exit
!!          else
!!             write(*,'(a)')string
!!          endif
!!       enddo
!!    end program demo_system_readenv
!!
!!   Sample results:
!!
!!    USERDOMAIN_ROAMINGPROFILE=buzz
!!    HOMEPATH=\Users\JSU
!!    APPDATA=C:\Users\JSU\AppData\Roaming
!!    MANPATH=/home/urbanjs/V600/LIBRARY/libGPF/download/tmp/man:/home/urbanjs/V600/doc/man:::
!!    DISPLAYNUM=0
!!    ProgramW6432=C:\Program Files
!!    HOSTNAME=buzz
!!    XKEYSYMDB=/usr/share/X11/XKeysymDB
!!    PUBLISH_CMD=
!!    OnlineServices=Online Services
!!         :
!!         :
!!         :
!===================================================================================================================================
function system_readenv() result(string)

character(len=*),parameter::ident_27="@(#)M_system::system_readenv(3f): read next entry from environment table"

character(len=:),allocatable  :: string
character(kind=c_char)        :: c_buff(longest_env_variable+1)

interface
   subroutine c_readenv(c_string) bind (C,NAME='my_readenv')
      import c_char, c_int, c_ptr, c_size_t
      character(kind=c_char),intent(out)  :: c_string(*)
   end subroutine c_readenv
end interface

  c_buff=' '
  c_buff(longest_env_variable+1:longest_env_variable+1)=c_null_char
  call c_readenv(c_buff)
  string=trim(arr2str(c_buff))

end function system_readenv
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!   system_uname(3f) - [M_system] call a C wrapper that calls uname(3c) to get current system information from Fortran
!!##SYNOPSIS
!!
!!    subroutine system_uname(WHICH,NAMEOUT)
!!
!!     character(KIND=C_CHAR),intent(in) :: WHICH
!!     character(len=*),intent(out)      :: NAMEOUT
!!##DESCRIPTION
!!        Given a letter, return a corresponding description of the current operating system.
!!        The NAMEOUT variable is assumed sufficiently large enough to hold the value.
!!
!!        s   return the kernel name
!!        r   return the kernel release
!!        v   return the kernel version
!!        n   return the network node hostname
!!        m   return the machine hardware name
!!        T   test mode -- print all information, in the following order - srvnm
!!
!!##EXAMPLE
!!
!!   Call uname(3c) from Fortran
!!
!!    program demo_system_uname
!!       use M_system, only: system_uname
!!       implicit none
!!       integer,parameter          :: is=100
!!       integer                    :: i
!!       character(len=*),parameter :: letters='srvnmxT'
!!       character(len=is)          :: string=' '
!!
!!       do i=1,len(letters)
!!          write(*,'(80("="))')
!!          call system_uname(letters(i:i),string)
!!          write(*,*)'=====> TESTING system_uname('//letters(i:i)//')--->'//trim(string)
!!       enddo
!!
!!    end program demo_system_uname
!===================================================================================================================================
subroutine system_uname(WHICH,NAMEOUT)
implicit none

character(len=*),parameter::ident_29="@(#)M_system::system_uname(3f): call my_uname(3c) which calls uname(3c)"

character(KIND=C_CHAR),intent(in) :: WHICH
character(len=*),intent(out)      :: NAMEOUT

! describe the C routine to Fortran
! void system_uname(char *which, char *buf, int *buflen);
interface
   subroutine system_uname_c(WHICH,BUF,BUFLEN) bind(C,NAME='my_uname')
      import c_char, c_int
      implicit none
      character(KIND=C_CHAR),intent(in)  :: WHICH
      character(KIND=C_CHAR),intent(out) :: BUF(*)
      integer(kind=c_int),intent(in)     :: BUFLEN
   end subroutine system_uname_c
end interface

   NAMEOUT='unknown'
   call system_uname_c(WHICH,NAMEOUT, INT(LEN(NAMEOUT),kind(0_c_int)))

end subroutine system_uname
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!        system_gethostname(3f) - [M_system:QUERY] get name of current host
!!##SYNOPSIS
!!
!!       subroutine system_gethostname(string,ierr)
!!
!!        character(len=:),allocatable,intent(out) :: NAME
!!        integer,intent(out)                      :: IERR
!!##DESCRIPTION
!!        The system_gethostname(3f) procedure returns the standard host
!!        name for the current machine.
!!
!!##OPTIONS
!!        string  returns the hostname. Must be an allocatable CHARACTER variable.
!!        ierr    Upon successful completion, 0 shall be returned; otherwise, -1
!!                shall be returned.
!!##EXAMPLE
!!
!!   Sample program:
!!
!!    program demo_system_gethostname
!!
!!    use M_system, only : system_gethostname
!!    implicit none
!!    character(len=:),allocatable :: name
!!    integer                      :: ierr
!!
!!       call system_gethostname(name,ierr)
!!       if(ierr.eq.0)then
!!          write(*,'("hostname[",a,"]")')name
!!       else
!!          write(*,'(a)')'ERROR: could not get hostname'
!!       endif
!!
!!    end program demo_system_gethostname
!===================================================================================================================================
subroutine system_gethostname(NAME,IERR)
implicit none

character(len=*),parameter::ident_30="@(#)M_system::system_gethostname(3f): get name of current host by calling gethostname(3c)"

character(len=:),allocatable,intent(out) :: NAME
integer,intent(out)                      :: IERR
   character(kind=c_char,len=1)          :: C_BUFF(HOST_NAME_MAX+1)

! describe the C routine to Fortran
!int gethostname(char *name, size_t namelen);
interface
   function system_gethostname_c(c_buf,c_buflen) bind(C,NAME='gethostname')
      import c_char, c_int
      implicit none
      integer(kind=c_int)                  :: system_gethostname_c
      character(KIND=C_CHAR),intent(out)   :: c_buf(*)
      integer(kind=c_int),intent(in),value :: c_buflen
   end function system_gethostname_c
end interface

   C_BUFF=' '
   ierr=system_gethostname_c(C_BUFF,HOST_NAME_MAX) ! Host names are limited to {HOST_NAME_MAX} bytes.
   NAME=trim(arr2str(C_BUFF))

end subroutine system_gethostname
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!    system_getlogin(3f) - [M_system:QUERY] get login name
!!
!!##SYNOPSIS
!!
!!   function system_getlogin() result (fname)
!!
!!    character(len=:),allocatable :: FNAME
!!
!!##DESCRIPTION
!!
!!    The system_getlogin() function returns a string containing the user
!!    name associated by the login activity with the controlling terminal
!!    of the current process. Otherwise, it returns a null string and sets
!!    errno to indicate the error.
!!
!!    Three names associated with the current process can be determined:
!!       o system_getpwuid(system_getuid()) returns the name associated with the real user ID of the process.
!!       o system_getpwuid(system_geteuid()) returns the name associated with the effective user ID of the process
!!       o system_getlogin() returns the name associated with the current login activity
!!
!!##RETURN VALUE
!!    fname  returns the login name.
!!
!!##EXAMPLE
!!
!!   Sample program:
!!
!!    program demo_system_getlogin
!!    use M_system, only : system_getlogin
!!    implicit none
!!    character(len=:),allocatable :: name
!!    name=system_getlogin()
!!    write(*,'("login[",a,"]")')name
!!    end program demo_system_getlogin
!!
!!   Results:
!!
!!    login[JSU]
!===================================================================================================================================
!--       The following example calls the getlogin() function to obtain the name of the user associated with the calling process,
!--       and passes this information to the getpwnam() function to get the associated user database information.
!--           ...
!--           char *lgn;
!--           struct passwd *pw;
!--           ...
!--           if ((lgn = getlogin()) == NULL || (pw = getpwnam(lgn)) == NULL) {
!--               fprintf(stderr, "Get of user information failed.\n"); exit(1);
!--               }
!--APPLICATION USAGE
!--SEE ALSO
!--       getpwnam(), getpwuid(), system_geteuid(), getuid()
function system_getlogin() result (fname)
character(len=:),allocatable :: fname
   type(c_ptr)               :: username

interface
   function c_getlogin() bind(c,name="getlogin") result(c_username)
      import c_int, c_ptr
      type(c_ptr)           :: c_username
   end function c_getlogin
end interface

   username = c_getlogin()
   if(.not.c_associated(username)) then
      write(*,'(a)')'*system_getlogin* Error getting username. not associated'
      fname=c_null_char
   else
      fname=c2f_string(username)
   endif

end function system_getlogin
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!    system_perm(3f) - [M_system] get file type and permission as a string
!!
!!##SYNOPSIS
!!
!!   function system_perm(mode) result (perms)
!!
!!    integer(kind=8),intent(in)   :: MODE
!!    character(len=:),allocatable :: PERMS
!!
!!##DESCRIPTION
!!
!!    The system_perm(3f) function returns a string containing the type
!!    and permission of a file implied by the value of the mode value.
!!
!!##RETURN VALUE
!!    PERMS  returns the permission string in a format similar to that
!!           used by Unix commands such as ls(1).
!!
!!##EXAMPLE
!!
!!   Sample program:
!!
!!    program demo_system_perm
!!    use M_system, only : system_perm, system_stat
!!    implicit none
!!    character(len=4096) :: string
!!    integer(kind=8)     :: values(13)
!!    integer             :: ierr
!!    character(len=:),allocatable :: perms
!!       values=0
!!       call get_command_argument(1, string)  ! get pathname from command line
!!       call system_stat(string,values,ierr)  ! get pathname information
!!       if(ierr.eq.0)then
!!          perms=system_perm(values(3))       ! convert permit mode to a string
!!          ! print permits as a string, decimal value, and octal value
!!          write(*,'("for ",a," permits[",a,"]",1x,i0,1x,o0)') &
!!                  trim(string),perms,values(3),values(3)
!!       endif
!!    end program demo_system_perm
!!
!!   Results:
!!
!!    demo_system_perm /tmp
!!
!!    for /tmp permits[drwxrwxrwx --S] 17407 41777
!===================================================================================================================================
function system_perm(mode) result (perms)
integer(kind=8),intent(in)   :: mode
character(len=:),allocatable :: perms
   type(c_ptr)               :: permissions
   integer(kind=c_long)      :: mode_local
interface
   function c_perm(c_mode) bind(c,name="my_get_perm") result(c_permissions)
      import c_int, c_ptr, c_long
      integer(kind=c_long),value  :: c_mode
      type(c_ptr)                 :: c_permissions
   end function c_perm
end interface

   mode_local=int(mode,kind=c_long)
   permissions = c_perm(mode_local)
   if(.not.c_associated(permissions)) then
      write(*,'(a)')'*system_perm* Error getting permissions. not associated'
      perms=c_null_char
   else
      perms=c2f_string(permissions)
   endif

end function system_perm
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!    system_getgrgid(3f) - [M_system:QUERY] get groupd name associated with a GID
!!##SYNOPSIS
!!
!!   function system_getgrgid(gid) result (gname)
!!
!!    integer(kind=8),intent(in)   :: gid
!!    character(len=:),allocatable :: gname
!!
!!##DESCRIPTION
!!
!!    The system_getlogin() function returns a string containing the group
!!    name associated with the given GID. If no match is found
!!    it returns a null string and sets errno to indicate the error.
!!
!!##OPTION
!!    gid    GID to try to look up associated group for.
!!
!!##RETURN VALUE
!!    gname  returns the group name. Blank if an error occurs
!!
!!##EXAMPLE
!!
!!   Sample program:
!!
!!    program demo_system_getgrgid
!!    use M_system, only : system_getgrgid
!!    use M_system, only: system_getgid
!!    implicit none
!!    character(len=:),allocatable :: name
!!    integer(kind=8) :: gid
!!    gid=system_getgid()
!!    name=system_getgrgid( gid )
!!    write(*,'("group[",a,"] for ",i0)')name,system_getgid()
!!    end program demo_system_getgrgid
!!
!!   Results:
!!
!!    group[default] for 197121
!===================================================================================================================================
function system_getgrgid(gid) result (gname)
integer(kind=8),intent(in)                 :: gid
character(len=:),allocatable               :: gname
   character(kind=c_char,len=1)            :: groupname(4097)  ! assumed long enough for any groupname
   integer                                 :: ierr
   integer(kind=c_long_long)               :: gid_local

interface
   function c_getgrgid(c_gid,c_groupname) bind(c,name="my_getgrgid") result(c_ierr)
      import c_int, c_ptr, c_char,c_long_long
      integer(kind=c_long_long),value,intent(in) :: c_gid
      character(kind=c_char),intent(out)         :: c_groupname(*)
      integer(kind=c_int)                        :: c_ierr
   end function c_getgrgid
end interface
!-----------------------------------------------------------------------------------------------------------------------------------
   gid_local=gid
   ierr = c_getgrgid(gid_local,groupname)
   if(ierr.eq.0)then
      gname=trim(arr2str(groupname))
   else
      gname=''
   endif
!-----------------------------------------------------------------------------------------------------------------------------------
end function system_getgrgid
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!    system_getpwuid(3f) - [M_system:QUERY] get login name associated with a UID
!!##SYNOPSIS
!!
!!   function system_getpwuid(uid) result (uname)
!!
!!    integer(kind=8),intent(in)   :: uid
!!    character(len=:),allocatable :: uname
!!
!!##DESCRIPTION
!!
!!    The system_getlogin() function returns a string containing the user
!!    name associated with the given UID. If no match is found
!!    it returns a null string and sets errno to indicate the error.
!!
!!##OPTION
!!    uid    UID to try to look up associated username for. Can be of any
!!           INTEGER type.
!!
!!##RETURN VALUE
!!    uname  returns the login name.
!!
!!##EXAMPLE
!!
!!   Sample program:
!!
!!    program demo_system_getpwuid
!!    use M_system, only : system_getpwuid
!!    use M_system, only: system_getuid
!!    implicit none
!!    character(len=:),allocatable :: name
!!    integer(kind=8)              :: uid
!!       uid=system_getuid()
!!       name=system_getpwuid(uid)
!!       write(*,'("login[",a,"] has UID ",i0)')name,uid
!!    end program demo_system_getpwuid
!===================================================================================================================================
function system_getpwuid(uid) result (uname)
integer(kind=8),intent(in)                 :: uid
character(len=:),allocatable               :: uname
   character(kind=c_char,len=1)            :: username(4097)  ! assumed long enough for any username
   integer                                 :: ierr
   integer(kind=c_long_long)               :: uid_local

interface
   function c_getpwuid(c_uid,c_username) bind(c,name="my_getpwuid") result(c_ierr)
      import c_int, c_ptr, c_char, c_long_long
      integer(kind=c_long_long),value,intent(in) :: c_uid
      character(kind=c_char),intent(out)   :: c_username(*)
      integer(kind=c_int)                  :: c_ierr
   end function c_getpwuid
end interface
!-----------------------------------------------------------------------------------------------------------------------------------
   uid_local=uid
   ierr = c_getpwuid(uid_local,username)
   if(ierr.eq.0)then
      uname=trim(arr2str(username))
   else
      uname=''
   endif
!-----------------------------------------------------------------------------------------------------------------------------------
end function system_getpwuid
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
pure function arr2str(array)  result (string)

character(len=*),parameter::ident_31="@(#)M_system::arr2str(3fp): function copies null-terminated char array to string"

character(len=1),intent(in)  :: array(:)
character(len=size(array))   :: string
integer                      :: i

   string=' '
   do i = 1,size(array)
      if(array(i).eq.char(0))then
         exit
      else
         string(i:i) = array(i)
      endif
   enddo

end function arr2str
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
pure function str2arr(string) result (array)

character(len=*),parameter::ident_32="@(#)M_system::str2arr(3fp): function copies string to null terminated char array"

character(len=*),intent(in)     :: string
character(len=1,kind=c_char)    :: array(len(string)+1)
   integer                      :: i

   do i = 1,len_trim(string)
      array(i) = string(i:i)
   enddo
   array(i:i)=c_null_char

end function str2arr
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
function C2F_string(c_string_pointer) result(f_string)

! gets a C string (pointer), and returns the corresponding Fortran string up to 4096(max_len) characters;
! If the C string is null, it returns string C "null" character:

type(c_ptr), intent(in)                       :: c_string_pointer
character(len=:), allocatable                 :: f_string
character(kind=c_char), dimension(:), pointer :: char_array_pointer => null()
integer,parameter                             :: max_len=4096
character(len=max_len)                        :: aux_string
integer                                       :: i
integer                                       :: length

   length=0
   call c_f_pointer(c_string_pointer,char_array_pointer,[max_len])

   if (.not.associated(char_array_pointer)) then
     allocate(character(len=4)::f_string)
     f_string=c_null_char
     return
   endif

   aux_string=" "

   do i=1,max_len
     if (char_array_pointer(i)==c_null_char) then
       length=i-1; exit
     endif
     aux_string(i:i)=char_array_pointer(i)
   enddo

   allocate(character(len=length)::f_string)
   f_string=aux_string(1:length)
end function C2F_string
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!    SYSTEM_STAT - [M_system] Get file status information
!!
!!##SYNTAX
!!   CALL SYSTEM_STAT(NAME, VALUES [, STATUS],[DEBUG])
!!
!!    character(len=*),intent(in)          :: NAME
!!    integer(kind=8),intent(out)          :: values(13)
!!    integer,optional,intent(out)         :: status
!!    integer,intent(in)                   :: debug
!!
!!##DESCRIPTION
!!
!!    This function returns information about a file. No permissions are
!!    required on the file itself, but execute (search) permission is required
!!    on all of the directories in path that lead to the file. The elements
!!    that are obtained and stored in the array VALUES:
!!
!!       VALUES(1) Device ID
!!       VALUES(2) Inode number
!!       VALUES(3) File mode
!!       VALUES(4) Number of links
!!       VALUES(5) Owner's uid
!!       VALUES(6) Owner's gid
!!       VALUES(7) ID of device containing directory entry for file (0 if not available)
!!       VALUES(8) File size (bytes)
!!       VALUES(9) Last access time as a Unix Epoch time rounded to seconds
!!       VALUES(10) Last modification time as a Unix Epoch time rounded to seconds
!!       VALUES(11) Last file status change time as a Unix Epoch time rounded to seconds
!!       VALUES(12) Preferred I/O block size (-1 if not available)
!!       VALUES(13) Number of blocks allocated (-1 if not available)
!!
!!    Not all these elements are relevant on all systems. If an element is
!!    not relevant, it is returned as 0.
!!
!!##OPTIONS
!!
!!    NAME    The type shall be CHARACTER, of the default kind and a valid
!!            path within the file system.
!!    VALUES  The type shall be INTEGER(8), DIMENSION(13).
!!    STATUS  (Optional) status flag of type INTEGER(4). Returns 0 on success
!!            and a system specific error code otherwise.
!!    DEBUG   (Optional) print values being returned from C routine being
!!            called if value of 0 is used
!!
!!##EXAMPLE
!!
!!   program demo_system_stat
!!
!!    use M_system, only : system_stat, system_getpwuid, system_getgrgid
!!    implicit none
!!
!!    integer(kind=8)  :: buff(13)
!!    integer(kind=4)  :: status
!!    character(len=*),parameter :: fmt_date='year-month-day hour:minute:second'
!!
!!    integer(kind=8) :: &
!!       Device_ID,           Inode_number,          File_mode,                  Number_of_links,  Owner_uid,         &
!!       Owner_gid,           Directory_device,      File_size,                  Last_access,      Last_modification, &
!!       Last_status_change,  Preferred_block_size,  Number_of_blocks_allocated
!!    equivalence                                    &
!!       ( buff(1)  , Device_ID                  ) , &
!!       ( buff(2)  , Inode_number               ) , &
!!       ( buff(3)  , File_mode                  ) , &
!!       ( buff(4)  , Number_of_links            ) , &
!!       ( buff(5)  , Owner_uid                  ) , &
!!       ( buff(6)  , Owner_gid                  ) , &
!!       ( buff(7)  , Directory_device           ) , &
!!       ( buff(8)  , File_size                  ) , &
!!       ( buff(9)  , Last_access                ) , &
!!       ( buff(10) , Last_modification          ) , &
!!       ( buff(11) , Last_status_change         ) , &
!!       ( buff(12) , Preferred_block_size       ) , &
!!       ( buff(13) , Number_of_blocks_allocated )
!!
!!    CALL SYSTEM_STAT("/etc/hosts", buff, status)
!!
!!    if (status == 0) then
!!       write (*, FMT="('Device ID(hex/decimal):',      T30, Z0,'h/',I0,'d')") buff(1),buff(1)
!!       write (*, FMT="('Inode number:',                T30, I0)") buff(2)
!!       write (*, FMT="('File mode (octal):',           T30, O19)") buff(3)
!!       write (*, FMT="('Number of links:',             T30, I0)") buff(4)
!!       write (*, FMT="('Owner''s uid/username:',       T30, I0,1x, A)") buff(5), system_getpwuid(buff(5))
!!       write (*, FMT="('Owner''s gid/group:',          T30, I0,1x, A)") buff(6), system_getgrgid(buff(6))
!!       write (*, FMT="('Device where located:',        T30, I0)") buff(7)
!!       write (*, FMT="('File size(bytes):',            T30, I0)") buff(8)
!!       write (*, FMT="('Last access time:',            T30, I0)") buff(9)
!!       write (*, FMT="('Last modification time:',      T30, I0)") buff(10)
!!       write (*, FMT="('Last status change time:',     T30, I0)") buff(11)
!!       write (*, FMT="('Preferred block size(bytes):', T30, I0)") buff(12)
!!       write (*, FMT="('No. of blocks allocated:',     T30, I0)") buff(13)
!!    endif
!!
!!    end program demo_system_stat
!!
!!   Results:
!!
!!    Device ID(hex/decimal):      3E6BE045h/1047257157d
!!    Inode number:                1407374886070599
!!    File mode (octal):                        100750
!!    Number of links:             1
!!    Owner's uid/username:        18 SYSTEM
!!    Owner's gid/group:           18 SYSTEM
!!    Device where located:        0
!!    File size(bytes):            824
!!    Last access time:            1557983191 2019-05-16 01:06:31
!!    Last modification time:      1557983191 2019-05-16 01:06:31
!!    Last status change time:     1557983532 2019-05-16 01:12:12
!!    Preferred block size(bytes): 65536
!!    No. of blocks allocated:     4
!===================================================================================================================================
subroutine system_stat(pathname,values,ierr)
implicit none

character(len=*),parameter::ident_33="@(#)M_system::system_stat(3f): call stat(3c) to get pathname information"

character(len=*),intent(in)          :: pathname

integer(kind=8),intent(out)          :: values(13)
integer(kind=c_long)                 :: cvalues(13)

integer,optional,intent(out)         :: ierr
integer(kind=c_int)                  :: cierr

interface
   subroutine c_stat(buffer,cvalues,cierr,cdebug) bind(c,name="my_stat")
      import c_char, c_size_t, c_ptr, c_int, c_long
      character(kind=c_char),intent(in)   :: buffer(*)
      integer(kind=c_long),intent(out)    :: cvalues(*)
      integer(kind=c_int)                 :: cierr
      integer(kind=c_int),intent(in)      :: cdebug
   end subroutine c_stat
end interface
!-----------------------------------------------------------------------------------------------------------------------------------
   call c_stat(str2arr(trim(pathname)),cvalues,cierr,0_c_int)
   values=cvalues
   if(present(ierr))then
      ierr=cierr
   endif
end subroutine system_stat
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
end module M_system
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================

This is the C wrappers used by the Fortran module

#include <dirent.h>
#include <errno.h>
#include <fcntl.h>
#include <grp.h>
#include <pwd.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <strings.h>
#include <sys/stat.h>
#include <sys/types.h>
#include <sys/utsname.h>
#include <unistd.h>
#include <utime.h>

#define MIN(x,y)  ((x) < (y) ? (x) : (y))

 extern char **environ;

 extern int FHOST_NAME_MAX;
 int FHOST_NAME_MAX=HOST_NAME_MAX;

 extern mode_t FS_IRGRP;
 extern mode_t FS_IROTH;
 extern mode_t FS_IRUSR;
 extern mode_t FS_IRWXG;
 extern mode_t FS_IRWXO;
 extern mode_t FS_IRWXU;
 extern mode_t FS_IWGRP;
 extern mode_t FS_IWOTH;
 extern mode_t FS_IWUSR;
 extern mode_t FS_IXGRP;
 extern mode_t FS_IXOTH;
 extern mode_t FS_IXUSR;
 extern mode_t FDEFFILEMODE;
 extern mode_t FACCESSPERMS;

  mode_t FS_IRGRP=S_IRGRP;
  mode_t FS_IROTH=S_IROTH;
  mode_t FS_IRUSR=S_IRUSR;
  mode_t FS_IRWXG=S_IRWXG;
  mode_t FS_IRWXO=S_IRWXO;
  mode_t FS_IRWXU=S_IRWXU;
  mode_t FS_IWGRP=S_IWGRP;
  mode_t FS_IWOTH=S_IWOTH;
  mode_t FS_IWUSR=S_IWUSR;
  mode_t FS_IXGRP=S_IXGRP;
  mode_t FS_IXOTH=S_IXOTH;
  mode_t FS_IXUSR=S_IXUSR;
  mode_t FDEFFILEMODE=DEFFILEMODE;
  mode_t FACCESSPERMS=ACCESSPERMS;

char **ep;

extern long int longest_env_variable;
       long int longest_env_variable=0L;
/*--------------------------------------------------------------------------------------------------------------------------------*/
/*
   wrapper around access(3c) for a call from Fortran
*/
int my_access(const char *pathname, int which) {
   int n;
   /*fprintf(stdout," which values = %d %d %d %d %d\n",F_OK,R_OK,W_OK,X_OK,which);*/
   n = access (pathname, which);
   return (n);
}
/*--------------------------------------------------------------------------------------------------------------------------------*/
/* does a recursive mkdir(3c) for a POSIX pathname */
void my_mkdir (char *dir, int mode, int *ier) {
   char *p = NULL;
   char buf[4096];
   size_t len;

   snprintf(buf, sizeof(buf), "%s", dir);
   len = strlen (buf);
   if (buf[len - 1] == '/') {
      buf[len - 1] = 0;
   }
   for (p = buf + 1; *p; p++) {
      if(*p == '/') {
         *p = 0;
         mkdir (buf, mode);
         *p = '/';
      }
   }
   ier=mkdir(buf, mode);
}
/*--------------------------------------------------------------------------------------------------------------------------------*/
/*
   wrapper around utime(3c) for a call from Fortran
*/
int my_utime(const char *file, int times[2]) {
   struct utimbuf ut;
   /* time_t ut[2]; */
   int n;

   ut.actime  = (time_t)times[0];
   ut.modtime = (time_t)times[1];
   n = utime (file, &ut);
   /*
   ut[0] = times[0];
   ut[1] = times[l];
   n = utime (file, ut);
   */
   return (n);
}
/*--------------------------------------------------------------------------------------------------------------------------------*/
/*
   wrapper around chown(3c) for a call from Fortran
*/
int my_chown(char *filename, long long int uid, long long int gid){
   return chown(filename, (uid_t)uid, (gid_t)gid);
}
/*--------------------------------------------------------------------------------------------------------------------------------*/
/*
   wrapper around readdir(3c) for a call from Fortran
*/
void my_readdir(DIR *dirp, char *filename, int *err){

   struct dirent *dp;
   int length;

   err = 0;
   length = 0;

   if ((dp = readdir (dirp)) != NULL) {
      length=(int)strlen(dp->d_name);
      strncpy(filename,dp->d_name,length);
   }else{
      err=&amp;errno; /*When the end of the directory is encountered, a null pointer is returned and errno is not changed.*/
   }
}
/*--------------------------------------------------------------------------------------------------------------------------------*/
/*
   flush stdin and stderr and all files open in C
*/
void my_flush(void){
   fflush(NULL);
   /* For good measure */
   fflush(stdin);
   fflush(stdout);
}
/*--------------------------------------------------------------------------------------------------------------------------------*/
int my_realpath (char *symlinkpath, char *actualpath) {
   int length;
   int ierr;
   char *gotpath;
   gotpath = realpath (symlinkpath, NULL);
   if (gotpath != NULL) {
      /* ... use gotpath ... */
      length = (int) strlen (actualpath);
      *actualpath = malloc(sizeof (gotpath));
      strncpy (actualpath, gotpath, length);
      free (gotpath);
      return (0);
   } else {
      /* ... handle error ... */
      length = (int) strlen (symlinkpath);
      strncpy (actualpath, symlinkpath, length);
      return (-1);
   }
}
/*--------------------------------------------------------------------------------------------------------------------------------*/
/*
   wrapper to step through environment table
*/
/*--------------------------------------------------------------------------------------------------------------------------------*/
void my_initenv(){
/*
   Set pointer into environment table to beginning of table,
   but find longest current variable length so can make buffer
   big enough by scanning current table. There is probably a
   C variable that defines this length; but hopefully this
   entire method of reading the environment table will be
   superseded if I can figure out what is wrong with the
   version that returns an arbitrary string length directly.
   See:
      xargs --show-limits
*/
long int newlength;
   ep=environ;
   longest_env_variable=4096;
   while ((*ep)){
      newlength=(long int)strlen(*ep);
      if(newlength > longest_env_variable){
         longest_env_variable=newlength;
      }
      *ep++;
   }
   ep=environ;
}
/*--------------------------------------------------------------------------------------------------------------------------------*/
void my_readenv(char *variable){
size_t length_in;
size_t length_out;
size_t length_copy;
   if ( *ep == NULL ){
      strncpy(variable,"",1);
      /*
      fprintf(stdout,"%s [%s]\n","REWIND TABLE",variable);
      */
      my_initenv();                                  /* reset pointer to start of table */
   }else{
      length_in=strlen(variable);
      length_out=strlen(*ep);
      length_copy=MIN(length_in,length_out);

      strncpy(variable,*ep,length_copy);
      *ep++;
   }
}
/*--------------------------------------------------------------------------------------------------------------------------------*/
int my_getgrgid(long long int id, char *groupname){
struct group *grp;

   errno = 0;

   if ( (grp = getgrgid((gid_t)id) ) != NULL) {
      strcpy(groupname,grp->gr_name);
   } else {
      strncpy(groupname,"",1);
      perror("getgrgid");
   }
   return errno;
}
/*--------------------------------------------------------------------------------------------------------------------------------*/
int my_getpwuid(long long int id, char *username){
struct passwd *pwd;

   errno = 0;

   if ( (pwd = getpwuid((uid_t)id) ) != NULL) {
      strcpy(username,pwd->pw_name);
   } else {
      strncpy(username,"",1);
      perror("getpwuid");
   }
   return errno;
}
/*--------------------------------------------------------------------------------------------------------------------------------*/
/*
  return last error number for functions that explicitly state they set it
  use a function as this might be a macro
*/
int my_errno() {
return(errno);
}
/*--------------------------------------------------------------------------------------------------------------------------------*/
void system_unbuffer() {
/*
   This routine turns off buffering of standard input so that Kevin
   Serafini can control both input and output so that he can control
   USH from the xush(1) X11 windows GUI program using forked pipes
*/
        char ident[] = "@(#)system_unbuffer(3c): FORTRAN-callable call to turn off buffering of stdin";

        if( setvbuf( stdin, NULL, _IOLBF, 0 ) != 0 ) {
                perror( "setvbuf" );
                exit(5);
        }
        if( setvbuf( stdout, NULL, _IOLBF, 0 ) != 0 ) {
                perror( "setvbuf" );
                exit(5);
        }
        fprintf(stderr, "IN THE BUFF!\n");
}
/*--------------------------------------------------------------------------------------------------------------------------------*/
/*
   my_uname -- return system information from uname(3c) to Fortran subroutine
*/
void my_uname (char *which, char *string, int *stringlen) {
   struct utsname name;
   int i;
   int j;
   if (uname (&name) == -1) {
      fprintf (stderr, "*my_uname* cannot get system name\n");
      strncpy (string, "UNKNOWN", *stringlen);
   } else {
      switch (*which) {
      case 's': strncpy (string, name.sysname, *stringlen);
         break;
      case 'n': strncpy (string, name.nodename, *stringlen);
         break;
      case 'r': strncpy (string, name.release, *stringlen);
         break;
      case 'v': strncpy (string, name.version, *stringlen);
         break;
      case 'm': strncpy (string, name.machine, *stringlen);
         break;
      case 'T':
         fprintf (stderr, "*my_uname* sysname:  %s\n", name.sysname);
         fprintf (stderr, "*my_uname* nodename: %s\n", name.nodename);
         fprintf (stderr, "*my_uname* release:  %s\n", name.release);
         fprintf (stderr, "*my_uname* version:  %s\n", name.version);
         fprintf (stderr, "*my_uname* machine:  %s\n", name.machine);
         strncpy (string, "", *stringlen);
         break;
      default:
         fprintf (stderr, "*my_uname* error: unknown switch %c \n",
                  *which);
         fprintf (stderr, "*my_uname* my_uname:%s:%c:%d\n", string, *which,
                  *stringlen);
         strncpy (string, "UNKNOWN", *stringlen);
      }
   }
   /*
      remove null string terminator and fill string with blanks for Fortran
      */
   for (j = strlen (string); j < *stringlen; j++) {
      string[j] = ' ';
   }
}
/*--------------------------------------------------------------------------------------------------------------------------------*/
/*
   Use unix routine times(3c) to measure user execution time between
   calls in seconds.
*/

void my_cpu_time( float *c, float *u, float *s ){
#include <sys/times.h>
#include <sys/param.h>
   clock_t t;
   struct tms mytime;

   t = times (&mytime);                              /* call "times" */
   *u = ((float) mytime.tms_utime) / ((float) HZ);   /* user time in 1/HZ seconds is in tms_utime */
   *s = ((float) mytime.tms_stime) / ((float) HZ);   /* HZ is in sys/param.h */
   *c = *u + *s;
   return;
}
/*--------------------------------------------------------------------------------------------------------------------------------*/
/* ===============================================================================================================================*/
/*
 *  Decides whether a given file name is a directory.
 *  return 1 if file exists and is a directory
 */
int my_isdir (const char *path) {
   struct stat sb;
   return stat(path, &sb) == 0 && S_ISDIR (sb.st_mode);
}
/* ===============================================================================================================================*/
/* Check for regular file. */
int my_isreg (const char *path) {
   struct stat sb;
   return stat(path, &sb) == 0 && S_ISREG (sb.st_mode);
}
/* ===============================================================================================================================*/
/* determine if filename is a block device */
int my_isblk(const char *path){
   struct stat sb;
   return stat(path, &sb) == 0 && S_ISBLK (sb.st_mode);
}
/* ===============================================================================================================================*/
/* determine if filename is a character device */
int my_ischr(const char *path){
   struct stat sb;
   return stat(path, &sb) == 0 && S_ISCHR (sb.st_mode);
}
/* ===============================================================================================================================*/
/* determine if filename is a fifo - named pipe */
int my_isfifo(const char *path){
   struct stat sb;
   return stat(path, &sb) == 0 && S_ISFIFO (sb.st_mode);
}
/* ===============================================================================================================================*/
/* determine if filename is a socket */
int my_issock(const char *path){
   struct stat sb;
   return stat(path, &sb) == 0 && S_ISSOCK (sb.st_mode);
}
/* ===============================================================================================================================*/
/*
 * Decides whether a given file name is a symbolic link.
 * return 1 if file exists and is a symlink, 0 otherwise.
 */
int my_islnk(const char *fname) {
  struct stat statbuf;

  if (lstat(fname, &statbuf)) {
    return 0;
  } else {
    return S_ISLNK(statbuf.st_mode);
  }
}
/* ===============================================================================================================================*/
/*
 * Checks whether a given file exists.
 * return 1 if file exists, 0 otherwise.
 */
int my_file_exists(const char *fname) {
  struct stat statbuf;
  return !stat(fname, &statbuf);
}
/* ===============================================================================================================================*/
#include <grp.h>
#include <time.h>
#include <locale.h>
#include <langinfo.h>
#include <stdint.h>

void my_stat(char *file,long int *values, int *ierr, int debug){
long long size;                                                           /* st_size can be a 64-bit int.         */
struct stat *buf = malloc (sizeof (struct stat));                         /* allocates memory for stat structure. */
struct passwd *pwd;
struct group *grp;
struct tm *tm;
char datestring[256];
static char local_buff[17] = { 0 };
int i;

   errno = 0;                                                              /* always set errno to zero first.      */
   if (stat (file, buf) != 0) {
      perror (file);                                                       /* if stat fails, print a diagnostic. */
      *ierr=1;
      return;
   }

   *ierr=0;
   values[0]=buf->st_dev;                      /* st_dev    device file currently resides on. */
   values[1]=buf->st_ino;                      /* st_ino    The inode for the file */
   values[2]=buf->st_mode;                     /* st_mode   The current permissions on the file. */
   values[3]=buf->st_nlink;                    /* st_nlink  number of links to this file. */
   values[4]=buf->st_uid ;                     /* st_uid    The User ID for the file. */
   values[5]=buf->st_gid ;                     /* st_gid    The Group ID for the file. */
   values[6]=buf->st_rdev;                     /* st_rdev   ID of device containing directory entry for file (0 if not available) */
   values[7]=buf->st_size;                     /* st_size   file size in bytes */
   values[8]=buf->st_atime+0.5;                /* st_atime  most recent time file was accessed. */
   values[9]=buf->st_mtime+0.5;                /* st_mtime  most recent time file contents modified. */
   values[10]=buf->st_ctime+0.5;               /* st_ctime  most recent time file permissions changed. */
   values[11]=buf->st_blksize;                 /*           Preferred I/O block size (-1 if not available) */
   values[12]=buf->st_blocks;                  /*           Number of blocks allocated (-1 if not available) */

   if(debug==0){
   printf("Information for %s ",file);
   printf("(The file %s a symbolic link)\n", (S_ISLNK(buf->st_mode)) ? "is" : "is not");
   printf("---------------------------\n");
   printf("File Size ........................ %jd bytes\n",(intmax_t)buf->st_size);  /* st_size      file size in bytes */
   printf("Number of Links .................. %d\n",buf->st_nlink);        /* st_nlink     number of links to this file. */
   printf("File inode ....................... %ld\n",buf->st_ino);          /* st_ino       The inode for the file */

   i=0;
/*
  This varies, but at least one ls(1) command uses this convention:

  The file type is one of the following characters:
       -    regular file
       b    block special file
       c    character special file
       C    high performance (   contiguous data   ) file
       d    directory
       D    door (Solaris 2.5 and up)
       l    symbolic link
       M    off-line (   migrated   ) file (Cray DMF)
       n    network special file (HP-UX)
       p    FIFO (named pipe)
       P    port (Solaris 10 and up)
       s    socket
       ?    some other file type
  The file mode bits listed are similar to symbolic mode specifications (*note Symbolic Modes::). But ls(1) combines
  multiple bits into the third character of each set of permissions as follows:
       s    If the set-user-ID or set-group-ID bit and the corresponding executable bit are both set.
       S    If the set-user-ID or set-group-ID bit is set but the corresponding executable bit is not set.
       t    If the restricted deletion flag or sticky bit, and the other-executable bit, are both set. The restricted deletion
        flag is another name for the sticky bit.  *Note Mode Structure::.
       T    If the restricted deletion flag or sticky bit is set but the other-executable bit is not set.
       x    If the executable bit is set and none of the above apply.
       -    Otherwise.
  Following the file mode bits is a single character that specifies
  whether an alternate access method such as an access control list
  applies to the file. When the character following the file mode
  bits is a space, there is no alternate access method. When it is a
  printing character, then there is such a method.

  GNU ls(1) uses a . character to indicate a file with a security context, but no other alternate access method.

  A file with any other combination of alternate access methods is marked with a    +    character.

*/
   if( S_ISDIR(buf->st_mode) ){                               /* st_mode      The current permissions on the file. */
       local_buff[i]='d';
   }else if( S_ISCHR(buf->st_mode) ){
       local_buff[i]='c';
   }else if( S_ISLNK(buf->st_mode) ){
       local_buff[i]='l';
   }else if( S_ISBLK(buf->st_mode) ){
       local_buff[i]='b';
   }else if( S_ISFIFO(buf->st_mode) ){
       local_buff[i]='p';
   }else if( S_ISSOCK(buf->st_mode) ){
       local_buff[i]='s';
   }else if( S_ISREG(buf->st_mode) ){
       local_buff[i]='-';
   }else{
       local_buff[i]='?';
   }
   i++;
   local_buff[i]=(buf->st_mode & S_IRUSR) ? 'r' : '-'; i++;
   local_buff[i]=(buf->st_mode & S_IWUSR) ? 'w' : '-'; i++;
   local_buff[i]=(buf->st_mode & S_IXUSR) ? 'x' : '-'; i++;
   local_buff[i]=(buf->st_mode & S_IRGRP) ? 'r' : '-'; i++;
   local_buff[i]=(buf->st_mode & S_IWGRP) ? 'w' : '-'; i++;
   local_buff[i]=(buf->st_mode & S_IXGRP) ? 'x' : '-'; i++;
   local_buff[i]=(buf->st_mode & S_IROTH) ? 'r' : '-'; i++;
   local_buff[i]=(buf->st_mode & S_IWOTH) ? 'w' : '-'; i++;
   local_buff[i]=(buf->st_mode & S_IXOTH) ? 'x' : '-'; i++;
   local_buff[i]='\0';
   printf("File Permissions ................. %s\n",local_buff);
   printf ("Owner ID ........................ %-8d\n", buf->st_uid);

                                                                          /* Print out owner name if found using getpwuid(). */
   if ((pwd = getpwuid (buf->st_uid)) != NULL){                           /* st_uid          The User ID for the file. */
      printf ("Owner ........................... %-8s\n", pwd->pw_name);
   }
   printf ("Owner ID ........................ %-8d\n", buf->st_uid);
                                                                          /* Print out group name if found using getgrgid(). */
   if ((grp = getgrgid (buf->st_gid)) != NULL){                           /* st_gid          The Group ID for the file. */
      printf ("Group name ...................... %-8s\n", grp->gr_name);
   }
   printf ("Group ID ........................ %-8d\n", buf->st_gid);

   tm = localtime (&buf->st_mtime);                                       /* st_mtime  most recent time file contents modified. */
   strftime (datestring, sizeof (datestring), nl_langinfo (D_T_FMT), tm); /* Get localized date string. */
   printf ("file contents last modified ..... %s\n", datestring );

   tm = localtime (&buf->st_atime);                                       /* st_atime  most recent time file was accessed. */
   strftime (datestring, sizeof (datestring), nl_langinfo (D_T_FMT), tm); /* Get localized date string. */
   printf ("file contents last accessed ..... %s\n", datestring );

   tm = localtime (&buf->st_ctime);                                       /* st_ctime  most recent time file permissions changed. */
   strftime (datestring, sizeof (datestring), nl_langinfo (D_T_FMT), tm); /* Get localized date string. */
   printf ("file permissions last changed ... %s\n", datestring );

   printf ("device .......................... %ld\n", buf->st_dev);       /* st_dev   device file currently resides on. */
   }
}
/* ===============================================================================================================================*/
/*
int main () {
   printf ("input.txt is a regular file?  %s\n",
           check_reg ("input.txt") ? "yes" : "no");
   printf ("docs is a directory?  %s\n", check_dir ("docs") ? "yes" : "no");
   printf ("/input.txt is a regular file?  %s\n",
           check_reg ("/input.txt") ? "yes" : "no");
   printf ("/docs is a directory?  %s\n", check_dir ("/docs") ? "yes" : "no");
   return 0;
}
*/
/* ===============================================================================================================================*/
const char *my_get_perm(long int imode){
static char perms_buff[15];
char ftype = '?';
mode_t mode;

   mode=(mode_t) imode;
   if (S_ISREG(mode))  ftype = '-';
   if (S_ISLNK(mode))  ftype = 'l';
   if (S_ISDIR(mode))  ftype = 'd';
   if (S_ISBLK(mode))  ftype = 'b';
   if (S_ISCHR(mode))  ftype = 'c';
   if (S_ISFIFO(mode)) ftype = 'p';
#ifdef S_ISDOOR
   if (S_ISDOOR(mode)) ftype = 'D'; /* Solaris 2.6, etc. */
#endif

   sprintf(perms_buff, "%c%c%c%c%c%c%c%c%c%c %c%c%c",
      ftype,
      mode &  S_IRUSR ? 'r' : '-',
      mode &  S_IWUSR ? 'w' : '-',
      mode &  S_IXUSR ? 'x' : '-',

      mode &  S_IRGRP ? 'r' : '-',
      mode &  S_IWGRP ? 'w' : '-',
      mode &  S_IXGRP ? 'x' : '-',

      mode &  S_IROTH ? 'r' : '-',
      mode &  S_IWOTH ? 'w' : '-',
      mode &  S_IXOTH ? 'x' : '-',

      mode &  S_ISUID ? 'U' : '-',
      mode &  S_ISGID ? 'G' : '-',
      mode &  S_ISVTX ? 'S' : '-');

   return perms_buff;
}
/* ===============================================================================================================================*/
/*
   To get stream I/O out of stdin and stdout, make a getc and putc callable from Fortran
*/
char getkeyC (void) {
   /* @(#) Driver for reading a character from stdin */
   char c;
   read (0, &c, 1);
   return (c);
}

int putkeyC (char c) {
   /* @(#) Driver for writing a character to stdout */
   write (1, &c, 1);
   return (c);
}
/* ===============================================================================================================================*/

A program that calls each public procedure in the module. Basically, this is a copy of example programs from the comments for demonstation purposes, not a unit test of the module.

program testit
write(*,*)  'demo_system_srand()';              call  demo_system_srand()
write(*,*)  'demo_system_kill()';               call  demo_system_kill()
write(*,*)  'demo_system_errno()';              call  demo_system_errno()
write(*,*)  'demo_system_geteuid()';            call  demo_system_geteuid()
write(*,*)  'demo_system_getuid()';             call  demo_system_getuid()
write(*,*)  'demo_system_getegid()';            call  demo_system_getegid()
write(*,*)  'demo_system_getgid()';             call  demo_system_getgid()
write(*,*)  'demo_system_getsid()';             call  demo_system_getsid()
write(*,*)  'demo_system_getpid()';             call  demo_system_getpid()
write(*,*)  'demo_system_getppid()';            call  demo_system_getppid()
write(*,*)  'demo_system_rand()';               call  demo_system_rand()
write(*,*)  'demo_system_initenv()';            call  demo_system_initenv()
write(*,*)  'demo_system_access()';             call  demo_system_access()
write(*,*)  'demo_system_realpath()';           call  demo_system_realpath()
write(*,*)  'demo_system_issock()';             call  demo_system_issock()
write(*,*)  'demo_system_isfifo()';             call  demo_system_isfifo()
write(*,*)  'demo_system_ischr()';              call  demo_system_ischr()
write(*,*)  'demo_system_isreg()';              call  demo_system_isreg()
write(*,*)  'demo_system_islnk()';              call  demo_system_islnk()
write(*,*)  'demo_system_isblk()';              call  demo_system_isblk()
write(*,*)  'demo_system_chown()';              call  demo_system_chown()
write(*,*)  'demo_system_isdir()';              call  demo_system_isdir()
write(*,*)  'demo_system_cpu_time()';           call  demo_system_cpu_time()
write(*,*)  'demo_system_link()';               call  demo_system_link()
write(*,*)  'demo_system_unlink()';             call  demo_system_unlink()
write(*,*)  'demo_system_perror()';             call  demo_system_perror()
write(*,*)  'demo_system_chdir()';              call  demo_system_chdir()
write(*,*)  'demo_system_remove()';             call  demo_system_remove()
write(*,*)  'demo_system_rename()';             call  demo_system_rename()
write(*,*)  'demo_system_getcwd()';             call  demo_system_getcwd()
write(*,*)  'demo_system_rmdir()';              call  demo_system_rmdir()
write(*,*)  'demo_system_mkfifo()';             call  demo_system_mkfifo()
write(*,*)  'demo_system_mkdir()';              call  demo_system_mkdir()
write(*,*)  'demo_system_opendir()';            call  demo_system_opendir()
write(*,*)  'demo_system_readdir()';            call  demo_system_readdir()
write(*,*)  'demo_system_rewinddir()';          call  demo_system_rewinddir()
write(*,*)  'demo_system_closedir()';           call  demo_system_closedir()
write(*,*)  'demo_system_putenv()';             call  demo_system_putenv()
write(*,*)  'demo_system_getenv()';             call  demo_system_getenv()
write(*,*)  'demo_set_environment_variable()';  call  demo_set_environment_variable()
write(*,*)  'demo_system_clearenv()';           call  demo_system_clearenv()
write(*,*)  'demo_system_unsetenv()';           call  demo_system_unsetenv()
write(*,*)  'demo_system_readenv()';            call  demo_system_readenv()
write(*,*)  'demo_system_uname()';              call  demo_system_uname()
write(*,*)  'demo_system_gethostname()';        call  demo_system_gethostname()
write(*,*)  'demo_system_getlogin()';           call  demo_system_getlogin()
write(*,*)  'demo_system_perm()';               call  demo_system_perm()
write(*,*)  'demo_system_getgrgid()';           call  demo_system_getgrgid()
write(*,*)  'demo_system_getpwuid()';           call  demo_system_getpwuid()
write(*,*)  'demo_system_stat()';               call  demo_system_stat()
write(*,*)  'demo_setumask()';                  call  demo_setumask()
write(*,*)  'demo_getumask()';                  call  demo_getumask()
write(*,*)  'demo_system_chmod()';              call  demo_system_chmod()
contains
subroutine demo_system_srand
   use M_system, only : system_srand, system_rand
   implicit none
   integer :: i,j
   do j=1,2
      call system_srand(1001)
      do i=1,10
         write(*,*)system_rand()
      enddo
      write(*,*)
   enddo
end subroutine demo_system_srand
subroutine demo_system_kill
   use M_system, only : system_kill
   use M_system, only : system_perror
   implicit none
   integer           :: i,pid,ios,ierr,signal=9
   character(len=80) :: argument

   do i=1,command_argument_count()
! get arguments from command line
      call get_command_argument(i, argument)
! convert arguments to integers assuming they are PID numbers
      read(argument,'(i80)',iostat=ios) pid
      if(ios.ne.0)then
         write(*,*)'bad PID=',trim(argument)
      else
         write(*,*)'kill SIGNAL=',signal,' PID=',pid
! send signal SIGNAL to pid PID
         ierr=system_kill(pid,signal)
! write message if an error was detected
         if(ierr.ne.0)then
            call system_perror('*demo_system_kill*')
         endif
      endif
   enddo
end subroutine demo_system_kill
subroutine demo_system_errno
   use M_system, only: system_errno, system_unlink, system_perror
   implicit none
   integer :: stat
   stat=system_unlink('not there/OR/anywhere')
   if(stat.ne.0)then
      write(*,*)'err=',system_errno()
      call system_perror('*demo_system_errno*')
   endif
end subroutine demo_system_errno
subroutine demo_system_geteuid
   use M_system, only: system_geteuid
   implicit none
   write(*,*)'EFFECTIVE UID=',system_geteuid()
end subroutine demo_system_geteuid
subroutine demo_system_getuid
   use M_system, only: system_getuid
   implicit none
   write(*,*)'UID=',system_getuid()
end subroutine demo_system_getuid
subroutine demo_system_getegid
   use M_system, only: system_getegid
   implicit none
   write(*,*)'GID=',system_getegid()
end subroutine demo_system_getegid
subroutine demo_system_getgid
   use M_system, only: system_getgid
   implicit none
   write(*,*)'GID=',system_getgid()
end subroutine demo_system_getgid
subroutine demo_system_getsid
   use M_system,      only : system_getsid
   use ISO_C_BINDING, only : c_int
   implicit none
   write(*,*)'SID=',system_getsid(0_c_int)
end subroutine demo_system_getsid
subroutine demo_system_getpid
   use M_system, only: system_getpid
   implicit none
   write(*,*)'PID=',system_getpid()
end subroutine demo_system_getpid
subroutine demo_system_getppid
   use M_system, only: system_getppid
   implicit none
   write(*,*)'PPID=',system_getppid()
end subroutine demo_system_getppid

subroutine demo_system_rand
   use M_system, only : system_srand, system_rand
   implicit none
   integer :: i

   call system_srand(1001)
   do i=1,10
      write(*,*)system_rand()
   enddo
   write(*,*)

end subroutine demo_system_rand
subroutine demo_system_initenv
   use M_system, only : system_initenv, system_readenv
   character(len=:),allocatable :: string
   call system_initenv()
   do
      string=system_readenv()
      if(string.eq.'')then
         exit
      else
         write(*,'(a)')string
      endif
   enddo
end subroutine demo_system_initenv
subroutine demo_system_access
   Use M_system, only : system_access, F_OK, R_OK, W_OK, X_OK
   implicit none
   integer                     :: i
   character(len=80),parameter :: names(*)=[ &
      '/usr/bin/bash   ', &
      '/tmp/NOTTHERE   ', &
      '/usr/local      ', &
      '.               ', &
      'PROBABLY_NOT    ']
   do i=1,size(names)
      write(*,*)' does ',trim(names(i)),' exist?    ', system_access(names(i),F_OK)
      write(*,*)' is ',trim(names(i)),' readable?     ', system_access(names(i),R_OK)
      write(*,*)' is ',trim(names(i)),' writeable?    ', system_access(names(i),W_OK)
      write(*,*)' is ',trim(names(i)),' executable?   ', system_access(names(i),X_OK)
   enddo
end subroutine demo_system_access
subroutine demo_system_realpath
   use M_system, only : system_realpath, system_perror
   implicit none
! resolve each pathname given on command line
   character(len=:),allocatable :: pathi,patho
   integer                      :: i
   integer                      :: filename_length
   integer                      :: ierr
   do i = 1, command_argument_count()
! get pathname from command line arguments
      call get_command_argument (i , length=filename_length)
      allocate(character(len=filename_length) :: pathi)
      call get_command_argument (i , value=pathi)
!
! resolve each pathname
      call system_realpath(pathi,patho,ierr)
      if(ierr.eq.0)then
         write(*,*)trim(pathi),'=>',trim(patho)
      else
         call system_perror('*system_realpath* error for pathname '//trim(pathi)//':')
         write(*,*)trim(pathi),'=>',trim(patho)
      endif
      deallocate(pathi)
   enddo
! if there were no pathnames give resolve the pathname "."
   if(i.eq.1)then
      call system_realpath('.',patho,ierr)
      write(*,*)'.=>',trim(patho)
   endif
end subroutine demo_system_realpath
subroutine demo_system_issock
   Use M_system, only : system_issock
   implicit none
   integer                     :: i
   character(len=80),parameter :: names(*)=[ &
      '/tmp            ', &
      '/tmp/NOTTHERE   ', &
      '/usr/local      ', &
      '.               ', &
      'sock.test       ', &
      'PROBABLY_NOT    ']
   do i=1,size(names)
      write(*,*)' is ',trim(names(i)),' a socket? ', system_issock(names(i))
   enddo
end subroutine demo_system_issock
subroutine demo_system_isfifo
   Use M_system, only : system_isfifo
   implicit none
   integer                     :: i
   character(len=80),parameter :: names(*)=[ &
      '/tmp            ', &
      '/tmp/NOTTHERE   ', &
      '/usr/local      ', &
      '.               ', &
      'fifo.test       ', &
      'PROBABLY_NOT    ']
   do i=1,size(names)
      write(*,*)' is ',trim(names(i)),' a fifo(named pipe)? ', system_isfifo(names(i))
   enddo
end subroutine demo_system_isfifo
subroutine demo_system_ischr
   Use M_system, only : system_ischr
   implicit none
   integer                     :: i
   character(len=80),parameter :: names(*)=[ &
      '/tmp            ', &
      '/tmp/NOTTHERE   ', &
      '/usr/local      ', &
      '.               ', &
      'char_dev.test   ', &
      'PROBABLY_NOT    ']
   do i=1,size(names)
      write(*,*)' is ',trim(names(i)),' a character device? ', system_ischr(names(i))
   enddo
end subroutine demo_system_ischr
subroutine demo_system_isreg
   Use M_system, only : system_isreg
   implicit none
   integer                     :: i
   character(len=80),parameter :: names(*)=[ &
      '/tmp            ', &
      'test.txt        ', &
      '.               ']
   do i=1,size(names)
      write(*,*)' is ',trim(names(i)),' a regular file? ', system_isreg(names(i))
   enddo
end subroutine demo_system_isreg
subroutine demo_system_islnk
   Use M_system, only : system_islnk
   implicit none
   integer                     :: i
   character(len=80),parameter :: names(*)=[ &
      '/tmp            ', &
      '/tmp/NOTTHERE   ', &
      '/usr/local      ', &
      '.               ', &
      'link.test       ', &
      'PROBABLY_NOT    ']
   do i=1,size(names)
      write(*,*)' is ',trim(names(i)),' a link? ', system_islnk(names(i))
   enddo
end subroutine demo_system_islnk
subroutine demo_system_isblk
   Use M_system, only : system_isblk
   implicit none
   integer                     :: i
   character(len=80),parameter :: names(*)=[ &
      '/tmp            ', &
      '/tmp/NOTTHERE   ', &
      '/usr/local      ', &
      '.               ', &
      'block_device.tst', &
      'PROBABLY_NOT    ']
   do i=1,size(names)
      write(*,*)' is ',trim(names(i)),' a block device? ', system_isblk(names(i))
   enddo
end subroutine demo_system_isblk
subroutine demo_system_chown
   Use M_system, only : system_chown
   Use M_system, only : system_getuid
   Use M_system, only : system_getgid
   use M_system, only : system_perror
   implicit none
   integer                     :: i
   character(len=80),parameter :: names(*)=[character(len=80) :: 'myfile1','/usr/local']
   do i=1,size(names)
      if(.not.  system_chown(&
      & trim(names(i)),  &
      & system_getuid(), &
      & system_getgid()) &
         )then
         call system_perror('*demo_system_chown* '//trim(names(i)))
      endif
   enddo
end subroutine demo_system_chown
subroutine demo_system_isdir
   Use M_system, only : system_isdir
   implicit none
   integer                     :: i
   character(len=80),parameter :: names(*)=[ &
      '/tmp            ', &
      '/tmp/NOTTHERE   ', &
      '/usr/local      ', &
      '.               ', &
      'PROBABLY_NOT    ']
   do i=1,size(names)
      write(*,*)' is ',trim(names(i)),' a directory? ', system_isdir(names(i))
   enddo
end subroutine demo_system_isdir
subroutine demo_system_cpu_time

   use M_system, only : system_cpu_time
   use ISO_C_BINDING, only : c_float
   implicit none
   real    :: user_start, system_start, total_start
   real    :: user_finish, system_finish, total_finish
   integer :: i
   real    :: value

   call system_cpu_time(total_start,user_start,system_start)

   value=0.0
   do i=1,1000000
      value=sqrt(real(i)+value)
   enddo
   write(*,*)'average sqrt value=',value/1000000.0
   call system_cpu_time(total_finish,user_finish,system_finish)
   write(*,*)'USER ......',user_finish-user_start
   write(*,*)'SYSTEM ....',system_finish-system_start
   write(*,*)'TOTAL .....',total_finish-total_start

end subroutine demo_system_cpu_time
subroutine demo_system_link
   use M_system, only : system_link, system_perror
   ierr = system_link('myfile1','myfile2')
   if(ierr.ne.0)then
      call system_perror('*demo_system_link*')
   endif
end subroutine demo_system_link
subroutine demo_system_unlink
   use M_system, only : system_unlink, system_perror
   ierr = system_unlink('myfile1')
   if(ierr.ne.0)then
      call system_perror('*demo_system_unlink*')
   endif
end subroutine demo_system_unlink
subroutine demo_setumask
   use M_system, only : system_getumask, system_setumask
   integer :: newmask
   write(*,101)(system_getumask(),i=1,4)
101 format(1x,i0,1x,"O'",o4.4,"'",1x,'Z"',z0,"'",1x,"B'",b12.12,"'")
   newmask=63
   old_umask=system_setumask(newmask)
   write(*,*)'NEW'
   write(*,101)(system_getumask(),i=1,4)
end subroutine demo_setumask
subroutine demo_getumask
   use M_system, only : system_getumask, system_setumask
   integer :: newmask
   write(*,101)(system_getumask(),i=1,4)
101 format(1x,i0,1x,"O'",o4.4,"'",1x,'Z"',z0,"'",1x,"B'",b12.12,"'")
end subroutine demo_getumask
subroutine demo_system_perror
   use M_system, only : system_perror,system_rmdir
   implicit none
   character(len=:),allocatable :: DIRNAME
   DIRNAME='/NOT/THERE/OR/ANYWHERE'
! generate an error with a routine that supports errno and perror(3c)
   if(system_rmdir(DIRNAME).ne.0)then
      call system_perror('*demo_system_perror*:'//DIRNAME)
   endif
   write(*,'(a)')"That's all Folks!"
end subroutine demo_system_perror
subroutine demo_system_chdir
   use M_system, only : system_chdir
   implicit none
   integer :: ierr

   call execute_command_line('pwd')
   call system_chdir('/tmp',ierr)
   call execute_command_line('pwd')
   write(*,*)'*CHDIR TEST* IERR=',ierr

end subroutine demo_system_chdir
subroutine demo_system_remove
   use M_system, only : system_remove
   character(len=*),parameter :: FILE='MyJunkFile.txt'
   write(*,*)'BEFORE CREATED '//FILE
   call execute_command_line('ls -l '//FILE)
   write(*,*)

! note intentionally causes error if file exists
   open(unit=10,file=FILE,status='NEW')
   write(*,*)'AFTER OPENED '//FILE
   call execute_command_line('ls -l '//FILE)
   write(*,*)

   write(10,'(a)') 'This is a file I want to delete'
   close(unit=10)
   write(*,*)'AFTER CLOSED '
   call execute_command_line('ls -l '//FILE)
   write(*,*)

   ierr=system_remove(FILE)
   write(*,*)'AFTER REMOVED',IERR
   call execute_command_line('ls -l '//FILE)
   write(*,*)
   close(unit=10)

end subroutine demo_system_remove
subroutine demo_system_rename
   use M_system, only : system_rename
   use M_system, only : system_remove
   use M_system, only : system_perror
   implicit none
   character(len=256) :: string
   integer            :: ios, ierr

! try to remove junk files just in case
   ierr=system_remove('_scratch_file_')
   write(*,'(a,i0)') 'should not be zero ',ierr
   call system_perror('*demo_system_rename*')
   ierr=system_remove('_renamed_scratch_file_')
   write(*,'(a,i0)') 'should not be zero ',ierr
   call system_perror('*demo_system_rename*')

! create scratch file to rename
   open(unit=10,file='_scratch_file_',status='new')
   write(10,'(a)') 'Test by renaming "_scratch_file_" to "_renamed_scratch_file_"'
   write(10,'(a)') 'IF YOU SEE THIS ON OUTPUT THE RENAME WORKED'
   close(unit=10)
! rename scratch file
   ierr=system_rename('_scratch_file_','_renamed_scratch_file_')
   if(ierr.ne.0)then
      write(*,*)'ERROR RENAMING FILE ',ierr
   endif
! read renamed file
   open(unit=11,file='_renamed_scratch_file_',status='old')
   INFINITE: do
      read(11,'(a)',iostat=ios)string
      if(ios.ne.0)exit INFINITE
      write(*,'(a)')trim(string)
   enddo INFINITE
   close(unit=11)

! clean up
   ierr=system_remove('_scratch_file_')
   write(*,'(a,i0)') 'should not be zero ',ierr
   ierr=system_remove('_renamed_scratch_file_')
   write(*,'(a,i0)') 'should be zero ',ierr

end subroutine demo_system_rename
subroutine demo_system_chmod
   use M_system, only : system_chmod
   use M_system, only : system_stat
   use M_system, only : R_GRP,R_OTH,R_USR,R_WXG,R_WXO
   use M_system, only : R_WXU,W_GRP,W_OTH,W_USR,X_GRP,X_OTH,X_USR
   use M_system, only : DEFFILEMODE, ACCESSPERMS
   implicit none
   integer         :: ierr
   integer         :: status
   integer(kind=8) :: buffer(13)
   integer         :: ios
   character(len=4096) :: message

!Setting Read Permissions for User, Group, and Others
! The following example sets read permissions for the owner, group, and others.
   open(file='_test1',unit=10)
   write(10,*,iostat=ios,iomsg=message)'TEST FILE 1'
   if(ios.ne.0)then
      write(*,*)trim(message)
   endif

   flush(unit=10,iostat=ios,iomsg=message)
   if(ios.ne.0)then
      write(*,*)trim(message)
   endif

   close(unit=10,iostat=ios,iomsg=message)
   if(ios.ne.0)then
      write(*,*)trim(message)
   endif

   ierr=system_chmod('_test1', IANY([R_USR,R_GRP,R_OTH]))

   open(file='_test1',unit=10)
   close(unit=10,status='delete',iostat=ios,iomsg=message)
   if(ios.ne.0)then
      write(*,*)trim(message)
   endif

!Setting Read, Write, and Execute Permissions for the Owner Only
! The following example sets read, write, and execute permissions for the owner, and no permissions for group and others.
   open(file='_test2',unit=10)
   write(10,*)'TEST FILE 2'
   close(unit=10)
   ierr=system_chmod('_test2', R_WXU)
   open(file='_test2',unit=10)
   close(unit=10,status='delete')

!Setting Different Permissions for Owner, Group, and Other
! The following example sets owner permissions for CHANGEFILE to read, write, and execute, group permissions to read and
! execute, and other permissions to read.
   open(file='_test3',unit=10)
   write(10,*)'TEST FILE 3'
   close(unit=10)
   ierr=system_chmod('_test3', IANY([R_WXU,R_GRP,X_GRP,R_OTH]));
   open(file='_test3',unit=10)
   close(unit=10,status='delete')

!Setting and Checking File Permissions
! The following example sets the file permission bits for a file named /home/cnd/mod1, then calls the stat() function to
! verify the permissions.

   ierr=system_chmod("home/cnd/mod1", IANY([R_WXU,R_WXG,R_OTH,W_OTH]))
   call system_stat("home/cnd/mod1", buffer,status)

! In order to ensure that the S_ISUID and S_ISGID bits are set, an application requiring this should use stat() after a
! successful chmod() to verify this.

!    Any files currently open could possibly become invalid if the mode
!    of the file is changed to a value which would deny access to
!    that process.

end subroutine demo_system_chmod
subroutine demo_system_getcwd
   use M_system, only : system_getcwd
   implicit none
   character(len=:),allocatable :: dirname
   integer                      :: ierr
   call system_getcwd(dirname,ierr)
   if(ierr.eq.0)then
      write(*,*)'CURRENT DIRECTORY ',trim(dirname)
   else
      write(*,*)'ERROR OBTAINING CURRENT DIRECTORY NAME'
   endif
end subroutine demo_system_getcwd
subroutine demo_system_rmdir
   use M_system, only : system_perror
   use M_system, only : system_rmdir, system_mkdir
   implicit none
   integer :: ierr
   write(*,*)'BEFORE TRY TO CREATE _scratch/'
   call execute_command_line('ls -ld _scratch')

   write(*,*)'TRY TO CREATE _scratch/'
   ierr=system_mkdir('_scratch',0+8*0+7)
   write(*,*)'IERR=',ierr
   call execute_command_line('ls -ld _scratch')

   write(*,*)'TRY TO REMOVE _scratch/'
   ierr=system_rmdir('_scratch')
   write(*,*)'IERR=',ierr
   call execute_command_line('ls -ld _scratch')

   write(*,*)'TRY TO REMOVE _scratch when it should be gone/'
   ierr=system_rmdir('_scratch')
   call system_perror('*test of system_rmdir*')
   write(*,*)'IERR=',ierr
   call execute_command_line('ls -ld _scratch')

end subroutine demo_system_rmdir
subroutine demo_system_mkfifo
   use M_system, only : system_mkfifo, system_perror
   use M_system, only : R_GRP,R_OTH,R_USR,R_WXG,R_WXO
   use M_system, only : R_WXU,W_GRP,W_OTH,W_USR,X_GRP,X_OTH,X_USR
   use M_system, only : DEFFILEMODE, ACCESSPERMS
   implicit none
   integer :: status
   status = system_mkfifo("/home/cnd/mod_done", IANY([W_USR, R_USR, R_GRP, R_OTH]))
   if(status.ne.0)then
      call system_perror('*mkfifo* error:')
   endif
end subroutine demo_system_mkfifo
subroutine demo_system_mkdir
   use M_system, only : system_perror
   use M_system, only : system_mkdir
   use M_system, only : R_GRP,R_OTH,R_USR,R_WXG,R_WXO
   use M_system, only : R_WXU,W_GRP,W_OTH,W_USR,X_GRP,X_OTH,X_USR
   use M_system, only : DEFFILEMODE, ACCESSPERMS
   implicit none
   integer :: ierr
   ierr=system_mkdir('_scratch',IANY([R_USR,W_USR,X_USR]))
end subroutine demo_system_mkdir
subroutine demo_system_opendir
   use M_system, only : system_opendir,system_readdir
   use M_system, only : system_closedir
   use iso_c_binding
   implicit none
   type(c_ptr)                  :: dir
   character(len=:),allocatable :: filename
   integer                      :: ierr
!--- open directory stream to read from
   call system_opendir('.',dir,ierr)
!--- read directory stream
   do
      call system_readdir(dir,filename,ierr)
      if(filename.eq.' ')exit
      write(*,*)filename
   enddo
!--- close directory stream
   call system_closedir(dir,ierr)
end subroutine demo_system_opendir
subroutine demo_system_readdir
   use M_system, only : system_opendir,system_readdir
   use M_system, only : system_rewinddir,system_closedir
   use iso_c_binding
   implicit none

   type(c_ptr)                  :: dir
   character(len=:),allocatable :: filename
   integer                      :: i, ierr
!--- open directory stream to read from
   call system_opendir('.',dir,ierr)
!--- read directory stream twice
   do i=1,2
      write(*,'(a,i0)')'PASS ',i
      do
         call system_readdir(dir,filename,ierr)
         if(filename.eq.' ')exit
         write(*,*)filename
      enddo
      call system_rewinddir(dir)
   enddo
!--- close directory stream
   call system_closedir(dir,ierr)

end subroutine demo_system_readdir
subroutine demo_system_rewinddir
   use M_system, only : system_opendir,system_readdir
   use M_system, only : system_rewinddir,system_closedir
   use iso_c_binding
   implicit none

   type(c_ptr)                  :: dir
   character(len=:),allocatable :: filename
   integer                      :: i, ierr
!>>> open directory stream to read from
   call system_opendir('.',dir,ierr)
!>>> read directory stream twice
   do i=1,2
      write(*,'(a,i0)')'PASS ',i
      do
         call system_readdir(dir,filename,ierr)
         if(filename.eq.' ')exit
         write(*,*)filename
      enddo
!>>> rewind directory stream
      call system_rewinddir(dir)
   enddo
!>>> close directory stream
   call system_closedir(dir,ierr)

end subroutine demo_system_rewinddir
subroutine demo_system_closedir
   use M_system, only : system_opendir,system_readdir
   use M_system, only : system_closedir, system_rewinddir
   use iso_c_binding, only : c_ptr
   implicit none
   type(c_ptr)                  :: dir
   character(len=:),allocatable :: filename
   integer                      :: ierr
!--- open directory stream to read from
   call system_opendir('.',dir,ierr)
!--- read directory stream
   do
      call system_readdir(dir,filename,ierr)
      if(filename.eq.' ')exit
      write(*,*)filename
   enddo
   call system_rewinddir(dir)
!--- close directory stream
   call system_closedir(dir,ierr)
end subroutine demo_system_closedir
subroutine demo_system_putenv
   use M_system, only: system_putenv
   use iso_c_binding
   implicit none
   integer :: ierr
!
   write(*,'(a)')'no environment variables containing "GRU":'
   call execute_command_line('env|grep GRU')
!
   call system_putenv('GRU=this is the value',ierr)
   write(*,'(a,i0)')'now "GRU" should be defined: ',ierr
   call execute_command_line('env|grep GRU')
!
   call system_putenv('GRU2=this is the second value',ierr)
   write(*,'(a,i0)')'now "GRU" and "GRU2" should be defined: ',ierr
   call execute_command_line('env|grep GRU')
!
   call system_putenv('GRU2',ierr)
   call system_putenv('GRU',ierr)
   write(*,'(a,i0)')'should be gone, varies with different putenv(3c): ',ierr
   call execute_command_line('env|grep GRU')
   write(*,'(a)')'system_unsetenv(3f) is a better way to remove variables'
!
end subroutine demo_system_putenv
subroutine demo_system_getenv
   use M_system, only: system_getenv
   implicit none
   integer :: ierr

   write(*,'("USER     : ",a)')system_getenv('USER')
   write(*,'("LOGNAME  : ",a)')system_getenv('LOGNAME')
   write(*,'("USERNAME : ",a)')system_getenv('USERNAME')

end subroutine demo_system_getenv
subroutine demo_set_environment_variable
   use M_system, only: set_environment_variable
   use iso_c_binding
   implicit none
   integer :: ierr
!!
   write(*,'(a)')'no environment variables containing "GRU":'
   call execute_command_line('env|grep GRU')
!!
   call set_environment_variable('GRU','this is the value',ierr)
   write(*,'(a,i0)')'now "GRU" should be defined, status=',ierr
   call execute_command_line('env|grep GRU')
!!
   call set_environment_variable('GRU2','this is the second value',ierr)
   write(*,'(a,i0)')'now "GRU" and "GRU2" should be defined, status =',ierr
!!
   call execute_command_line('env|grep GRU')
end subroutine demo_set_environment_variable
subroutine demo_system_clearenv
   use M_system, only : system_clearenv
   implicit none
! environment before clearing
   call execute_command_line('env|wc')
! environment after clearing (not necessarily blank!!)
   call system_clearenv()
   call execute_command_line('env')
end subroutine demo_system_clearenv
subroutine demo_system_unsetenv
   use M_system, only : system_unsetenv, system_putenv
   implicit none
   call system_putenv('GRU=this is the value')
   write(*,'(a)')'The variable GRU should be set'
   call execute_command_line('env|grep GRU')
   call system_unsetenv('GRU')
   write(*,'(a)')'The variable GRU should not be set'
   call execute_command_line('env|grep GRU')
end subroutine demo_system_unsetenv
subroutine demo_system_readenv
   use M_system, only : system_initenv, system_readenv
   character(len=:),allocatable :: string
   call system_initenv()
   do
      string=system_readenv()
      if(string.eq.'')then
         exit
      else
         write(*,'(a)')string
      endif
   enddo
end subroutine demo_system_readenv
subroutine demo_system_uname
   use M_system, only: system_uname
   implicit none
   integer,parameter          :: is=100
   integer                    :: i
   character(len=*),parameter :: letters='srvnmxT'
   character(len=is)          :: string=' '

   do i=1,len(letters)
      write(*,'(80("="))')
      call system_uname(letters(i:i),string)
      write(*,*)'=====> TESTING system_uname('//letters(i:i)//')--->'//trim(string)
   enddo

end subroutine demo_system_uname
subroutine demo_system_gethostname

   use M_system, only : system_gethostname
   implicit none
   character(len=:),allocatable :: name
   integer                      :: ierr

   call system_gethostname(name,ierr)
   if(ierr.eq.0)then
      write(*,'("hostname[",a,"]")')name
   else
      write(*,'(a)')'ERROR: could not get hostname'
   endif

end subroutine demo_system_gethostname
subroutine demo_system_getlogin
   use M_system, only : system_getlogin
   implicit none
   character(len=:),allocatable :: name
   name=system_getlogin()
   write(*,'("login[",a,"]")')name
end subroutine demo_system_getlogin
subroutine demo_system_perm
   use M_system, only : system_perm, system_stat
   implicit none
   character(len=4096) :: string
   integer(kind=8)     :: values(13)
   integer             :: ierr
   character(len=:),allocatable :: perms
   values=0
   call get_command_argument(1, string)  ! get pathname from command line
   call system_stat(string,values,ierr)  ! get pathname information
   if(ierr.eq.0)then
      perms=system_perm(values(3))       ! convert permit mode to a string
! print permits as a string, decimal value, and octal value
      write(*,'("for ",a," permits[",a,"]",1x,i0,1x,o0)') &
         trim(string),perms,values(3),values(3)
   endif
end subroutine demo_system_perm
subroutine demo_system_getgrgid
   use M_system, only : system_getgrgid
   use M_system, only: system_getgid
   implicit none
   integer(kind=8) :: gid
   character(len=:),allocatable :: name
   gid=system_getgid()
   name=system_getgrgid( gid )
   write(*,'("group[",a,"] for ",i0)')name,system_getgid()
end subroutine demo_system_getgrgid


subroutine demo_system_getpwuid
   use M_system, only : system_getpwuid
   use M_system, only: system_getuid
   implicit none
   character(len=:),allocatable :: name
   integer(kind=8)              :: uid
   uid=system_getuid()
   name=system_getpwuid(uid)
   write(*,'("login[",a,"] has UID ",i0)')name,uid
end subroutine demo_system_getpwuid
subroutine demo_system_stat

   use M_system, only : system_stat, system_getpwuid, system_getgrgid
   implicit none

   integer(kind=8)  :: buff(13)
   integer(kind=4)  :: status
   character(len=*),parameter :: fmt_date='year-month-day hour:minute:second'

   integer(kind=8) :: &
      Device_ID,           Inode_number,          File_mode,                  Number_of_links,  Owner_uid,         &
      Owner_gid,           Directory_device,      File_size,                  Last_access,      Last_modification, &
      Last_status_change,  Preferred_block_size,  Number_of_blocks_allocated
   equivalence                                    &
      ( buff(1)  , Device_ID                  ) , &
      ( buff(2)  , Inode_number               ) , &
      ( buff(3)  , File_mode                  ) , &
      ( buff(4)  , Number_of_links            ) , &
      ( buff(5)  , Owner_uid                  ) , &
      ( buff(6)  , Owner_gid                  ) , &
      ( buff(7)  , Directory_device           ) , &
      ( buff(8)  , File_size                  ) , &
      ( buff(9)  , Last_access                ) , &
      ( buff(10) , Last_modification          ) , &
      ( buff(11) , Last_status_change         ) , &
      ( buff(12) , Preferred_block_size       ) , &
      ( buff(13) , Number_of_blocks_allocated )

   CALL SYSTEM_STAT("/etc/hosts", buff, status)

   if (status == 0) then
      write (*, FMT="('Device ID(hex/decimal):',      T30, Z0,'h/',I0,'d')") buff(1),buff(1)
      write (*, FMT="('Inode number:',                T30, I0)") buff(2)
      write (*, FMT="('File mode (octal):',           T30, O19)") buff(3)
      write (*, FMT="('Number of links:',             T30, I0)") buff(4)
      write (*, FMT="('Owner''s uid/username:',       T30, I0,1x, A)") buff(5), system_getpwuid(buff(5))
      write (*, FMT="('Owner''s gid/group:',          T30, I0,1x, A)") buff(6), system_getgrgid(buff(6))
      write (*, FMT="('Device where located:',        T30, I0)") buff(7)
      write (*, FMT="('File size(bytes):',            T30, I0)") buff(8)
      write (*, FMT="('Last access time:',            T30, I0)") buff(9)
      write (*, FMT="('Last modification time:',      T30, I0)") buff(10)
      write (*, FMT="('Last status change time:',     T30, I0)") buff(11)
      write (*, FMT="('Preferred block size(bytes):', T30, I0)") buff(12)
      write (*, FMT="('No. of blocks allocated:',     T30, I0)") buff(13)
   endif

end subroutine demo_system_stat
end program testit

category: code