← Back to branch summary

~siesta-ts/siesta/trunk_ts_soc

« back to all changes in this revision

Viewing changes to Util/JobList/Src/posix_calls.f90

  • Committer: Nils Wittemeier
  • Date: 2019-02-14 07:45:07 UTC
  • mfrom: (746.1.15 trunk)
  • Revision ID: nils@4wittemeier.de-20190214074507-1mvzbmj9kw19gllr
Merged trunk 761

Show diffs side-by-side

added added

removed removed

Lines of Context:
Util/JobList/Src/posix_calls.f90
 
1
module posix_calls
 
2
 
 
3
  public :: system
 
4
  public :: chdir
 
5
  public :: getcwd
 
6
  
 
7
  private
 
8
 
 
9
  CONTAINS
 
10
 
 
11
!! Until we set F2008 as the reference, this is needed for F2003
 
12
 
 
13
subroutine system(str,stat)
 
14
  use iso_c_binding, only: C_CHAR, C_NULL_CHAR, C_INT
 
15
 
 
16
  character(len=*), intent(in)   :: str
 
17
  integer, intent(out), optional :: stat
 
18
   interface
 
19
      integer(c_int) function c_system(string) bind(C,name="system")
 
20
        use iso_c_binding, only: c_char, c_int
 
21
        character(kind=c_char) :: string(*)
 
22
      end function c_system
 
23
   end interface
 
24
 
 
25
   integer(C_INT) :: return_value
 
26
 
 
27
   return_value = c_system(str // C_NULL_CHAR)
 
28
   if (present(stat)) then
 
29
      stat = return_value
 
30
   end if
 
31
 
 
32
 end subroutine system
 
33
 
 
34
!-----------------------------------------------------
 
35
  subroutine chdir(path, stat)
 
36
    use iso_c_binding, only: C_CHAR, C_NULL_CHAR, C_INT
 
37
 
 
38
 
 
39
    character(*) :: path
 
40
    integer, optional, intent(out) :: stat
 
41
 
 
42
    integer(C_INT) :: return_value
 
43
 
 
44
  interface
 
45
    integer(c_int) function c_chdir(path) bind(C,name="chdir")
 
46
      use iso_c_binding, only: c_char, c_int
 
47
      character(kind=c_char) :: path(*)
 
48
    end function c_chdir
 
49
  end interface
 
50
 
 
51
  return_value =  c_chdir(path//c_null_char)
 
52
 
 
53
  if (present(stat)) then
 
54
     stat = return_value
 
55
  endif
 
56
  end subroutine chdir
 
57
!--------------------------------------------------
 
58
 
 
59
  ! If 'path' is too short to hold the result, stat will be "1".
 
60
  ! Otherwise, stat=0
 
61
  ! You *should* use the stat argument!
 
62
  
 
63
  subroutine getcwd(path, stat)
 
64
    use iso_c_binding, only: C_CHAR, C_INT, C_ASSOCIATED, C_PTR, C_SIZE_T
 
65
 
 
66
    character(len=*), intent(out)  :: path
 
67
    integer, optional, intent(out) :: stat
 
68
 
 
69
interface
 
70
   !      char * getcwd(char *buf, size_t size);
 
71
 
 
72
   function c_getcwd(str,str_size) result(res) bind(C, name="getcwd")
 
73
     use ISO_C_Binding, only: C_CHAR, C_PTR, C_SIZE_T
 
74
     character(kind=C_CHAR),intent(out) :: str(*)
 
75
     integer(kind=C_SIZE_T),intent(in), VALUE  :: str_size
 
76
     type(C_PTR) :: res
 
77
    end function
 
78
  end interface
 
79
 
 
80
  integer(C_INT) :: return_value
 
81
  
 
82
  integer :: null_loc
 
83
  integer(kind=C_SIZE_T) :: str_size
 
84
  type(c_PTR) :: p_result
 
85
  
 
86
  str_size = len(path)
 
87
  p_result = c_getcwd(path,str_size)
 
88
 
 
89
  if (c_associated(p_result)) then
 
90
     ! Remove stuff past the null-character
 
91
     null_loc = index( path, char(0) )
 
92
     path = path(1:null_loc-1)
 
93
     return_value = 0
 
94
  else
 
95
     path = ""
 
96
     return_value = 1
 
97
  endif
 
98
  
 
99
  if (present(stat)) then
 
100
     stat = return_value
 
101
  endif
 
102
  
 
103
end subroutine getcwd
 
104
 
 
105
!!! See also
 
106
!!! https://stackoverflow.com/questions/30279228/is-there-an-alternative-to-getcwd-in-fortran-2003-2008
 
107
!!! for "Windows" code
 
108
 
 
109
  
 
110
end module posix_calls