Octopus
loct.F90
Go to the documentation of this file.
1!! Copyright (C) 2002-2006 M. Marques, A. Castro, A. Rubio, G. Bertsch, M. Oliveira
2!!
3!! This program is free software; you can redistribute it and/or modify
4!! it under the terms of the GNU General Public License as published by
5!! the Free Software Foundation; either version 2, or (at your option)
6!! any later version.
7!!
8!! This program is distributed in the hope that it will be useful,
9!! but WITHOUT ANY WARRANTY; without even the implied warranty of
10!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11!! GNU General Public License for more details.
12!!
13!! You should have received a copy of the GNU General Public License
14!! along with this program; if not, write to the Free Software
15!! Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
16!! 02110-1301, USA.
17!!
18
19#include "global.h"
20
22module loct_oct_m
23 use iso_c_binding
24 use, intrinsic :: iso_fortran_env
25
26 implicit none
27
29 private
30 public :: &
31 loct_clock, &
36 loct_mkdir, &
37 loct_rm, &
49
50 private :: string_f_to_c
51
52 ! ---------------------------------------------------------
54 logical, public :: show_progress_bar = .true.
55
56 interface loct_clock
57 function oct_clock()
58 use, intrinsic :: iso_fortran_env
59 implicit none
60 real(real64) :: oct_clock
61 end function oct_clock
62 end interface loct_clock
63
64 interface loct_gettimeofday
65 subroutine oct_gettimeofday(sec, usec)
66 implicit none
67 integer, intent(out) :: sec, usec
68 end subroutine oct_gettimeofday
69 end interface loct_gettimeofday
70
71 interface loct_nanosleep
72 subroutine oct_nanosleep(sec, nsec)
73 implicit none
74 integer, intent(in) :: sec
75 integer, intent(in) :: nsec
76 end subroutine oct_nanosleep
77 end interface loct_nanosleep
78
79 ! ---------------------------------------------------------
81 interface loct_number_of_lines
82 integer function oct_number_of_lines(filename) bind(c)
83 use iso_c_binding
84 implicit none
85 character(kind=c_char), intent(in) :: filename(*)
86 end function oct_number_of_lines
87 end interface loct_number_of_lines
88
89 interface loct_break_c_string
90 subroutine oct_break_c_string(str, s, line)
91 use iso_c_binding
92 implicit none
93 type(c_ptr), intent(in) :: str
94 type(c_ptr), intent(inout) :: s
95 character(kind=c_char), intent(out) :: line(*)
96 end subroutine oct_break_c_string
97 end interface loct_break_c_string
98
99 ! ---------------------------------------------------------
101
102 interface loct_wfs_list
103 subroutine oct_wfs_list(str, l) bind(c)
104 use iso_c_binding
105 implicit none
106 character(kind=c_char), intent(in) :: str(*)
107 integer, intent(out) :: l
108 end subroutine oct_wfs_list
109 end interface loct_wfs_list
110
111 interface loct_get_memory_usage
112 integer(c_intptr_t) function oct_get_memory_usage()
113 use iso_c_binding, only: c_intptr_t
114 implicit none
115 end function oct_get_memory_usage
116 end interface loct_get_memory_usage
118contains
119
120 subroutine loct_print_recipe(dir, filename)
121 character(len=*), intent(in) :: dir
122 character(len=*), intent(inout) :: filename
123
124 character(kind=c_char) :: c_name(len(filename)+1)
125
126 interface
127 subroutine oct_print_recipe(dir, filename) bind(c)
128 use iso_c_binding
129 implicit none
130 character(kind=c_char), intent(in) :: dir(*)
131 character(kind=c_char), intent(out) :: filename(*)
132 end subroutine oct_print_recipe
133 end interface
134
135 call oct_print_recipe(string_f_to_c(dir), c_name)
136 call string_c_to_f(c_name, filename)
137 end subroutine loct_print_recipe
138
139
140 ! ---------------------------------------------------------
143 !
144 function string_f_to_c(f_string) result(c_string)
145 character(len=*), intent(in) :: f_string
146 character(kind=c_char,len=1) :: c_string(len_trim(f_string) + 1)
147
148 integer :: i, strlen
150 strlen = len_trim(f_string)
152 do i = 1, strlen
153 c_string(i) = f_string(i:i)
154 end do
155 c_string(strlen+1) = c_null_char
156
157 end function string_f_to_c
158
159 ! ---------------------------------------------------------
161 !
162 subroutine string_c_to_f(c_string, f_string)
163 character(kind=c_char,len=1), intent(in) :: c_string(*)
164 character(len=*), intent(out) :: f_string
165
166 integer :: i
168 i = 1
169 do while(c_string(i) /= c_null_char .and. i <= len(f_string))
170 f_string(i:i) = c_string(i)
171 i = i + 1
172 end do
173 if (i < len(f_string)) f_string(i:) = ' '
174
175 end subroutine string_c_to_f
180 subroutine loct_progress_bar(a, maxcount)
181 integer, intent(in) :: a
182 ! Set to -1 to initialise the bar.
183 integer, intent(in) :: maxcount
185 if (show_progress_bar) then
186 call oct_progress_bar(a, maxcount)
187 endif
188
189 end subroutine loct_progress_bar
190
191
192 logical function loct_isinstringlist(a, s) result(inlist)
193 integer, intent(in) :: a
194 character(len=*), intent(in) :: s
195
196 integer, allocatable :: list(:)
198 allocate(list(2**14))
199
200 call loct_wfs_list(string_f_to_c(s), list(1))
201 inlist = .false.
202 if (list(a) == 1) inlist = .true.
203
204 deallocate(list)
205
208 subroutine loct_mkdir(name)
209 character(len=*), intent(in) :: name
210
211 interface oct_mkdir
212 subroutine oct_mkdir(name) bind(c)
213 use iso_c_binding
214 implicit none
215 character(kind=c_char), intent(in) :: name(*)
216 end subroutine oct_mkdir
217 end interface oct_mkdir
218
219 call oct_mkdir(string_f_to_c(name))
220 end subroutine loct_mkdir
221
222 subroutine loct_rm(name)
223 character(len=*), intent(in) :: name
224
225 interface oct_rm
226 subroutine oct_rm(name) bind(c)
227 use iso_c_binding
228 implicit none
229 character(kind=c_char), intent(in) :: name(*)
230 end subroutine oct_rm
231 end interface oct_rm
232
233 call oct_rm(string_f_to_c(name))
234 end subroutine loct_rm
235
236 subroutine loct_sysname(name)
237 character(len=*), intent(inout) :: name
238 character(kind=c_char) :: c_name(len(name)+1)
240 interface oct_sysname
241 subroutine oct_sysname(name) bind(c)
242 use iso_c_binding
243 implicit none
244 character(kind=c_char), intent(out) :: name(*)
245 end subroutine oct_sysname
246 end interface oct_sysname
247
248 c_name = c_null_char
249 call oct_sysname(c_name)
250 call string_c_to_f(c_name, name)
251 end subroutine loct_sysname
252
253 logical function loct_dir_exists(dirname) result(exists)
254 character(len=*), intent(in) :: dirname
255
256 interface oct_dir_exists
257 integer function oct_dir_exists(dirname) bind(c)
258 use iso_c_binding
259 implicit none
260 character(kind=c_char), intent(in) :: dirname(*)
261 end function oct_dir_exists
262 end interface oct_dir_exists
263
264 exists = oct_dir_exists(string_f_to_c(dirname)) /= 0
265
266 end function loct_dir_exists
267
268 subroutine loct_getenv(var, val)
269 character(len=*), intent(in) :: var
270 character(len=*), intent(inout) :: val
271
272 character(kind=c_char) :: c_val(len(val)+1)
273
274 interface oct_getenv
275 subroutine oct_getenv(var, val) bind(c)
276 use iso_c_binding
277 implicit none
278 character(kind=c_char), intent(in) :: var(*)
279 character(kind=c_char), intent(inout) :: val(*)
280 end subroutine oct_getenv
281 end interface oct_getenv
282
283 c_val = c_null_char
284 call oct_getenv(string_f_to_c(var), c_val)
285 call string_c_to_f(c_val, val)
286 end subroutine loct_getenv
288 subroutine loct_strerror(errno, res)
289 integer, intent(in) :: errno
290 character(len=*), intent(inout) :: res
291
292 character(kind=c_char) :: cres(len(res)+1)
293
294 interface oct_strerror
295 subroutine oct_strerror(errno, res) bind(c)
296 use iso_c_binding
297 implicit none
298 integer, intent(in) :: errno
299 character(kind=c_char), intent(inout) :: res(*)
300 end subroutine oct_strerror
301 end interface oct_strerror
302
303 cres = c_null_char
304 call oct_strerror(errno, cres)
305 call string_c_to_f(cres, res)
306 end subroutine loct_strerror
307
308 subroutine loct_search_file_lr(freq, tag, ierr, dirname)
309 real(real64), intent(inout) :: freq
310 integer, intent(in) :: tag
311 integer, intent(out) :: ierr
312 character(len=*), intent(in) :: dirname
313
314 interface
315 subroutine oct_search_file_lr(freq, tag, ierr, dirname) bind(c)
316 use iso_c_binding
317 use, intrinsic :: iso_fortran_env
318 implicit none
319 real(real64), intent(inout) :: freq
320 integer, intent(in) :: tag
321 integer, intent(out) :: ierr
322 character(kind=c_char), intent(in) :: dirname(*)
323 end subroutine oct_search_file_lr
324 end interface
325
326 call oct_search_file_lr(freq, tag, ierr, string_f_to_c(dirname))
327 end subroutine loct_search_file_lr
328
329 subroutine loct_executable_path(fpath)
330 character(len=*), intent(inout) :: fpath
332 character(kind=c_char) :: path(len(fpath)+1)
333 interface oct_executable_path
334 subroutine oct_executable_path(var) bind(c)
335 use iso_c_binding
336 implicit none
337 character(kind=c_char), intent(out) :: var(*)
338 end subroutine oct_executable_path
339 end interface oct_executable_path
340
341 path = c_null_char
342 call oct_executable_path(path)
343 call string_c_to_f(path, fpath)
344 end subroutine loct_executable_path
345
346 subroutine loct_dirname(path, dir)
347 character(len=*), intent(in) :: path
348 character(len=*), intent(inout) :: dir
349
350 character(kind=c_char) :: cdir(len(dir)+1)
351 interface
352 subroutine oct_dirname(path, dir) bind(c)
353 use iso_c_binding
354 character(kind=c_char), intent(in) :: path(*)
355 character(kind=c_char), intent(inout) :: dir(*)
356 end subroutine oct_dirname
357 end interface
358
359 call oct_dirname(string_f_to_c(path), cdir)
360 call string_c_to_f(cdir, dir)
361 end subroutine loct_dirname
362end module loct_oct_m
364!! Local Variables:
365!! mode: f90
366!! coding: utf-8
367!! End:
System information (time, memory, sysname)
Definition: loct.F90:117
subroutine, public loct_rm(name)
Definition: loct.F90:318
logical function, public loct_isinstringlist(a, s)
Definition: loct.F90:288
subroutine, public loct_search_file_lr(freq, tag, ierr, dirname)
Definition: loct.F90:404
subroutine, public loct_mkdir(name)
Definition: loct.F90:304
subroutine, public loct_progress_bar(a, maxcount)
A wrapper around the progress bar, such that it can be silenced without needing to dress the call wit...
Definition: loct.F90:276
subroutine, public loct_print_recipe(dir, filename)
Definition: loct.F90:216
subroutine, public loct_strerror(errno, res)
Definition: loct.F90:384
subroutine, public loct_getenv(var, val)
Definition: loct.F90:364
subroutine, public loct_dirname(path, dir)
Definition: loct.F90:442
logical function, public loct_dir_exists(dirname)
Definition: loct.F90:349
character(kind=c_char, len=1) function, dimension(len_trim(f_string)+1), private string_f_to_c(f_string)
convert a Fortran string to a C string
Definition: loct.F90:240
subroutine, public loct_executable_path(fpath)
Definition: loct.F90:425
subroutine string_c_to_f(c_string, f_string)
convert a C string to a Fortran string
Definition: loct.F90:258
subroutine, public loct_sysname(name)
Definition: loct.F90:332
void oct_wfs_list(char *str_c, fint l[16384])
Definition: oct_f.c:5137
void oct_executable_path(char *path)
Definition: oct_f.c:5483
void oct_rm(char *name_c)
Definition: oct_f.c:5081
void oct_sysname(char *name_c)
Definition: oct_f.c:5282
int oct_number_of_lines(char *name_c)
Definition: oct_f.c:5294
void oct_dirname(char *fn, char *dn)
Definition: oct_f.c:5104
void oct_getenv(char *name_c, char *var_c)
Definition: oct_f.c:5116
int oct_dir_exists(char *name_c)
Definition: oct_f.c:5060
void oct_search_file_lr(double *freq, const fint *tag, fint *ierr, char *name_c)
Definition: oct_f.c:5355
void oct_mkdir(char *name_c)
Definition: oct_f.c:5013
void oct_strerror(const fint *err, char *res)
Definition: oct_gsl_f.c:12402
void oct_print_recipe(char *dir_, char *filename)
Definition: recipes.c:3962
int true(void)