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