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