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