Line data Source code
1 : !--------------------------------------------------------------------------------------------------!
2 : ! CP2K: A general program to perform molecular dynamics simulations !
3 : ! Copyright 2000-2025 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 : #include "libxsmm_version.h"
32 : #if !defined(__LIBXSMM2) && (1 < __LIBXSMM || (1170000 < \
33 : (LIBXSMM_CONFIG_VERSION_MAJOR*1000000\
34 : +LIBXSMM_CONFIG_VERSION_MINOR*10000\
35 : +LIBXSMM_CONFIG_VERSION_UPDATE*100\
36 : +LIBXSMM_CONFIG_VERSION_PATCH)))
37 : #define __LIBXSMM2
38 : #endif
39 : #if defined(__LIBXSMM2)
40 : USE libxsmm, ONLY: libxsmm_timer_tick, libxsmm_timer_duration, libxsmm_get_target_archid, &
41 : LIBXSMM_TARGET_ARCH_GENERIC, LIBXSMM_X86_SSE4, LIBXSMM_X86_AVX, LIBXSMM_X86_AVX2, &
42 : LIBXSMM_X86_AVX512_SKX, LIBXSMM_AARCH64_V81, LIBXSMM_AARCH64_SVE128
43 : #else
44 : USE libxsmm, ONLY: libxsmm_timer_tick, libxsmm_timer_duration, libxsmm_get_target_archid, &
45 : LIBXSMM_TARGET_ARCH_GENERIC, LIBXSMM_X86_SSE4, LIBXSMM_X86_AVX, LIBXSMM_X86_AVX2, &
46 : LIBXSMM_X86_AVX512_SKX => LIBXSMM_X86_AVX512_CORE
47 : #endif
48 : #endif
49 :
50 : IMPLICIT NONE
51 :
52 : ! Except for some error handling code, all code should
53 : ! get a unit number from the print keys or from the logger, in order
54 : ! to guarantee correct output behavior,
55 : ! for example in farming or path integral runs
56 : ! default_input_unit should never be used
57 : ! but we need to know what it is, as we should not try to open it for output
58 : INTEGER, PUBLIC, PARAMETER :: default_output_unit = output_unit, &
59 : default_input_unit = input_unit, &
60 : timestamp_length = 23
61 :
62 : #include "machine_cpuid.h"
63 : ! Enumerates the target architectures or instruction set extensions.
64 : ! A feature is present if within range for the respective architecture.
65 : ! For example, to check for MACHINE_X86_AVX the following is true:
66 : ! MACHINE_X86_AVX <= m_cpuid() and MACHINE_X86 >= m_cpuid().
67 : ! For example, to check for MACHINE_ARM_SOME the following is true:
68 : ! MACHINE_ARM_SOME <= m_cpuid() and MACHINE_ARM >= m_cpuid().
69 : INTEGER, PUBLIC, PARAMETER :: &
70 : MACHINE_CPU_GENERIC = CP_MACHINE_CPU_GENERIC, &
71 : !
72 : MACHINE_X86_SSE4 = CP_MACHINE_X86_SSE4, &
73 : MACHINE_X86_AVX = CP_MACHINE_X86_AVX, &
74 : MACHINE_X86_AVX2 = CP_MACHINE_X86_AVX2, &
75 : MACHINE_X86_AVX512 = CP_MACHINE_X86_AVX512, &
76 : MACHINE_X86 = MACHINE_X86_AVX512, &
77 : !
78 : MACHINE_ARM_ARCH64 = CP_MACHINE_ARM_ARCH64, &
79 : MACHINE_ARM_SVE128 = CP_MACHINE_ARM_SVE128, &
80 : MACHINE_ARM_SVE256 = CP_MACHINE_ARM_SVE256, &
81 : MACHINE_ARM_SVE512 = CP_MACHINE_ARM_SVE512, &
82 : MACHINE_ARM = MACHINE_ARM_SVE512, &
83 : !
84 : ! other archs to be added as needed
85 : MACHINE_CPU_UNKNOWN = CP_MACHINE_UNKNOWN ! marks end of range
86 :
87 : PRIVATE
88 :
89 : PUBLIC :: m_walltime, m_timestamp, m_hostnm, m_flush, &
90 : m_getcwd, m_getlog, m_getpid, m_procrun, m_abort, &
91 : m_chdir, m_mov, m_memory, m_memory_details, m_energy, &
92 : m_cpuinfo, m_cpuid_static, m_cpuid, m_cpuid_name, &
93 : m_cpuid_vlen, m_omp_get_stacksize, m_omp_trace_issues
94 :
95 : INTERFACE
96 : ! **********************************************************************************************
97 : !> \brief Target architecture or instruction set extension according to compiler target flags.
98 : !> \return cpuid according to MACHINE_* integer-parameter.
99 : !> \par History
100 : !> 04.2019 created [Hans Pabst]
101 : ! **********************************************************************************************
102 : PURE FUNCTION m_cpuid_static() BIND(C)
103 : IMPORT :: C_INT
104 : INTEGER(C_INT) :: m_cpuid_static
105 : END FUNCTION m_cpuid_static
106 :
107 : ! **********************************************************************************************
108 : !> \brief Trace OpenMP constructs if ennvironment variable CP2K_OMP_TRACE=1.
109 : !> \return Number of OpenMP issues encountered (negative if OMPT disabled).
110 : !> \par History
111 : !> 11.2024 created [Hans Pabst]
112 : ! **********************************************************************************************
113 : FUNCTION m_omp_trace_issues() BIND(C, name="openmp_trace_issues")
114 : IMPORT :: C_INT
115 : INTEGER(C_INT) :: m_omp_trace_issues
116 : END FUNCTION m_omp_trace_issues
117 : END INTERFACE
118 :
119 : ! Flushing is enabled by default because without it crash reports can get lost.
120 : ! For performance reasons it can be disabled via the input in &GLOBAL.
121 : LOGICAL, SAVE, PUBLIC :: flush_should_flush = .TRUE.
122 :
123 : INTEGER(KIND=int_8), SAVE, PUBLIC :: m_memory_max = 0
124 :
125 : CONTAINS
126 :
127 : ! **************************************************************************************************
128 : !> \brief flushes units if the &GLOBAL flag is set accordingly
129 : !> \param lunit ...
130 : !> \par History
131 : !> 10.2008 created [Joost VandeVondele]
132 : !> \note
133 : !> flushing might degrade performance significantly (30% and more)
134 : ! **************************************************************************************************
135 254926 : SUBROUTINE m_flush(lunit)
136 : INTEGER, INTENT(IN) :: lunit
137 :
138 254926 : IF (flush_should_flush) FLUSH (lunit)
139 :
140 254926 : END SUBROUTINE m_flush
141 :
142 : ! **************************************************************************************************
143 : !> \brief returns time from a real-time clock, protected against rolling
144 : !> early/easily
145 : !> \return ...
146 : !> \par History
147 : !> 03.2006 created [Joost VandeVondele]
148 : !> \note
149 : !> same implementation for all machines.
150 : !> might still roll, if not called multiple times per count_max/count_rate
151 : ! **************************************************************************************************
152 3290362333 : FUNCTION m_walltime() RESULT(wt)
153 : REAL(KIND=dp) :: wt
154 :
155 : #if defined(__LIBXSMM)
156 3290362333 : wt = libxsmm_timer_duration(0_int_8, libxsmm_timer_tick())
157 : #else
158 : wt = omp_get_wtime()
159 : #endif
160 3290362333 : END FUNCTION m_walltime
161 :
162 : ! **************************************************************************************************
163 : !> \brief reads /proc/cpuinfo if it exists (i.e. Linux) to return relevant info
164 : !> \param model_name as obtained from the 'model name' field, UNKNOWN otherwise
165 : ! **************************************************************************************************
166 5044 : SUBROUTINE m_cpuinfo(model_name)
167 : CHARACTER(LEN=default_string_length), INTENT(OUT) :: model_name
168 :
169 : INTEGER, PARAMETER :: bufferlen = 2048
170 :
171 : CHARACTER(LEN=bufferlen) :: buffer
172 : INTEGER :: i, icol, iline, stat
173 :
174 5044 : model_name = "UNKNOWN"
175 5044 : buffer = ""
176 5044 : OPEN (121245, FILE="/proc/cpuinfo", ACTION="READ", STATUS="OLD", ACCESS="STREAM", IOSTAT=stat)
177 5044 : IF (stat == 0) THEN
178 10335156 : DO i = 1, bufferlen
179 10335156 : READ (121245, END=999) buffer(I:I)
180 : END DO
181 5044 : 999 CLOSE (121245)
182 5044 : i = INDEX(buffer, "model name")
183 5044 : IF (i > 0) THEN
184 5044 : icol = i - 1 + INDEX(buffer(i:), ":")
185 5044 : iline = icol - 1 + INDEX(buffer(icol:), NEW_LINE('A'))
186 5044 : IF (iline == icol - 1) iline = bufferlen + 1
187 5044 : model_name = buffer(icol + 1:iline - 1)
188 : END IF
189 : END IF
190 5044 : END SUBROUTINE m_cpuinfo
191 :
192 : ! **************************************************************************************************
193 : !> \brief Target architecture or instruction set extension according to CPU-check at runtime.
194 : !> \return cpuid according to MACHINE_* integer-parameter.
195 : !> \par History
196 : !> 04.2019 created [Hans Pabst]
197 : !> 09.2024 update+arm [Hans Pabst]
198 : ! **************************************************************************************************
199 484965 : PURE FUNCTION m_cpuid()
200 : INTEGER :: m_cpuid
201 : #if !defined(__LIBXSMM)
202 : m_cpuid = m_cpuid_static()
203 : #else
204 :
205 : INTEGER :: archid
206 484965 : m_cpuid = MACHINE_CPU_UNKNOWN
207 484965 : archid = libxsmm_get_target_archid()
208 484965 : IF (LIBXSMM_X86_SSE4 <= archid .AND. archid < LIBXSMM_X86_AVX) THEN
209 : m_cpuid = MACHINE_X86_SSE4
210 484965 : ELSE IF (LIBXSMM_X86_AVX <= archid .AND. archid < LIBXSMM_X86_AVX2) THEN
211 : m_cpuid = MACHINE_X86_AVX
212 484965 : ELSE IF (LIBXSMM_X86_AVX2 <= archid .AND. archid < LIBXSMM_X86_AVX512_SKX) THEN
213 : m_cpuid = MACHINE_X86_AVX2
214 0 : ELSE IF (LIBXSMM_X86_AVX512_SKX <= archid .AND. archid <= 1999) THEN
215 : m_cpuid = MACHINE_X86_AVX512
216 : END IF
217 :
218 : #if defined(__LIBXSMM2)
219 : IF (m_cpuid == MACHINE_CPU_UNKNOWN) THEN
220 0 : IF (LIBXSMM_AARCH64_V81 <= archid .AND. archid < LIBXSMM_AARCH64_SVE128) THEN
221 : m_cpuid = MACHINE_ARM_ARCH64
222 0 : ELSE IF (LIBXSMM_AARCH64_SVE128 <= archid .AND. archid < 2401) THEN ! LIBXSMM_AARCH64_SVE512
223 : m_cpuid = MACHINE_ARM_SVE256
224 0 : ELSE IF (2401 <= archid .AND. archid <= 2999) THEN
225 : m_cpuid = MACHINE_ARM_SVE512
226 : END IF
227 : END IF
228 : #endif
229 :
230 0 : IF (m_cpuid == MACHINE_CPU_UNKNOWN .AND. LIBXSMM_TARGET_ARCH_GENERIC <= archid .AND. archid <= 2999) THEN
231 0 : m_cpuid = MACHINE_CPU_GENERIC
232 : END IF
233 : #endif
234 484965 : END FUNCTION m_cpuid
235 :
236 : ! **************************************************************************************************
237 : !> \brief Determine name of target architecture for a given CPUID.
238 : !> \param cpuid integer value (MACHINE_*)
239 : !> \return short name of ISA extension.
240 : !> \par History
241 : !> 06.2019 created [Hans Pabst]
242 : !> 09.2024 update+arm [Hans Pabst]
243 : ! **************************************************************************************************
244 0 : PURE FUNCTION m_cpuid_name(cpuid)
245 : INTEGER, INTENT(IN), OPTIONAL :: cpuid
246 : CHARACTER(len=default_string_length) :: m_cpuid_name
247 :
248 : INTEGER :: isa
249 :
250 0 : IF (PRESENT(cpuid)) THEN
251 0 : isa = cpuid
252 : ELSE
253 0 : isa = m_cpuid()
254 : END IF
255 :
256 0 : SELECT CASE (isa)
257 : CASE (MACHINE_CPU_GENERIC)
258 0 : m_cpuid_name = "generic"
259 : CASE (MACHINE_X86_SSE4)
260 0 : m_cpuid_name = "x86_sse4"
261 : CASE (MACHINE_X86_AVX)
262 0 : m_cpuid_name = "x86_avx"
263 : CASE (MACHINE_X86_AVX2)
264 0 : m_cpuid_name = "x86_avx2"
265 : CASE (MACHINE_X86_AVX512)
266 0 : m_cpuid_name = "x86_avx512"
267 : CASE (MACHINE_ARM_ARCH64)
268 0 : m_cpuid_name = "arm_arch64"
269 : CASE (MACHINE_ARM_SVE128)
270 0 : m_cpuid_name = "arm_sve128"
271 : CASE (MACHINE_ARM_SVE256)
272 0 : m_cpuid_name = "arm_sve256"
273 : CASE (MACHINE_ARM_SVE512)
274 0 : m_cpuid_name = "arm_sve512"
275 : CASE DEFAULT
276 0 : m_cpuid_name = "unknown"
277 : END SELECT
278 0 : END FUNCTION m_cpuid_name
279 :
280 : ! **************************************************************************************************
281 : !> \brief Determine vector-length for a given CPUID.
282 : !> \param cpuid integer value (MACHINE_*)
283 : !> \param typesize number of bytes of scalar type
284 : !> \return vector-length in number of elements.
285 : !> \par History
286 : !> 12.2024 created [Hans Pabst]
287 : ! **************************************************************************************************
288 480925 : PURE FUNCTION m_cpuid_vlen(cpuid, typesize)
289 : INTEGER, INTENT(IN), OPTIONAL :: cpuid, typesize
290 : INTEGER :: m_cpuid_vlen
291 :
292 : INTEGER :: isa, nbytes
293 :
294 480925 : IF (PRESENT(typesize)) THEN
295 0 : nbytes = typesize
296 : ELSE
297 : nbytes = 8 ! double-precision
298 : END IF
299 :
300 480925 : IF (0 < nbytes .AND. nbytes <= 16) THEN ! sanity check
301 480925 : IF (PRESENT(cpuid)) THEN
302 10088 : isa = cpuid
303 : ELSE
304 470837 : isa = m_cpuid()
305 : END IF
306 :
307 0 : SELECT CASE (isa)
308 : CASE (MACHINE_X86_SSE4)
309 0 : m_cpuid_vlen = 16/nbytes
310 : CASE (MACHINE_ARM_ARCH64) ! NEON
311 0 : m_cpuid_vlen = 16/nbytes
312 : CASE (MACHINE_ARM_SVE128)
313 0 : m_cpuid_vlen = 16/nbytes
314 : CASE (MACHINE_X86_AVX)
315 0 : m_cpuid_vlen = 32/nbytes
316 : CASE (MACHINE_X86_AVX2)
317 480925 : m_cpuid_vlen = 32/nbytes
318 : CASE (MACHINE_ARM_SVE256)
319 0 : m_cpuid_vlen = 32/nbytes
320 : CASE (MACHINE_X86_AVX512)
321 0 : m_cpuid_vlen = 64/nbytes
322 : CASE (MACHINE_ARM_SVE512)
323 0 : m_cpuid_vlen = 64/nbytes
324 : CASE DEFAULT ! unknown or generic
325 480925 : m_cpuid_vlen = 1 ! scalar
326 : END SELECT
327 : ELSE ! fallback
328 : m_cpuid_vlen = 1 ! scalar
329 : END IF
330 480925 : END FUNCTION m_cpuid_vlen
331 :
332 : ! **************************************************************************************************
333 : !> \brief returns the energy used since some time in the past.
334 : !> The precise meaning depends on the infrastructure is available.
335 : !> In the cray_pm_energy case, this is the energy used by the node in kJ.
336 : !> \return ...
337 : !> \par History
338 : !> 09.2013 created [Joost VandeVondele, Ole Schuett]
339 : ! **************************************************************************************************
340 3283411691 : FUNCTION m_energy() RESULT(wt)
341 : REAL(KIND=dp) :: wt
342 :
343 : #if defined(__CRAY_PM_ENERGY)
344 : wt = read_energy("/sys/cray/pm_counters/energy")
345 : #elif defined(__CRAY_PM_ACCEL_ENERGY)
346 : wt = read_energy("/sys/cray/pm_counters/accel_energy")
347 : #else
348 3283411691 : wt = 0.0 ! fallback default
349 : #endif
350 :
351 3283411691 : END FUNCTION m_energy
352 :
353 : #if defined(__CRAY_PM_ACCEL_ENERGY) || defined(__CRAY_PM_ENERGY)
354 : ! **************************************************************************************************
355 : !> \brief reads energy values from the sys-filesystem
356 : !> \param filename ...
357 : !> \return ...
358 : !> \par History
359 : !> 09.2013 created [Joost VandeVondele, Ole Schuett]
360 : ! **************************************************************************************************
361 : FUNCTION read_energy(filename) RESULT(wt)
362 : CHARACTER(LEN=*) :: filename
363 : REAL(KIND=dp) :: wt
364 :
365 : CHARACTER(LEN=80) :: DATA
366 : INTEGER :: i, iostat
367 : INTEGER(KIND=int_8) :: raw
368 :
369 : OPEN (121245, FILE=filename, ACTION="READ", STATUS="OLD", ACCESS="STREAM")
370 : DO I = 1, 80
371 : READ (121245, END=999) DATA(I:I)
372 : END DO
373 : 999 CLOSE (121245)
374 : DATA(I:80) = ""
375 : READ (DATA, *, IOSTAT=iostat) raw
376 : IF (iostat /= 0) THEN
377 : wt = 0.0_dp
378 : ELSE
379 : ! convert from J to kJ
380 : wt = raw/1000.0_dp
381 : END IF
382 : END FUNCTION read_energy
383 : #endif
384 :
385 : ! **************************************************************************************************
386 : !> \brief Returns a human readable timestamp
387 : !> \param timestamp Timestamp string
388 : !> \par History
389 : !> 10.2009 created [Joost VandeVondele]
390 : !> 08.2025 modified [Matthias Krack]
391 : ! **************************************************************************************************
392 22816 : SUBROUTINE m_timestamp(timestamp)
393 : CHARACTER(len=timestamp_length), INTENT(OUT) :: timestamp
394 :
395 : CHARACTER(len=10) :: time
396 : CHARACTER(len=8) :: date
397 :
398 22816 : CALL DATE_AND_TIME(date=date, time=time)
399 : timestamp = date(1:4)//"-"//date(5:6)//"-"//date(7:8)//" "// &
400 22816 : time(1:2)//":"//time(3:4)//":"//time(5:10)
401 :
402 22816 : END SUBROUTINE m_timestamp
403 :
404 : ! **************************************************************************************************
405 : !> \brief Can be used to get a nice core
406 : ! **************************************************************************************************
407 0 : SUBROUTINE m_abort()
408 : INTERFACE
409 : SUBROUTINE abort() BIND(C, name="abort")
410 : END SUBROUTINE abort
411 : END INTERFACE
412 :
413 0 : CALL abort()
414 0 : END SUBROUTINE m_abort
415 :
416 : ! **************************************************************************************************
417 : !> \brief Returns if a process is running on the local machine
418 : !> 1 if yes and 0 if not
419 : !> \param pid ...
420 : !> \return ...
421 : ! **************************************************************************************************
422 9881 : FUNCTION m_procrun(pid) RESULT(run_on)
423 : INTEGER, INTENT(IN) :: pid
424 : INTEGER :: run_on
425 : #if defined(__MINGW)
426 : run_on = 0
427 : #else
428 : INTEGER :: istat
429 :
430 : INTERFACE
431 : FUNCTION kill(pid, sig) BIND(C, name="kill") RESULT(errno)
432 : IMPORT
433 : INTEGER(KIND=C_INT), VALUE :: pid, sig
434 : INTEGER(KIND=C_INT) :: errno
435 : END FUNCTION kill
436 : END INTERFACE
437 :
438 : ! If sig is 0, then no signal is sent, but error checking is still
439 : ! performed; this can be used to check for the existence of a process
440 : ! ID or process group ID.
441 :
442 9881 : istat = kill(pid=pid, sig=0)
443 9881 : IF (istat == 0) THEN
444 : run_on = 1 ! no error, process exists
445 : ELSE
446 0 : run_on = 0 ! error, process probably does not exist
447 : END IF
448 : #endif
449 9881 : END FUNCTION m_procrun
450 :
451 : ! **************************************************************************************************
452 : !> \brief Returns the total amount of memory [bytes] in use, if known, zero otherwise
453 : !> \param mem ...
454 : ! **************************************************************************************************
455 2230020 : SUBROUTINE m_memory(mem)
456 :
457 : INTEGER(KIND=int_8), OPTIONAL, INTENT(OUT) :: mem
458 : INTEGER(KIND=int_8) :: mem_local
459 :
460 : ! __NO_STATM_ACCESS can be used to disable the stuff, if getpagesize
461 : ! lead to linking errors or /proc/self/statm can not be opened
462 : !
463 : #if defined(__NO_STATM_ACCESS)
464 : mem_local = 0
465 : #else
466 : INTEGER(KIND=int_8) :: m1, m2, m3
467 : CHARACTER(LEN=80) :: DATA
468 : INTEGER :: iostat, i
469 :
470 : ! the size of a page, might not be available everywhere
471 : INTERFACE
472 : FUNCTION getpagesize() BIND(C, name="getpagesize") RESULT(RES)
473 : IMPORT
474 : INTEGER(C_INT) :: RES
475 : END FUNCTION getpagesize
476 : END INTERFACE
477 :
478 : ! reading from statm
479 : !
480 2230020 : mem_local = -1
481 2230020 : DATA = ""
482 2230020 : OPEN (121245, FILE="/proc/self/statm", ACTION="READ", STATUS="OLD", ACCESS="STREAM")
483 78149404 : DO I = 1, 80
484 78149404 : READ (121245, END=999) DATA(I:I)
485 : END DO
486 2230020 : 999 CLOSE (121245)
487 2230020 : DATA(I:80) = ""
488 : ! m1 = total
489 : ! m2 = resident
490 : ! m3 = shared
491 2230020 : READ (DATA, *, IOSTAT=iostat) m1, m2, m3
492 2230020 : IF (iostat /= 0) THEN
493 : mem_local = 0
494 : ELSE
495 2230020 : mem_local = m2
496 : #if defined(__STATM_TOTAL)
497 : mem_local = m1
498 : #endif
499 : #if defined(__STATM_RESIDENT)
500 : mem_local = m2
501 : #endif
502 2230020 : mem_local = mem_local*getpagesize()
503 : END IF
504 : #endif
505 :
506 2230020 : m_memory_max = MAX(mem_local, m_memory_max)
507 2230020 : IF (PRESENT(mem)) mem = mem_local
508 :
509 2230020 : END SUBROUTINE m_memory
510 :
511 : ! **************************************************************************************************
512 : !> \brief get more detailed memory info, all units are bytes.
513 : !> the only 'useful' option is MemLikelyFree which is an estimate of remaining memory
514 : !> assumed to give info like /proc/meminfo while MeMLikelyFree is the amount of
515 : !> memory we're likely to be able to allocate, but not necessarily in one chunk
516 : !> zero means not available...
517 : !> \param MemTotal ...
518 : !> \param MemFree ...
519 : !> \param Buffers ...
520 : !> \param Cached ...
521 : !> \param Slab ...
522 : !> \param SReclaimable ...
523 : !> \param MemLikelyFree ...
524 : ! **************************************************************************************************
525 9881 : SUBROUTINE m_memory_details(MemTotal, MemFree, Buffers, Cached, Slab, SReclaimable, MemLikelyFree)
526 :
527 : INTEGER(kind=int_8), OPTIONAL :: MemTotal, MemFree, Buffers, Cached, Slab, SReclaimable, MemLikelyFree
528 :
529 : INTEGER, PARAMETER :: Nbuffer = 10000
530 : CHARACTER(LEN=Nbuffer) :: meminfo
531 :
532 : INTEGER :: i
533 :
534 9881 : MemTotal = 0
535 9881 : MemFree = 0
536 9881 : Buffers = 0
537 9881 : Cached = 0
538 9881 : Slab = 0
539 9881 : SReclaimable = 0
540 9881 : MemLikelyFree = 0
541 9881 : meminfo = ""
542 :
543 9881 : OPEN (UNIT=8123, file="/proc/meminfo", ACCESS="STREAM", ERR=901)
544 9881 : i = 0
545 15167307 : DO
546 15177188 : i = i + 1
547 15177188 : IF (i > Nbuffer) EXIT
548 15177188 : READ (8123, END=900, ERR=900) meminfo(i:i)
549 : END DO
550 : 900 CONTINUE
551 9881 : meminfo(i:Nbuffer) = ""
552 : 901 CONTINUE
553 9881 : CLOSE (8123, ERR=902)
554 : 902 CONTINUE
555 9881 : MemTotal = get_field_value_in_bytes('MemTotal:')
556 9881 : MemFree = get_field_value_in_bytes('MemFree:')
557 9881 : Buffers = get_field_value_in_bytes('Buffers:')
558 9881 : Cached = get_field_value_in_bytes('Cached:')
559 9881 : Slab = get_field_value_in_bytes('Slab:')
560 9881 : SReclaimable = get_field_value_in_bytes('SReclaimable:')
561 : ! opinions here vary but this might work
562 9881 : MemLikelyFree = MemFree + Buffers + Cached + SReclaimable
563 :
564 : CONTAINS
565 :
566 : ! **************************************************************************************************
567 : !> \brief ...
568 : !> \param field ...
569 : !> \return ...
570 : ! **************************************************************************************************
571 59286 : INTEGER(int_8) FUNCTION get_field_value_in_bytes(field)
572 : CHARACTER(LEN=*) :: field
573 :
574 : INTEGER :: start
575 : INTEGER(KIND=int_8) :: value
576 :
577 59286 : get_field_value_in_bytes = 0
578 59286 : start = INDEX(meminfo, field)
579 59286 : IF (start /= 0) THEN
580 59286 : start = start + LEN_TRIM(field)
581 59286 : IF (start < Nbuffer) THEN
582 59286 : READ (meminfo(start:), *, ERR=999, END=999) value
583 : ! XXXXXXX convert from Kb to bytes XXXXXXXX
584 59286 : get_field_value_in_bytes = value*1024
585 : 999 CONTINUE
586 : END IF
587 : END IF
588 59286 : END FUNCTION get_field_value_in_bytes
589 : END SUBROUTINE m_memory_details
590 :
591 : ! **************************************************************************************************
592 : !> \brief ...
593 : !> \param hname ...
594 : ! **************************************************************************************************
595 14929 : SUBROUTINE m_hostnm(hname)
596 : CHARACTER(len=*), INTENT(OUT) :: hname
597 : #if defined(__MINGW)
598 : ! While there is a gethostname in the Windows (POSIX) API, it requires that winsocks is
599 : ! initialised prior to using it via WSAStartup(..), respectively cleaned up at the end via WSACleanup().
600 : hname = "<unknown>"
601 : #else
602 : INTEGER :: istat, i
603 : CHARACTER(len=default_path_length) :: buf
604 :
605 : INTERFACE
606 : FUNCTION gethostname(buf, buflen) BIND(C, name="gethostname") RESULT(errno)
607 : IMPORT
608 : CHARACTER(KIND=C_CHAR), DIMENSION(*) :: buf
609 : INTEGER(KIND=C_INT), VALUE :: buflen
610 : INTEGER(KIND=C_INT) :: errno
611 : END FUNCTION gethostname
612 : END INTERFACE
613 :
614 29858 : istat = gethostname(buf, LEN(buf))
615 14929 : IF (istat /= 0) THEN
616 0 : WRITE (*, *) "m_hostnm failed"
617 0 : CALL m_abort()
618 : END IF
619 14929 : i = INDEX(buf, c_null_char) - 1
620 14929 : hname = buf(1:i)
621 : #endif
622 14929 : END SUBROUTINE m_hostnm
623 :
624 : ! **************************************************************************************************
625 : !> \brief ...
626 : !> \param curdir ...
627 : ! **************************************************************************************************
628 134504 : SUBROUTINE m_getcwd(curdir)
629 : CHARACTER(len=*), INTENT(OUT) :: curdir
630 : TYPE(C_PTR) :: stat
631 : INTEGER :: i
632 : CHARACTER(len=default_path_length), TARGET :: tmp
633 :
634 : INTERFACE
635 : FUNCTION getcwd(buf, buflen) BIND(C, name="getcwd") RESULT(stat)
636 : IMPORT
637 : CHARACTER(KIND=C_CHAR), DIMENSION(*) :: buf
638 : INTEGER(KIND=C_INT), VALUE :: buflen
639 : TYPE(C_PTR) :: stat
640 : END FUNCTION getcwd
641 : END INTERFACE
642 :
643 269008 : stat = getcwd(tmp, LEN(tmp))
644 134504 : IF (.NOT. C_ASSOCIATED(stat)) THEN
645 0 : WRITE (*, *) "m_getcwd failed"
646 0 : CALL m_abort()
647 : END IF
648 134504 : i = INDEX(tmp, c_null_char) - 1
649 134504 : curdir = tmp(1:i)
650 134504 : END SUBROUTINE m_getcwd
651 :
652 : ! **************************************************************************************************
653 : !> \brief ...
654 : !> \param dir ...
655 : !> \param ierror ...
656 : ! **************************************************************************************************
657 2966 : SUBROUTINE m_chdir(dir, ierror)
658 : CHARACTER(len=*), INTENT(IN) :: dir
659 : INTEGER, INTENT(OUT) :: ierror
660 :
661 : INTERFACE
662 : FUNCTION chdir(path) BIND(C, name="chdir") RESULT(errno)
663 : IMPORT
664 : CHARACTER(KIND=C_CHAR), DIMENSION(*) :: path
665 : INTEGER(KIND=C_INT) :: errno
666 : END FUNCTION chdir
667 : END INTERFACE
668 :
669 2966 : ierror = chdir(TRIM(dir)//c_null_char)
670 2966 : END SUBROUTINE m_chdir
671 :
672 : ! **************************************************************************************************
673 : !> \brief ...
674 : !> \param pid ...
675 : ! **************************************************************************************************
676 14929 : SUBROUTINE m_getpid(pid)
677 : INTEGER, INTENT(OUT) :: pid
678 :
679 : INTERFACE
680 : FUNCTION getpid() BIND(C, name="getpid") RESULT(pid)
681 : IMPORT
682 : INTEGER(KIND=C_INT) :: pid
683 : END FUNCTION getpid
684 : END INTERFACE
685 :
686 14929 : pid = getpid()
687 14929 : END SUBROUTINE m_getpid
688 :
689 : ! **************************************************************************************************
690 : !> \brief ...
691 : !> \param path ...
692 : !> \return ...
693 : ! **************************************************************************************************
694 11903 : FUNCTION m_unlink(path) RESULT(istat)
695 :
696 : CHARACTER(LEN=*), INTENT(IN) :: path
697 :
698 : INTEGER :: istat
699 :
700 : INTERFACE
701 : FUNCTION unlink(path) BIND(C, name="unlink") RESULT(errno)
702 : IMPORT
703 : CHARACTER(KIND=C_CHAR), DIMENSION(*) :: path
704 : INTEGER(KIND=C_INT) :: errno
705 : END FUNCTION unlink
706 : END INTERFACE
707 :
708 11903 : istat = unlink(TRIM(path)//c_null_char)
709 11903 : END FUNCTION m_unlink
710 :
711 : ! **************************************************************************************************
712 : !> \brief ...
713 : !> \param source ...
714 : !> \param TARGET ...
715 : ! **************************************************************************************************
716 11903 : SUBROUTINE m_mov(source, TARGET)
717 :
718 : CHARACTER(LEN=*), INTENT(IN) :: source, TARGET
719 :
720 : INTEGER :: istat
721 :
722 : INTERFACE
723 : FUNCTION rename(src, dest) BIND(C, name="rename") RESULT(errno)
724 : IMPORT
725 : CHARACTER(KIND=C_CHAR), DIMENSION(*) :: src, dest
726 : INTEGER(KIND=C_INT) :: errno
727 : END FUNCTION rename
728 : END INTERFACE
729 :
730 11903 : IF (TARGET == source) THEN
731 0 : WRITE (*, *) "Warning: m_mov ", TRIM(TARGET), " equals ", TRIM(source)
732 0 : RETURN
733 : END IF
734 :
735 : ! first remove target (needed on windows / mingw)
736 11903 : istat = m_unlink(TARGET)
737 : ! ignore istat of unlink
738 :
739 : ! now move
740 11903 : istat = rename(TRIM(source)//c_null_char, TRIM(TARGET)//c_null_char)
741 11903 : IF (istat /= 0) THEN
742 0 : WRITE (*, *) "Trying to move "//TRIM(source)//" to "//TRIM(TARGET)//"."
743 0 : WRITE (*, *) "rename returned status: ", istat
744 0 : WRITE (*, *) "Problem moving file"
745 0 : CALL m_abort()
746 : END IF
747 : END SUBROUTINE m_mov
748 :
749 : ! **************************************************************************************************
750 : !> \brief ...
751 : !> \param user ...
752 : ! **************************************************************************************************
753 14362 : SUBROUTINE m_getlog(user)
754 :
755 : CHARACTER(LEN=*), INTENT(OUT) :: user
756 :
757 : INTEGER :: istat
758 :
759 : ! on a posix system LOGNAME should be defined
760 14362 : CALL get_environment_variable("LOGNAME", value=user, status=istat)
761 : ! nope, check alternative
762 14362 : IF (istat /= 0) &
763 14362 : CALL get_environment_variable("USER", value=user, status=istat)
764 : ! nope, check alternative
765 14362 : IF (istat /= 0) &
766 14362 : CALL get_environment_variable("USERNAME", value=user, status=istat)
767 : ! fall back
768 14362 : IF (istat /= 0) &
769 14362 : user = "<unknown>"
770 :
771 14362 : END SUBROUTINE m_getlog
772 :
773 : ! **************************************************************************************************
774 : !> \brief Retrieve environment variable OMP_STACKSIZE
775 : !> \param omp_stacksize Value of OMP_STACKSIZE
776 : ! **************************************************************************************************
777 5044 : SUBROUTINE m_omp_get_stacksize(omp_stacksize)
778 : CHARACTER(LEN=*), INTENT(OUT) :: omp_stacksize
779 :
780 : INTEGER :: istat
781 :
782 5044 : omp_stacksize = ""
783 5044 : CALL get_environment_variable("OMP_STACKSIZE", value=omp_stacksize, status=istat)
784 : ! Fall back, if OMP_STACKSIZE is not set
785 5044 : IF (istat /= 0) omp_stacksize = "default"
786 :
787 5044 : END SUBROUTINE m_omp_get_stacksize
788 :
789 : END MODULE machine
|
