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(__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 254991 : SUBROUTINE m_flush(lunit)
136 : INTEGER, INTENT(IN) :: lunit
137 :
138 254991 : IF (flush_should_flush) FLUSH (lunit)
139 :
140 254991 : 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 3293714383 : FUNCTION m_walltime() RESULT(wt)
153 : REAL(KIND=dp) :: wt
154 :
155 : #if defined(__LIBXSMM)
156 3293714383 : wt = libxsmm_timer_duration(0_int_8, libxsmm_timer_tick())
157 : #else
158 : wt = omp_get_wtime()
159 : #endif
160 3293714383 : 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 5050 : 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 5050 : model_name = "UNKNOWN"
175 5050 : buffer = ""
176 5050 : OPEN (121245, FILE="/proc/cpuinfo", ACTION="READ", STATUS="OLD", ACCESS="STREAM", IOSTAT=stat)
177 5050 : IF (stat == 0) THEN
178 10347450 : DO i = 1, bufferlen
179 10347450 : READ (121245, END=999) buffer(I:I)
180 : END DO
181 5050 : 999 CLOSE (121245)
182 5050 : i = INDEX(buffer, "model name")
183 5050 : IF (i > 0) THEN
184 5050 : icol = i - 1 + INDEX(buffer(i:), ":")
185 5050 : iline = icol - 1 + INDEX(buffer(icol:), NEW_LINE('A'))
186 5050 : IF (iline == icol - 1) iline = bufferlen + 1
187 5050 : model_name = buffer(icol + 1:iline - 1)
188 : END IF
189 : END IF
190 5050 : 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 485211 : 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 485211 : m_cpuid = MACHINE_CPU_UNKNOWN
207 485211 : archid = libxsmm_get_target_archid()
208 485211 : IF (LIBXSMM_X86_SSE4 <= archid .AND. archid < LIBXSMM_X86_AVX) THEN
209 : m_cpuid = MACHINE_X86_SSE4
210 485211 : ELSE IF (LIBXSMM_X86_AVX <= archid .AND. archid < LIBXSMM_X86_AVX2) THEN
211 : m_cpuid = MACHINE_X86_AVX
212 485211 : 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 485211 : 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 481165 : 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 481165 : IF (PRESENT(typesize)) THEN
295 0 : nbytes = typesize
296 : ELSE
297 : nbytes = 8 ! double-precision
298 : END IF
299 :
300 481165 : IF (0 < nbytes .AND. nbytes <= 16) THEN ! sanity check
301 481165 : IF (PRESENT(cpuid)) THEN
302 10100 : isa = cpuid
303 : ELSE
304 471065 : 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 481165 : 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 481165 : m_cpuid_vlen = 1 ! scalar
326 : END SELECT
327 : ELSE ! fallback
328 : m_cpuid_vlen = 1 ! scalar
329 : END IF
330 481165 : 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 3286754813 : 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 3286754813 : wt = 0.0 ! fallback default
349 : #endif
350 :
351 3286754813 : 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 22839 : 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 22839 : CALL DATE_AND_TIME(date=date, time=time)
399 : timestamp = date(1:4)//"-"//date(5:6)//"-"//date(7:8)//" "// &
400 22839 : time(1:2)//":"//time(3:4)//":"//time(5:10)
401 :
402 22839 : 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 9893 : FUNCTION m_procrun(pid) RESULT(run_on)
423 : INTEGER, INTENT(IN) :: pid
424 : INTEGER :: run_on
425 :
426 : INTEGER :: istat
427 : INTERFACE
428 : FUNCTION kill(pid, sig) RESULT(errno) BIND(C, name="kill")
429 : IMPORT
430 : INTEGER(KIND=C_INT), VALUE :: pid, sig
431 : INTEGER(KIND=C_INT) :: errno
432 : END FUNCTION kill
433 : END INTERFACE
434 :
435 : ! If sig is 0, then no signal is sent, but error checking is still
436 : ! performed; this can be used to check for the existence of a process
437 : ! ID or process group ID.
438 :
439 9893 : istat = kill(pid=pid, sig=0)
440 9893 : IF (istat == 0) THEN
441 : run_on = 1 ! no error, process exists
442 : ELSE
443 0 : run_on = 0 ! error, process probably does not exist
444 : END IF
445 9893 : END FUNCTION m_procrun
446 :
447 : ! **************************************************************************************************
448 : !> \brief Returns the total amount of memory [bytes] in use, if known, zero otherwise
449 : !> \param mem ...
450 : ! **************************************************************************************************
451 2231372 : SUBROUTINE m_memory(mem)
452 :
453 : INTEGER(KIND=int_8), OPTIONAL, INTENT(OUT) :: mem
454 : INTEGER(KIND=int_8) :: mem_local
455 :
456 : ! __NO_STATM_ACCESS can be used to disable the stuff, if getpagesize
457 : ! lead to linking errors or /proc/self/statm can not be opened
458 : !
459 : #if defined(__NO_STATM_ACCESS)
460 : mem_local = 0
461 : #else
462 : INTEGER(KIND=int_8) :: m1, m2, m3
463 : CHARACTER(LEN=80) :: DATA
464 : INTEGER :: iostat, i
465 :
466 : ! the size of a page, might not be available everywhere
467 : INTERFACE
468 : FUNCTION getpagesize() BIND(C, name="getpagesize") RESULT(RES)
469 : IMPORT
470 : INTEGER(C_INT) :: RES
471 : END FUNCTION getpagesize
472 : END INTERFACE
473 :
474 : ! reading from statm
475 : !
476 2231372 : mem_local = -1
477 2231372 : DATA = ""
478 2231372 : OPEN (121245, FILE="/proc/self/statm", ACTION="READ", STATUS="OLD", ACCESS="STREAM")
479 78199895 : DO I = 1, 80
480 78199895 : READ (121245, END=999) DATA(I:I)
481 : END DO
482 2231372 : 999 CLOSE (121245)
483 2231372 : DATA(I:80) = ""
484 : ! m1 = total
485 : ! m2 = resident
486 : ! m3 = shared
487 2231372 : READ (DATA, *, IOSTAT=iostat) m1, m2, m3
488 2231372 : IF (iostat /= 0) THEN
489 : mem_local = 0
490 : ELSE
491 2231372 : mem_local = m2
492 : #if defined(__STATM_TOTAL)
493 : mem_local = m1
494 : #endif
495 : #if defined(__STATM_RESIDENT)
496 : mem_local = m2
497 : #endif
498 2231372 : mem_local = mem_local*getpagesize()
499 : END IF
500 : #endif
501 :
502 2231372 : m_memory_max = MAX(mem_local, m_memory_max)
503 2231372 : IF (PRESENT(mem)) mem = mem_local
504 :
505 2231372 : END SUBROUTINE m_memory
506 :
507 : ! **************************************************************************************************
508 : !> \brief get more detailed memory info, all units are bytes.
509 : !> the only 'useful' option is MemLikelyFree which is an estimate of remaining memory
510 : !> assumed to give info like /proc/meminfo while MeMLikelyFree is the amount of
511 : !> memory we're likely to be able to allocate, but not necessarily in one chunk
512 : !> zero means not available...
513 : !> \param MemTotal ...
514 : !> \param MemFree ...
515 : !> \param Buffers ...
516 : !> \param Cached ...
517 : !> \param Slab ...
518 : !> \param SReclaimable ...
519 : !> \param MemLikelyFree ...
520 : ! **************************************************************************************************
521 9893 : SUBROUTINE m_memory_details(MemTotal, MemFree, Buffers, Cached, Slab, SReclaimable, MemLikelyFree)
522 :
523 : INTEGER(kind=int_8), OPTIONAL :: MemTotal, MemFree, Buffers, Cached, Slab, SReclaimable, MemLikelyFree
524 :
525 : INTEGER, PARAMETER :: Nbuffer = 10000
526 : CHARACTER(LEN=Nbuffer) :: meminfo
527 :
528 : INTEGER :: i
529 :
530 9893 : MemTotal = 0
531 9893 : MemFree = 0
532 9893 : Buffers = 0
533 9893 : Cached = 0
534 9893 : Slab = 0
535 9893 : SReclaimable = 0
536 9893 : MemLikelyFree = 0
537 9893 : meminfo = ""
538 :
539 9893 : OPEN (UNIT=8123, file="/proc/meminfo", ACCESS="STREAM", ERR=901)
540 9893 : i = 0
541 15175993 : DO
542 15185886 : i = i + 1
543 15185886 : IF (i > Nbuffer) EXIT
544 15185886 : READ (8123, END=900, ERR=900) meminfo(i:i)
545 : END DO
546 : 900 CONTINUE
547 9893 : meminfo(i:Nbuffer) = ""
548 : 901 CONTINUE
549 9893 : CLOSE (8123, ERR=902)
550 : 902 CONTINUE
551 9893 : MemTotal = get_field_value_in_bytes('MemTotal:')
552 9893 : MemFree = get_field_value_in_bytes('MemFree:')
553 9893 : Buffers = get_field_value_in_bytes('Buffers:')
554 9893 : Cached = get_field_value_in_bytes('Cached:')
555 9893 : Slab = get_field_value_in_bytes('Slab:')
556 9893 : SReclaimable = get_field_value_in_bytes('SReclaimable:')
557 : ! opinions here vary but this might work
558 9893 : MemLikelyFree = MemFree + Buffers + Cached + SReclaimable
559 :
560 : CONTAINS
561 :
562 : ! **************************************************************************************************
563 : !> \brief ...
564 : !> \param field ...
565 : !> \return ...
566 : ! **************************************************************************************************
567 59358 : INTEGER(int_8) FUNCTION get_field_value_in_bytes(field)
568 : CHARACTER(LEN=*) :: field
569 :
570 : INTEGER :: start
571 : INTEGER(KIND=int_8) :: value
572 :
573 59358 : get_field_value_in_bytes = 0
574 59358 : start = INDEX(meminfo, field)
575 59358 : IF (start /= 0) THEN
576 59358 : start = start + LEN_TRIM(field)
577 59358 : IF (start < Nbuffer) THEN
578 59358 : READ (meminfo(start:), *, ERR=999, END=999) value
579 : ! XXXXXXX convert from Kb to bytes XXXXXXXX
580 59358 : get_field_value_in_bytes = value*1024
581 : 999 CONTINUE
582 : END IF
583 : END IF
584 59358 : END FUNCTION get_field_value_in_bytes
585 : END SUBROUTINE m_memory_details
586 :
587 : ! **************************************************************************************************
588 : !> \brief ...
589 : !> \param hname ...
590 : ! **************************************************************************************************
591 14947 : SUBROUTINE m_hostnm(hname)
592 : CHARACTER(len=*), INTENT(OUT) :: hname
593 : INTEGER :: istat, i
594 : CHARACTER(len=default_path_length) :: buf
595 :
596 : INTERFACE
597 : FUNCTION gethostname(buf, buflen) BIND(C, name="gethostname") RESULT(errno)
598 : IMPORT
599 : CHARACTER(KIND=C_CHAR), DIMENSION(*) :: buf
600 : INTEGER(KIND=C_INT), VALUE :: buflen
601 : INTEGER(KIND=C_INT) :: errno
602 : END FUNCTION gethostname
603 : END INTERFACE
604 :
605 29894 : istat = gethostname(buf, LEN(buf))
606 14947 : IF (istat /= 0) THEN
607 0 : WRITE (*, *) "m_hostnm failed"
608 0 : CALL m_abort()
609 : END IF
610 14947 : i = INDEX(buf, c_null_char) - 1
611 14947 : hname = buf(1:i)
612 14947 : END SUBROUTINE m_hostnm
613 :
614 : ! **************************************************************************************************
615 : !> \brief ...
616 : !> \param curdir ...
617 : ! **************************************************************************************************
618 134723 : SUBROUTINE m_getcwd(curdir)
619 : CHARACTER(len=*), INTENT(OUT) :: curdir
620 : TYPE(C_PTR) :: stat
621 : INTEGER :: i
622 : CHARACTER(len=default_path_length), TARGET :: tmp
623 :
624 : INTERFACE
625 : FUNCTION getcwd(buf, buflen) BIND(C, name="getcwd") RESULT(stat)
626 : IMPORT
627 : CHARACTER(KIND=C_CHAR), DIMENSION(*) :: buf
628 : INTEGER(KIND=C_INT), VALUE :: buflen
629 : TYPE(C_PTR) :: stat
630 : END FUNCTION getcwd
631 : END INTERFACE
632 :
633 269446 : stat = getcwd(tmp, LEN(tmp))
634 134723 : IF (.NOT. C_ASSOCIATED(stat)) THEN
635 0 : WRITE (*, *) "m_getcwd failed"
636 0 : CALL m_abort()
637 : END IF
638 134723 : i = INDEX(tmp, c_null_char) - 1
639 134723 : curdir = tmp(1:i)
640 134723 : END SUBROUTINE m_getcwd
641 :
642 : ! **************************************************************************************************
643 : !> \brief ...
644 : !> \param dir ...
645 : !> \param ierror ...
646 : ! **************************************************************************************************
647 2966 : SUBROUTINE m_chdir(dir, ierror)
648 : CHARACTER(len=*), INTENT(IN) :: dir
649 : INTEGER, INTENT(OUT) :: ierror
650 :
651 : INTERFACE
652 : FUNCTION chdir(path) BIND(C, name="chdir") RESULT(errno)
653 : IMPORT
654 : CHARACTER(KIND=C_CHAR), DIMENSION(*) :: path
655 : INTEGER(KIND=C_INT) :: errno
656 : END FUNCTION chdir
657 : END INTERFACE
658 :
659 2966 : ierror = chdir(TRIM(dir)//c_null_char)
660 2966 : END SUBROUTINE m_chdir
661 :
662 : ! **************************************************************************************************
663 : !> \brief ...
664 : !> \param pid ...
665 : ! **************************************************************************************************
666 14947 : SUBROUTINE m_getpid(pid)
667 : INTEGER, INTENT(OUT) :: pid
668 :
669 : INTERFACE
670 : FUNCTION getpid() BIND(C, name="getpid") RESULT(pid)
671 : IMPORT
672 : INTEGER(KIND=C_INT) :: pid
673 : END FUNCTION getpid
674 : END INTERFACE
675 :
676 14947 : pid = getpid()
677 14947 : END SUBROUTINE m_getpid
678 :
679 : ! **************************************************************************************************
680 : !> \brief ...
681 : !> \param path ...
682 : !> \return ...
683 : ! **************************************************************************************************
684 11908 : FUNCTION m_unlink(path) RESULT(istat)
685 :
686 : CHARACTER(LEN=*), INTENT(IN) :: path
687 :
688 : INTEGER :: istat
689 :
690 : INTERFACE
691 : FUNCTION unlink(path) BIND(C, name="unlink") RESULT(errno)
692 : IMPORT
693 : CHARACTER(KIND=C_CHAR), DIMENSION(*) :: path
694 : INTEGER(KIND=C_INT) :: errno
695 : END FUNCTION unlink
696 : END INTERFACE
697 :
698 11908 : istat = unlink(TRIM(path)//c_null_char)
699 11908 : END FUNCTION m_unlink
700 :
701 : ! **************************************************************************************************
702 : !> \brief ...
703 : !> \param source ...
704 : !> \param TARGET ...
705 : ! **************************************************************************************************
706 11908 : SUBROUTINE m_mov(source, TARGET)
707 :
708 : CHARACTER(LEN=*), INTENT(IN) :: source, TARGET
709 :
710 : INTEGER :: istat
711 :
712 : INTERFACE
713 : FUNCTION rename(src, dest) BIND(C, name="rename") RESULT(errno)
714 : IMPORT
715 : CHARACTER(KIND=C_CHAR), DIMENSION(*) :: src, dest
716 : INTEGER(KIND=C_INT) :: errno
717 : END FUNCTION rename
718 : END INTERFACE
719 :
720 11908 : IF (TARGET == source) THEN
721 0 : WRITE (*, *) "Warning: m_mov ", TRIM(TARGET), " equals ", TRIM(source)
722 0 : RETURN
723 : END IF
724 :
725 : ! first remove target (needed on windows)
726 11908 : istat = m_unlink(TARGET)
727 : ! ignore istat of unlink
728 :
729 : ! now move
730 11908 : istat = rename(TRIM(source)//c_null_char, TRIM(TARGET)//c_null_char)
731 11908 : IF (istat /= 0) THEN
732 0 : WRITE (*, *) "Trying to move "//TRIM(source)//" to "//TRIM(TARGET)//"."
733 0 : WRITE (*, *) "rename returned status: ", istat
734 0 : WRITE (*, *) "Problem moving file"
735 0 : CALL m_abort()
736 : END IF
737 : END SUBROUTINE m_mov
738 :
739 : ! **************************************************************************************************
740 : !> \brief ...
741 : !> \param user ...
742 : ! **************************************************************************************************
743 14380 : SUBROUTINE m_getlog(user)
744 :
745 : CHARACTER(LEN=*), INTENT(OUT) :: user
746 :
747 : INTEGER :: istat
748 :
749 : ! on a posix system LOGNAME should be defined
750 14380 : CALL get_environment_variable("LOGNAME", value=user, status=istat)
751 : ! nope, check alternative
752 14380 : IF (istat /= 0) &
753 14380 : CALL get_environment_variable("USER", value=user, status=istat)
754 : ! nope, check alternative
755 14380 : IF (istat /= 0) &
756 14380 : CALL get_environment_variable("USERNAME", value=user, status=istat)
757 : ! fall back
758 14380 : IF (istat /= 0) &
759 14380 : user = "<unknown>"
760 :
761 14380 : END SUBROUTINE m_getlog
762 :
763 : ! **************************************************************************************************
764 : !> \brief Retrieve environment variable OMP_STACKSIZE
765 : !> \param omp_stacksize Value of OMP_STACKSIZE
766 : ! **************************************************************************************************
767 5050 : SUBROUTINE m_omp_get_stacksize(omp_stacksize)
768 : CHARACTER(LEN=*), INTENT(OUT) :: omp_stacksize
769 :
770 : INTEGER :: istat
771 :
772 5050 : omp_stacksize = ""
773 5050 : CALL get_environment_variable("OMP_STACKSIZE", value=omp_stacksize, status=istat)
774 : ! Fall back, if OMP_STACKSIZE is not set
775 5050 : IF (istat /= 0) omp_stacksize = "default"
776 :
777 5050 : END SUBROUTINE m_omp_get_stacksize
778 :
779 : END MODULE machine
|
