Line data Source code
1 : !--------------------------------------------------------------------------------------------------!
2 : ! CP2K: A general program to perform molecular dynamics simulations !
3 : ! Copyright 2000-2024 CP2K developers group <https://cp2k.org> !
4 : ! !
5 : ! SPDX-License-Identifier: GPL-2.0-or-later !
6 : !--------------------------------------------------------------------------------------------------!
7 :
8 : ! **************************************************************************************************
9 : !> \brief Machine interface based on Fortran 2003 and POSIX
10 : !> \par History
11 : !> JGH (05.07.2001) : added G95 interface
12 : !> - m_flush added (12.06.2002,MK)
13 : !> - Missing print_memory added (24.09.2002,MK)
14 : !> - Migrate to generic implementation based on F2003 + POSIX (2014, Ole Schuett)
15 : !> \author APSI, JGH, Ole Schuett
16 : ! **************************************************************************************************
17 : MODULE machine
18 : USE ISO_C_BINDING, ONLY: C_CHAR, &
19 : C_INT, &
20 : C_PTR, &
21 : C_NULL_CHAR, &
22 : C_ASSOCIATED
23 : USE ISO_FORTRAN_ENV, ONLY: input_unit, &
24 : output_unit
25 : USE omp_lib, ONLY: omp_get_wtime
26 : USE kinds, ONLY: default_path_length, &
27 : default_string_length, &
28 : dp, &
29 : int_8
30 : #if defined(__LIBXSMM)
31 : USE libxsmm, ONLY: libxsmm_timer_tick, &
32 : libxsmm_timer_duration, &
33 : libxsmm_get_target_archid, &
34 : LIBXSMM_X86_SSE4
35 : #endif
36 :
37 : IMPLICIT NONE
38 :
39 : ! Except for some error handling code, all code should
40 : ! get a unit number from the print keys or from the logger, in order
41 : ! to guarantee correct output behavior,
42 : ! for example in farming or path integral runs
43 : ! default_input_unit should never be used
44 : ! but we need to know what it is, as we should not try to open it for output
45 : INTEGER, PUBLIC, PARAMETER :: default_output_unit = output_unit, &
46 : default_input_unit = input_unit
47 :
48 : #include "machine_cpuid.h"
49 : ! Enumerates the target architectures or instruction set extensions.
50 : ! A feature is present if within range for the respective architecture.
51 : ! For example, to check for MACHINE_X86_AVX the following is true:
52 : ! MACHINE_X86_AVX <= m_cpuid() and MACHINE_X86 >= m_cpuid().
53 : ! For example, to check for MACHINE_ARM_SOME the following is true:
54 : ! MACHINE_ARM_SOME <= m_cpuid() and MACHINE_ARM >= m_cpuid().
55 : INTEGER, PUBLIC, PARAMETER :: &
56 : MACHINE_CPU_GENERIC = CP_MACHINE_CPU_GENERIC, &
57 : MACHINE_X86_SSE4 = CP_MACHINE_X86_SSE4, &
58 : MACHINE_X86_AVX = CP_MACHINE_X86_AVX, &
59 : MACHINE_X86_AVX2 = CP_MACHINE_X86_AVX2, &
60 : MACHINE_X86_AVX512 = CP_MACHINE_X86_AVX512, &
61 : MACHINE_X86 = MACHINE_X86_AVX512 ! marks end of range
62 : ! other arch to be added as needed e.g.,
63 : !MACHINE_ARM_SOME = 2000
64 : !MACHINE_ARM_ELSE = 2001
65 : !MACHINE_ARM = MACHINE_ARM_ELSE
66 : !MACHINE_PWR_???? = 3000
67 :
68 : PRIVATE
69 :
70 : PUBLIC :: m_walltime, m_datum, m_hostnm, m_flush, &
71 : m_getcwd, m_getlog, m_getpid, m_procrun, m_abort, &
72 : m_chdir, m_mov, m_memory, m_memory_details, m_energy, &
73 : m_cpuinfo, m_cpuid_static, m_cpuid, m_cpuid_name, &
74 : m_get_omp_stacksize
75 :
76 : INTERFACE
77 : ! **********************************************************************************************
78 : !> \brief Target architecture or instruction set extension according to compiler target flags.
79 : !> \return cpuid according to MACHINE_* integer-parameter.
80 : !> \par History
81 : !> 04.2019 created [Hans Pabst]
82 : ! **********************************************************************************************
83 : PURE FUNCTION m_cpuid_static() BIND(C)
84 : IMPORT :: C_INT
85 : INTEGER(C_INT) :: m_cpuid_static
86 : END FUNCTION m_cpuid_static
87 : END INTERFACE
88 :
89 : ! Flushing is enabled by default because without it crash reports can get lost.
90 : ! For performance reasons it can be disabled via the input in &GLOBAL.
91 : LOGICAL, SAVE, PUBLIC :: flush_should_flush = .TRUE.
92 :
93 : INTEGER(KIND=int_8), SAVE, PUBLIC :: m_memory_max = 0
94 :
95 : CONTAINS
96 :
97 : ! **************************************************************************************************
98 : !> \brief flushes units if the &GLOBAL flag is set accordingly
99 : !> \param lunit ...
100 : !> \par History
101 : !> 10.2008 created [Joost VandeVondele]
102 : !> \note
103 : !> flushing might degrade performance significantly (30% and more)
104 : ! **************************************************************************************************
105 290580 : SUBROUTINE m_flush(lunit)
106 : INTEGER, INTENT(IN) :: lunit
107 :
108 290580 : IF (flush_should_flush) FLUSH (lunit)
109 :
110 290580 : END SUBROUTINE
111 :
112 : ! **************************************************************************************************
113 : !> \brief returns time from a real-time clock, protected against rolling
114 : !> early/easily
115 : !> \return ...
116 : !> \par History
117 : !> 03.2006 created [Joost VandeVondele]
118 : !> \note
119 : !> same implementation for all machines.
120 : !> might still roll, if not called multiple times per count_max/count_rate
121 : ! **************************************************************************************************
122 3097104983 : FUNCTION m_walltime() RESULT(wt)
123 : REAL(KIND=dp) :: wt
124 :
125 : #if defined(__LIBXSMM)
126 3097104983 : wt = libxsmm_timer_duration(0_int_8, libxsmm_timer_tick())
127 : #else
128 : wt = omp_get_wtime()
129 : #endif
130 3097104983 : END FUNCTION m_walltime
131 :
132 : ! **************************************************************************************************
133 : !> \brief reads /proc/cpuinfo if it exists (i.e. Linux) to return relevant info
134 : !> \param model_name as obtained from the 'model name' field, UNKNOWN otherwise
135 : ! **************************************************************************************************
136 4616 : SUBROUTINE m_cpuinfo(model_name)
137 : CHARACTER(LEN=default_string_length) :: model_name
138 :
139 : INTEGER, PARAMETER :: bufferlen = 2048
140 :
141 : CHARACTER(LEN=bufferlen) :: buffer
142 : INTEGER :: i, icol, iline, imod, stat
143 :
144 4616 : model_name = "UNKNOWN"
145 4616 : buffer = ""
146 4616 : OPEN (121245, FILE="/proc/cpuinfo", ACTION="READ", STATUS="OLD", ACCESS="STREAM", IOSTAT=stat)
147 4616 : IF (stat == 0) THEN
148 9458184 : DO i = 1, bufferlen
149 9458184 : READ (121245, END=999) buffer(I:I)
150 : END DO
151 4616 : 999 CLOSE (121245)
152 4616 : imod = INDEX(buffer, "model name")
153 4616 : IF (imod > 0) THEN
154 4616 : icol = imod - 1 + INDEX(buffer(imod:), ":")
155 4616 : iline = icol - 1 + INDEX(buffer(icol:), NEW_LINE('A'))
156 4616 : IF (iline == icol - 1) iline = bufferlen + 1
157 4616 : model_name = buffer(icol + 1:iline - 1)
158 : END IF
159 : END IF
160 4616 : END SUBROUTINE m_cpuinfo
161 :
162 : ! **************************************************************************************************
163 : !> \brief Target architecture or instruction set extension according to CPU-check at runtime.
164 : !> \return cpuid according to MACHINE_* integer-parameter.
165 : !> \par History
166 : !> 04.2019 created [Hans Pabst]
167 : ! **************************************************************************************************
168 13447 : PURE FUNCTION m_cpuid() RESULT(cpuid)
169 : INTEGER :: cpuid
170 : #if defined(__LIBXSMM)
171 13447 : cpuid = libxsmm_get_target_archid()
172 : cpuid = MERGE(MIN(MACHINE_X86_SSE4 + cpuid - LIBXSMM_X86_SSE4, MACHINE_X86), &
173 13447 : MACHINE_CPU_GENERIC, LIBXSMM_X86_SSE4 .LE. cpuid)
174 : #else
175 : cpuid = m_cpuid_static()
176 : #endif
177 13447 : END FUNCTION m_cpuid
178 :
179 : ! **************************************************************************************************
180 : !> \brief Determine name of target architecture for a given CPUID.
181 : !> \param cpuid integer value (MACHINE_*)
182 : !> \return name or short name.
183 : !> \par History
184 : !> 06.2019 created [Hans Pabst]
185 : ! **************************************************************************************************
186 0 : FUNCTION m_cpuid_name(cpuid)
187 : INTEGER :: cpuid
188 : CHARACTER(len=default_string_length), POINTER :: m_cpuid_name
189 :
190 : CHARACTER(len=default_string_length), SAVE, TARGET :: name_generic = "generic", &
191 : name_unknown = "unknown", name_x86_avx = "x86_avx", name_x86_avx2 = "x86_avx2", &
192 : name_x86_avx512 = "x86_avx512", name_x86_sse4 = "x86_sse4"
193 :
194 0 : SELECT CASE (cpuid)
195 : CASE (MACHINE_CPU_GENERIC)
196 0 : m_cpuid_name => name_generic
197 : CASE (MACHINE_X86_SSE4)
198 0 : m_cpuid_name => name_x86_sse4
199 : CASE (MACHINE_X86_AVX)
200 0 : m_cpuid_name => name_x86_avx
201 : CASE (MACHINE_X86_AVX2)
202 0 : m_cpuid_name => name_x86_avx2
203 : CASE (MACHINE_X86_AVX512)
204 0 : m_cpuid_name => name_x86_avx512
205 : CASE DEFAULT
206 0 : m_cpuid_name => name_unknown
207 : END SELECT
208 0 : END FUNCTION m_cpuid_name
209 :
210 : ! **************************************************************************************************
211 : !> \brief returns the energy used since some time in the past.
212 : !> The precise meaning depends on the infrastructure is available.
213 : !> In the cray_pm_energy case, this is the energy used by the node in kJ.
214 : !> \return ...
215 : !> \par History
216 : !> 09.2013 created [Joost VandeVondele, Ole Schuett]
217 : ! **************************************************************************************************
218 3090485727 : FUNCTION m_energy() RESULT(wt)
219 : REAL(KIND=dp) :: wt
220 :
221 : #if defined(__CRAY_PM_ENERGY)
222 : wt = read_energy("/sys/cray/pm_counters/energy")
223 : #elif defined(__CRAY_PM_ACCEL_ENERGY)
224 : wt = read_energy("/sys/cray/pm_counters/accel_energy")
225 : #else
226 3090485727 : wt = 0.0 ! fallback default
227 : #endif
228 :
229 3090485727 : END FUNCTION m_energy
230 :
231 : #if defined(__CRAY_PM_ACCEL_ENERGY) || defined(__CRAY_PM_ENERGY)
232 : ! **************************************************************************************************
233 : !> \brief reads energy values from the sys-filesystem
234 : !> \param filename ...
235 : !> \return ...
236 : !> \par History
237 : !> 09.2013 created [Joost VandeVondele, Ole Schuett]
238 : ! **************************************************************************************************
239 : FUNCTION read_energy(filename) RESULT(wt)
240 : CHARACTER(LEN=*) :: filename
241 : REAL(KIND=dp) :: wt
242 :
243 : CHARACTER(LEN=80) :: DATA
244 : INTEGER :: i, iostat
245 : INTEGER(KIND=int_8) :: raw
246 :
247 : OPEN (121245, FILE=filename, ACTION="READ", STATUS="OLD", ACCESS="STREAM")
248 : DO I = 1, 80
249 : READ (121245, END=999) DATA(I:I)
250 : END DO
251 : 999 CLOSE (121245)
252 : DATA(I:80) = ""
253 : READ (DATA, *, IOSTAT=iostat) raw
254 : IF (iostat .NE. 0) THEN
255 : wt = 0.0_dp
256 : ELSE
257 : ! convert from J to kJ
258 : wt = raw/1000.0_dp
259 : END IF
260 : END FUNCTION read_energy
261 : #endif
262 :
263 : ! **************************************************************************************************
264 : !> \brief returns a datum in human readable format using a standard Fortran routine
265 : !> \param cal_date ...
266 : !> \par History
267 : !> 10.2009 created [Joost VandeVondele]
268 : ! **************************************************************************************************
269 21417 : SUBROUTINE m_datum(cal_date)
270 : CHARACTER(len=*), INTENT(OUT) :: cal_date
271 :
272 : CHARACTER(len=10) :: time
273 : CHARACTER(len=8) :: date
274 :
275 21417 : CALL DATE_AND_TIME(date=date, time=time)
276 21417 : cal_date = date(1:4)//"-"//date(5:6)//"-"//date(7:8)//" "//time(1:2)//":"//time(3:4)//":"//time(5:10)
277 :
278 21417 : END SUBROUTINE m_datum
279 :
280 : ! **************************************************************************************************
281 : !> \brief Can be used to get a nice core
282 : ! **************************************************************************************************
283 0 : SUBROUTINE m_abort()
284 : INTERFACE
285 : SUBROUTINE abort() BIND(C, name="abort")
286 : END SUBROUTINE
287 : END INTERFACE
288 :
289 0 : CALL abort()
290 0 : END SUBROUTINE m_abort
291 :
292 : ! **************************************************************************************************
293 : !> \brief Returns if a process is running on the local machine
294 : !> 1 if yes and 0 if not
295 : !> \param pid ...
296 : !> \return ...
297 : ! **************************************************************************************************
298 2 : FUNCTION m_procrun(pid) RESULT(run_on)
299 : INTEGER, INTENT(IN) :: pid
300 : INTEGER :: run_on
301 : #if defined(__MINGW)
302 : run_on = 0
303 : #else
304 : INTEGER :: istat
305 :
306 : INTERFACE
307 : FUNCTION kill(pid, sig) BIND(C, name="kill") RESULT(errno)
308 : IMPORT
309 : INTEGER(KIND=C_INT), VALUE :: pid, sig
310 : INTEGER(KIND=C_INT) :: errno
311 : END FUNCTION
312 : END INTERFACE
313 :
314 : ! If sig is 0, then no signal is sent, but error checking is still
315 : ! performed; this can be used to check for the existence of a process
316 : ! ID or process group ID.
317 :
318 2 : istat = kill(pid=pid, sig=0)
319 2 : IF (istat == 0) THEN
320 : run_on = 1 ! no error, process exists
321 : ELSE
322 0 : run_on = 0 ! error, process probably does not exist
323 : END IF
324 : #endif
325 2 : END FUNCTION m_procrun
326 :
327 : ! **************************************************************************************************
328 : !> \brief Returns the total amount of memory [bytes] in use, if known, zero otherwise
329 : !> \param mem ...
330 : ! **************************************************************************************************
331 2079510 : SUBROUTINE m_memory(mem)
332 :
333 : INTEGER(KIND=int_8), OPTIONAL, INTENT(OUT) :: mem
334 : INTEGER(KIND=int_8) :: mem_local
335 :
336 : !
337 : ! __NO_STATM_ACCESS can be used to disable the stuff, if getpagesize
338 : ! lead to linking errors or /proc/self/statm can not be opened
339 : !
340 : #if defined(__NO_STATM_ACCESS)
341 : mem_local = 0
342 : #else
343 : INTEGER(KIND=int_8) :: m1, m2, m3
344 : CHARACTER(LEN=80) :: DATA
345 : INTEGER :: iostat, i
346 :
347 : ! the size of a page, might not be available everywhere
348 : INTERFACE
349 : FUNCTION getpagesize() BIND(C, name="getpagesize") RESULT(RES)
350 : IMPORT
351 : INTEGER(C_INT) :: RES
352 : END FUNCTION
353 : END INTERFACE
354 :
355 : !
356 : ! reading from statm
357 : !
358 2079510 : mem_local = -1
359 2079510 : DATA = ""
360 2079510 : OPEN (121245, FILE="/proc/self/statm", ACTION="READ", STATUS="OLD", ACCESS="STREAM")
361 78920303 : DO I = 1, 80
362 78920303 : READ (121245, END=999) DATA(I:I)
363 : END DO
364 2079510 : 999 CLOSE (121245)
365 2079510 : DATA(I:80) = ""
366 : ! m1 = total
367 : ! m2 = resident
368 : ! m3 = shared
369 2079510 : READ (DATA, *, IOSTAT=iostat) m1, m2, m3
370 2079510 : IF (iostat .NE. 0) THEN
371 : mem_local = 0
372 : ELSE
373 2079510 : mem_local = m2
374 : #if defined(__STATM_TOTAL)
375 : mem_local = m1
376 : #endif
377 : #if defined(__STATM_RESIDENT)
378 : mem_local = m2
379 : #endif
380 2079510 : mem_local = mem_local*getpagesize()
381 : END IF
382 : #endif
383 :
384 2079510 : m_memory_max = MAX(mem_local, m_memory_max)
385 2079510 : IF (PRESENT(mem)) mem = mem_local
386 :
387 2079510 : END SUBROUTINE m_memory
388 :
389 : ! **************************************************************************************************
390 : !> \brief get more detailed memory info, all units are bytes.
391 : !> the only 'useful' option is MemLikelyFree which is an estimate of remaining memory
392 : !> assumed to give info like /proc/meminfo while MeMLikelyFree is the amount of
393 : !> memory we're likely to be able to allocate, but not necessarily in one chunk
394 : !> zero means not available...
395 : !> \param MemTotal ...
396 : !> \param MemFree ...
397 : !> \param Buffers ...
398 : !> \param Cached ...
399 : !> \param Slab ...
400 : !> \param SReclaimable ...
401 : !> \param MemLikelyFree ...
402 : ! **************************************************************************************************
403 9025 : SUBROUTINE m_memory_details(MemTotal, MemFree, Buffers, Cached, Slab, SReclaimable, MemLikelyFree)
404 :
405 : INTEGER(kind=int_8), OPTIONAL :: MemTotal, MemFree, Buffers, Cached, Slab, SReclaimable, MemLikelyFree
406 :
407 : INTEGER, PARAMETER :: Nbuffer = 10000
408 : CHARACTER(LEN=Nbuffer) :: meminfo
409 :
410 : INTEGER :: i
411 :
412 9025 : MemTotal = 0
413 9025 : MemFree = 0
414 9025 : Buffers = 0
415 9025 : Cached = 0
416 9025 : Slab = 0
417 9025 : SReclaimable = 0
418 9025 : MemLikelyFree = 0
419 9025 : meminfo = ""
420 :
421 9025 : OPEN (UNIT=8123, file="/proc/meminfo", ACCESS="STREAM", ERR=901)
422 9025 : i = 0
423 13848761 : DO
424 13857786 : i = i + 1
425 13857786 : IF (i > Nbuffer) EXIT
426 13857786 : READ (8123, END=900, ERR=900) meminfo(i:i)
427 : END DO
428 : 900 CONTINUE
429 9025 : meminfo(i:Nbuffer) = ""
430 : 901 CONTINUE
431 9025 : CLOSE (8123, ERR=902)
432 : 902 CONTINUE
433 9025 : MemTotal = get_field_value_in_bytes('MemTotal:')
434 9025 : MemFree = get_field_value_in_bytes('MemFree:')
435 9025 : Buffers = get_field_value_in_bytes('Buffers:')
436 9025 : Cached = get_field_value_in_bytes('Cached:')
437 9025 : Slab = get_field_value_in_bytes('Slab:')
438 9025 : SReclaimable = get_field_value_in_bytes('SReclaimable:')
439 : ! opinions here vary but this might work
440 9025 : MemLikelyFree = MemFree + Buffers + Cached + SReclaimable
441 :
442 : CONTAINS
443 :
444 : ! **************************************************************************************************
445 : !> \brief ...
446 : !> \param field ...
447 : !> \return ...
448 : ! **************************************************************************************************
449 54150 : INTEGER(int_8) FUNCTION get_field_value_in_bytes(field)
450 : CHARACTER(LEN=*) :: field
451 :
452 : INTEGER :: start
453 : INTEGER(KIND=int_8) :: value
454 :
455 54150 : get_field_value_in_bytes = 0
456 54150 : start = INDEX(meminfo, field)
457 54150 : IF (start .NE. 0) THEN
458 54150 : start = start + LEN_TRIM(field)
459 54150 : IF (start .LT. Nbuffer) THEN
460 54150 : READ (meminfo(start:), *, ERR=999, END=999) value
461 : ! XXXXXXX convert from Kb to bytes XXXXXXXX
462 54150 : get_field_value_in_bytes = value*1024
463 : 999 CONTINUE
464 : END IF
465 : END IF
466 54150 : END FUNCTION
467 : END SUBROUTINE m_memory_details
468 :
469 : ! **************************************************************************************************
470 : !> \brief ...
471 : !> \param hname ...
472 : ! **************************************************************************************************
473 13303 : SUBROUTINE m_hostnm(hname)
474 : CHARACTER(len=*), INTENT(OUT) :: hname
475 : #if defined(__MINGW)
476 : ! While there is a gethostname in the Windows (POSIX) API, it requires that winsocks is
477 : ! initialised prior to using it via WSAStartup(..), respectively cleaned up at the end via WSACleanup().
478 : hname = "<unknown>"
479 : #else
480 : INTEGER :: istat, i
481 : CHARACTER(len=default_path_length) :: buf
482 :
483 : INTERFACE
484 : FUNCTION gethostname(buf, buflen) BIND(C, name="gethostname") RESULT(errno)
485 : IMPORT
486 : CHARACTER(KIND=C_CHAR), DIMENSION(*) :: buf
487 : INTEGER(KIND=C_INT), VALUE :: buflen
488 : INTEGER(KIND=C_INT) :: errno
489 : END FUNCTION
490 : END INTERFACE
491 :
492 26606 : istat = gethostname(buf, LEN(buf))
493 13303 : IF (istat /= 0) THEN
494 0 : WRITE (*, *) "m_hostnm failed"
495 0 : CALL m_abort()
496 : END IF
497 13303 : i = INDEX(buf, c_null_char) - 1
498 13303 : hname = buf(1:i)
499 : #endif
500 13303 : END SUBROUTINE m_hostnm
501 :
502 : ! **************************************************************************************************
503 : !> \brief ...
504 : !> \param curdir ...
505 : ! **************************************************************************************************
506 129307 : SUBROUTINE m_getcwd(curdir)
507 : CHARACTER(len=*), INTENT(OUT) :: curdir
508 : TYPE(C_PTR) :: stat
509 : INTEGER :: i
510 : CHARACTER(len=default_path_length), TARGET :: tmp
511 :
512 : INTERFACE
513 : FUNCTION getcwd(buf, buflen) BIND(C, name="getcwd") RESULT(stat)
514 : IMPORT
515 : CHARACTER(KIND=C_CHAR), DIMENSION(*) :: buf
516 : INTEGER(KIND=C_INT), VALUE :: buflen
517 : TYPE(C_PTR) :: stat
518 : END FUNCTION
519 : END INTERFACE
520 :
521 258614 : stat = getcwd(tmp, LEN(tmp))
522 129307 : IF (.NOT. C_ASSOCIATED(stat)) THEN
523 0 : WRITE (*, *) "m_getcwd failed"
524 0 : CALL m_abort()
525 : END IF
526 129307 : i = INDEX(tmp, c_null_char) - 1
527 129307 : curdir = tmp(1:i)
528 129307 : END SUBROUTINE m_getcwd
529 :
530 : ! **************************************************************************************************
531 : !> \brief ...
532 : !> \param dir ...
533 : !> \param ierror ...
534 : ! **************************************************************************************************
535 2902 : SUBROUTINE m_chdir(dir, ierror)
536 : CHARACTER(len=*), INTENT(IN) :: dir
537 : INTEGER, INTENT(OUT) :: ierror
538 :
539 : INTERFACE
540 : FUNCTION chdir(path) BIND(C, name="chdir") RESULT(errno)
541 : IMPORT
542 : CHARACTER(KIND=C_CHAR), DIMENSION(*) :: path
543 : INTEGER(KIND=C_INT) :: errno
544 : END FUNCTION
545 : END INTERFACE
546 :
547 2902 : ierror = chdir(TRIM(dir)//c_null_char)
548 2902 : END SUBROUTINE m_chdir
549 :
550 : ! **************************************************************************************************
551 : !> \brief ...
552 : !> \param pid ...
553 : ! **************************************************************************************************
554 13303 : SUBROUTINE m_getpid(pid)
555 : INTEGER, INTENT(OUT) :: pid
556 :
557 : INTERFACE
558 : FUNCTION getpid() BIND(C, name="getpid") RESULT(pid)
559 : IMPORT
560 : INTEGER(KIND=C_INT) :: pid
561 : END FUNCTION
562 : END INTERFACE
563 :
564 13303 : pid = getpid()
565 13303 : END SUBROUTINE m_getpid
566 :
567 : ! **************************************************************************************************
568 : !> \brief ...
569 : !> \param path ...
570 : !> \return ...
571 : ! **************************************************************************************************
572 11448 : FUNCTION m_unlink(path) RESULT(istat)
573 :
574 : CHARACTER(LEN=*), INTENT(IN) :: path
575 :
576 : INTEGER :: istat
577 :
578 : INTERFACE
579 : FUNCTION unlink(path) BIND(C, name="unlink") RESULT(errno)
580 : IMPORT
581 : CHARACTER(KIND=C_CHAR), DIMENSION(*) :: path
582 : INTEGER(KIND=C_INT) :: errno
583 : END FUNCTION
584 : END INTERFACE
585 :
586 11448 : istat = unlink(TRIM(path)//c_null_char)
587 11448 : END FUNCTION m_unlink
588 :
589 : ! **************************************************************************************************
590 : !> \brief ...
591 : !> \param source ...
592 : !> \param TARGET ...
593 : ! **************************************************************************************************
594 11448 : SUBROUTINE m_mov(source, TARGET)
595 :
596 : CHARACTER(LEN=*), INTENT(IN) :: source, TARGET
597 :
598 : INTEGER :: istat
599 :
600 : INTERFACE
601 : FUNCTION rename(src, dest) BIND(C, name="rename") RESULT(errno)
602 : IMPORT
603 : CHARACTER(KIND=C_CHAR), DIMENSION(*) :: src, dest
604 : INTEGER(KIND=C_INT) :: errno
605 : END FUNCTION
606 : END INTERFACE
607 :
608 11448 : IF (TARGET == source) THEN
609 0 : WRITE (*, *) "Warning: m_mov ", TRIM(TARGET), " equals ", TRIM(source)
610 0 : RETURN
611 : END IF
612 :
613 : ! first remove target (needed on windows / mingw)
614 11448 : istat = m_unlink(TARGET)
615 : ! ignore istat of unlink
616 :
617 : ! now move
618 11448 : istat = rename(TRIM(source)//c_null_char, TRIM(TARGET)//c_null_char)
619 11448 : IF (istat .NE. 0) THEN
620 0 : WRITE (*, *) "Trying to move "//TRIM(source)//" to "//TRIM(TARGET)//"."
621 0 : WRITE (*, *) "rename returned status: ", istat
622 0 : WRITE (*, *) "Problem moving file"
623 0 : CALL m_abort()
624 : END IF
625 : END SUBROUTINE m_mov
626 :
627 : ! **************************************************************************************************
628 : !> \brief ...
629 : !> \param user ...
630 : ! **************************************************************************************************
631 13078 : SUBROUTINE m_getlog(user)
632 :
633 : CHARACTER(LEN=*), INTENT(OUT) :: user
634 :
635 : INTEGER :: istat
636 :
637 : ! on a posix system LOGNAME should be defined
638 13078 : CALL get_environment_variable("LOGNAME", value=user, status=istat)
639 : ! nope, check alternative
640 13078 : IF (istat /= 0) &
641 13078 : CALL get_environment_variable("USER", value=user, status=istat)
642 : ! nope, check alternative
643 13078 : IF (istat /= 0) &
644 13078 : CALL get_environment_variable("USERNAME", value=user, status=istat)
645 : ! fall back
646 13078 : IF (istat /= 0) &
647 13078 : user = "<unknown>"
648 :
649 13078 : END SUBROUTINE m_getlog
650 :
651 : ! **************************************************************************************************
652 : !> \brief Retrieve environment variable OMP_STACKSIZE
653 : !> \param omp_stacksize Value of OMP_STACKSIZE
654 : ! **************************************************************************************************
655 4616 : SUBROUTINE m_get_omp_stacksize(omp_stacksize)
656 : CHARACTER(LEN=*), INTENT(OUT) :: omp_stacksize
657 :
658 : INTEGER :: istat
659 :
660 4616 : omp_stacksize = ""
661 4616 : CALL get_environment_variable("OMP_STACKSIZE", value=omp_stacksize, status=istat)
662 : ! Fall back, if OMP_STACKSIZE is not set
663 4616 : IF (istat /= 0) omp_stacksize = "default"
664 :
665 4616 : END SUBROUTINE m_get_omp_stacksize
666 :
667 : END MODULE machine
|
