Line data Source code
1 : !--------------------------------------------------------------------------------------------------!
2 : ! CP2K: A general program to perform molecular dynamics simulations !
3 : ! Copyright 2000-2024 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_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 243807 : SUBROUTINE m_flush(lunit)
130 : INTEGER, INTENT(IN) :: lunit
131 :
132 243807 : IF (flush_should_flush) FLUSH (lunit)
133 :
134 243807 : 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 3131786791 : FUNCTION m_walltime() RESULT(wt)
147 : REAL(KIND=dp) :: wt
148 :
149 : #if defined(__LIBXSMM)
150 3131786791 : wt = libxsmm_timer_duration(0_int_8, libxsmm_timer_tick())
151 : #else
152 : wt = omp_get_wtime()
153 : #endif
154 3131786791 : 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 4667 : SUBROUTINE m_cpuinfo(model_name)
161 : CHARACTER(LEN=default_string_length) :: model_name
162 :
163 : INTEGER, PARAMETER :: bufferlen = 2048
164 :
165 : CHARACTER(LEN=bufferlen) :: buffer
166 : INTEGER :: i, icol, iline, imod, stat
167 :
168 4667 : model_name = "UNKNOWN"
169 4667 : buffer = ""
170 4667 : OPEN (121245, FILE="/proc/cpuinfo", ACTION="READ", STATUS="OLD", ACCESS="STREAM", IOSTAT=stat)
171 4667 : IF (stat == 0) THEN
172 9562683 : DO i = 1, bufferlen
173 9562683 : READ (121245, END=999) buffer(I:I)
174 : END DO
175 4667 : 999 CLOSE (121245)
176 4667 : imod = INDEX(buffer, "model name")
177 4667 : IF (imod > 0) THEN
178 4667 : icol = imod - 1 + INDEX(buffer(imod:), ":")
179 4667 : iline = icol - 1 + INDEX(buffer(icol:), NEW_LINE('A'))
180 4667 : IF (iline == icol - 1) iline = bufferlen + 1
181 4667 : model_name = buffer(icol + 1:iline - 1)
182 : END IF
183 : END IF
184 4667 : 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 13600 : PURE FUNCTION m_cpuid() RESULT(cpuid)
194 : INTEGER :: cpuid
195 : #if defined(__LIBXSMM)
196 13600 : cpuid = libxsmm_get_target_archid()
197 13600 : IF (LIBXSMM_X86_SSE4 <= cpuid .AND. cpuid < LIBXSMM_X86_AVX) THEN
198 : cpuid = MACHINE_X86_SSE4
199 13600 : ELSE IF (LIBXSMM_X86_AVX <= cpuid .AND. cpuid < LIBXSMM_X86_AVX2) THEN
200 : cpuid = MACHINE_X86_AVX
201 13600 : ELSE IF (LIBXSMM_X86_AVX2 <= cpuid .AND. cpuid < LIBXSMM_X86_AVX512_SKX) THEN
202 : cpuid = MACHINE_X86_AVX2
203 0 : ELSE IF (LIBXSMM_X86_AVX512_SKX <= cpuid .AND. cpuid <= 1999) THEN
204 : cpuid = MACHINE_X86_AVX512
205 : #if defined(__LIBXSMM2)
206 0 : ELSE IF (LIBXSMM_AARCH64_V81 <= cpuid .AND. cpuid < LIBXSMM_AARCH64_SVE128) THEN
207 : cpuid = MACHINE_ARM_ARCH64
208 0 : ELSE IF (LIBXSMM_AARCH64_SVE128 <= cpuid .AND. cpuid < 2401) THEN ! LIBXSMM_AARCH64_SVE512
209 : cpuid = MACHINE_ARM_SVE256
210 0 : ELSE IF (2401 <= cpuid .AND. cpuid <= 2999) THEN
211 : cpuid = MACHINE_ARM_SVE512
212 : #endif
213 0 : ELSE IF (LIBXSMM_TARGET_ARCH_GENERIC <= cpuid .AND. cpuid <= 2999) THEN
214 : cpuid = MACHINE_CPU_GENERIC
215 : ELSE
216 0 : cpuid = MACHINE_CPU_UNKNOWN
217 : END IF
218 : #else
219 : cpuid = m_cpuid_static()
220 : #endif
221 13600 : 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 name or short name.
227 : !> \par History
228 : !> 06.2019 created [Hans Pabst]
229 : !> 09.2024 update+arm [Hans Pabst]
230 : ! **************************************************************************************************
231 0 : FUNCTION m_cpuid_name(cpuid)
232 : INTEGER :: cpuid
233 : CHARACTER(len=default_string_length), POINTER :: m_cpuid_name
234 :
235 : CHARACTER(len=default_string_length), SAVE, TARGET :: name_arm_arch64 = "arm_arch64", &
236 : name_arm_sve128 = "arm_sve128", &
237 : name_arm_sve256 = "arm_sve256", &
238 : name_arm_sve512 = "arm_sve512", &
239 : name_generic = "generic", &
240 : name_unknown = "unknown", &
241 : name_x86_avx = "x86_avx", &
242 : name_x86_avx2 = "x86_avx2", &
243 : name_x86_avx512 = "x86_avx512", &
244 : name_x86_sse4 = "x86_sse4"
245 :
246 0 : SELECT CASE (cpuid)
247 : CASE (MACHINE_CPU_GENERIC)
248 0 : m_cpuid_name => name_generic
249 : CASE (MACHINE_X86_SSE4)
250 0 : m_cpuid_name => name_x86_sse4
251 : CASE (MACHINE_X86_AVX)
252 0 : m_cpuid_name => name_x86_avx
253 : CASE (MACHINE_X86_AVX2)
254 0 : m_cpuid_name => name_x86_avx2
255 : CASE (MACHINE_X86_AVX512)
256 0 : m_cpuid_name => name_x86_avx512
257 : CASE (MACHINE_ARM_ARCH64)
258 0 : m_cpuid_name => name_arm_arch64
259 : CASE (MACHINE_ARM_SVE128)
260 0 : m_cpuid_name => name_arm_sve128
261 : CASE (MACHINE_ARM_SVE256)
262 0 : m_cpuid_name => name_arm_sve256
263 : CASE (MACHINE_ARM_SVE512)
264 0 : m_cpuid_name => name_arm_sve512
265 : CASE DEFAULT
266 0 : m_cpuid_name => name_unknown
267 : END SELECT
268 0 : END FUNCTION m_cpuid_name
269 :
270 : ! **************************************************************************************************
271 : !> \brief returns the energy used since some time in the past.
272 : !> The precise meaning depends on the infrastructure is available.
273 : !> In the cray_pm_energy case, this is the energy used by the node in kJ.
274 : !> \return ...
275 : !> \par History
276 : !> 09.2013 created [Joost VandeVondele, Ole Schuett]
277 : ! **************************************************************************************************
278 3125135881 : FUNCTION m_energy() RESULT(wt)
279 : REAL(KIND=dp) :: wt
280 :
281 : #if defined(__CRAY_PM_ENERGY)
282 : wt = read_energy("/sys/cray/pm_counters/energy")
283 : #elif defined(__CRAY_PM_ACCEL_ENERGY)
284 : wt = read_energy("/sys/cray/pm_counters/accel_energy")
285 : #else
286 3125135881 : wt = 0.0 ! fallback default
287 : #endif
288 :
289 3125135881 : END FUNCTION m_energy
290 :
291 : #if defined(__CRAY_PM_ACCEL_ENERGY) || defined(__CRAY_PM_ENERGY)
292 : ! **************************************************************************************************
293 : !> \brief reads energy values from the sys-filesystem
294 : !> \param filename ...
295 : !> \return ...
296 : !> \par History
297 : !> 09.2013 created [Joost VandeVondele, Ole Schuett]
298 : ! **************************************************************************************************
299 : FUNCTION read_energy(filename) RESULT(wt)
300 : CHARACTER(LEN=*) :: filename
301 : REAL(KIND=dp) :: wt
302 :
303 : CHARACTER(LEN=80) :: DATA
304 : INTEGER :: i, iostat
305 : INTEGER(KIND=int_8) :: raw
306 :
307 : OPEN (121245, FILE=filename, ACTION="READ", STATUS="OLD", ACCESS="STREAM")
308 : DO I = 1, 80
309 : READ (121245, END=999) DATA(I:I)
310 : END DO
311 : 999 CLOSE (121245)
312 : DATA(I:80) = ""
313 : READ (DATA, *, IOSTAT=iostat) raw
314 : IF (iostat .NE. 0) THEN
315 : wt = 0.0_dp
316 : ELSE
317 : ! convert from J to kJ
318 : wt = raw/1000.0_dp
319 : END IF
320 : END FUNCTION read_energy
321 : #endif
322 :
323 : ! **************************************************************************************************
324 : !> \brief returns a datum in human readable format using a standard Fortran routine
325 : !> \param cal_date ...
326 : !> \par History
327 : !> 10.2009 created [Joost VandeVondele]
328 : ! **************************************************************************************************
329 21570 : SUBROUTINE m_datum(cal_date)
330 : CHARACTER(len=*), INTENT(OUT) :: cal_date
331 :
332 : CHARACTER(len=10) :: time
333 : CHARACTER(len=8) :: date
334 :
335 21570 : CALL DATE_AND_TIME(date=date, time=time)
336 21570 : cal_date = date(1:4)//"-"//date(5:6)//"-"//date(7:8)//" "//time(1:2)//":"//time(3:4)//":"//time(5:10)
337 :
338 21570 : END SUBROUTINE m_datum
339 :
340 : ! **************************************************************************************************
341 : !> \brief Can be used to get a nice core
342 : ! **************************************************************************************************
343 0 : SUBROUTINE m_abort()
344 : INTERFACE
345 : SUBROUTINE abort() BIND(C, name="abort")
346 : END SUBROUTINE
347 : END INTERFACE
348 :
349 0 : CALL abort()
350 0 : END SUBROUTINE m_abort
351 :
352 : ! **************************************************************************************************
353 : !> \brief Returns if a process is running on the local machine
354 : !> 1 if yes and 0 if not
355 : !> \param pid ...
356 : !> \return ...
357 : ! **************************************************************************************************
358 2 : FUNCTION m_procrun(pid) RESULT(run_on)
359 : INTEGER, INTENT(IN) :: pid
360 : INTEGER :: run_on
361 : #if defined(__MINGW)
362 : run_on = 0
363 : #else
364 : INTEGER :: istat
365 :
366 : INTERFACE
367 : FUNCTION kill(pid, sig) BIND(C, name="kill") RESULT(errno)
368 : IMPORT
369 : INTEGER(KIND=C_INT), VALUE :: pid, sig
370 : INTEGER(KIND=C_INT) :: errno
371 : END FUNCTION
372 : END INTERFACE
373 :
374 : ! If sig is 0, then no signal is sent, but error checking is still
375 : ! performed; this can be used to check for the existence of a process
376 : ! ID or process group ID.
377 :
378 2 : istat = kill(pid=pid, sig=0)
379 2 : IF (istat == 0) THEN
380 : run_on = 1 ! no error, process exists
381 : ELSE
382 0 : run_on = 0 ! error, process probably does not exist
383 : END IF
384 : #endif
385 2 : END FUNCTION m_procrun
386 :
387 : ! **************************************************************************************************
388 : !> \brief Returns the total amount of memory [bytes] in use, if known, zero otherwise
389 : !> \param mem ...
390 : ! **************************************************************************************************
391 2113370 : SUBROUTINE m_memory(mem)
392 :
393 : INTEGER(KIND=int_8), OPTIONAL, INTENT(OUT) :: mem
394 : INTEGER(KIND=int_8) :: mem_local
395 :
396 : !
397 : ! __NO_STATM_ACCESS can be used to disable the stuff, if getpagesize
398 : ! lead to linking errors or /proc/self/statm can not be opened
399 : !
400 : #if defined(__NO_STATM_ACCESS)
401 : mem_local = 0
402 : #else
403 : INTEGER(KIND=int_8) :: m1, m2, m3
404 : CHARACTER(LEN=80) :: DATA
405 : INTEGER :: iostat, i
406 :
407 : ! the size of a page, might not be available everywhere
408 : INTERFACE
409 : FUNCTION getpagesize() BIND(C, name="getpagesize") RESULT(RES)
410 : IMPORT
411 : INTEGER(C_INT) :: RES
412 : END FUNCTION
413 : END INTERFACE
414 :
415 : !
416 : ! reading from statm
417 : !
418 2113370 : mem_local = -1
419 2113370 : DATA = ""
420 2113370 : OPEN (121245, FILE="/proc/self/statm", ACTION="READ", STATUS="OLD", ACCESS="STREAM")
421 80207762 : DO I = 1, 80
422 80207762 : READ (121245, END=999) DATA(I:I)
423 : END DO
424 2113370 : 999 CLOSE (121245)
425 2113370 : DATA(I:80) = ""
426 : ! m1 = total
427 : ! m2 = resident
428 : ! m3 = shared
429 2113370 : READ (DATA, *, IOSTAT=iostat) m1, m2, m3
430 2113370 : IF (iostat .NE. 0) THEN
431 : mem_local = 0
432 : ELSE
433 2113370 : mem_local = m2
434 : #if defined(__STATM_TOTAL)
435 : mem_local = m1
436 : #endif
437 : #if defined(__STATM_RESIDENT)
438 : mem_local = m2
439 : #endif
440 2113370 : mem_local = mem_local*getpagesize()
441 : END IF
442 : #endif
443 :
444 2113370 : m_memory_max = MAX(mem_local, m_memory_max)
445 2113370 : IF (PRESENT(mem)) mem = mem_local
446 :
447 2113370 : END SUBROUTINE m_memory
448 :
449 : ! **************************************************************************************************
450 : !> \brief get more detailed memory info, all units are bytes.
451 : !> the only 'useful' option is MemLikelyFree which is an estimate of remaining memory
452 : !> assumed to give info like /proc/meminfo while MeMLikelyFree is the amount of
453 : !> memory we're likely to be able to allocate, but not necessarily in one chunk
454 : !> zero means not available...
455 : !> \param MemTotal ...
456 : !> \param MemFree ...
457 : !> \param Buffers ...
458 : !> \param Cached ...
459 : !> \param Slab ...
460 : !> \param SReclaimable ...
461 : !> \param MemLikelyFree ...
462 : ! **************************************************************************************************
463 9127 : SUBROUTINE m_memory_details(MemTotal, MemFree, Buffers, Cached, Slab, SReclaimable, MemLikelyFree)
464 :
465 : INTEGER(kind=int_8), OPTIONAL :: MemTotal, MemFree, Buffers, Cached, Slab, SReclaimable, MemLikelyFree
466 :
467 : INTEGER, PARAMETER :: Nbuffer = 10000
468 : CHARACTER(LEN=Nbuffer) :: meminfo
469 :
470 : INTEGER :: i
471 :
472 9127 : MemTotal = 0
473 9127 : MemFree = 0
474 9127 : Buffers = 0
475 9127 : Cached = 0
476 9127 : Slab = 0
477 9127 : SReclaimable = 0
478 9127 : MemLikelyFree = 0
479 9127 : meminfo = ""
480 :
481 9127 : OPEN (UNIT=8123, file="/proc/meminfo", ACCESS="STREAM", ERR=901)
482 9127 : i = 0
483 14009945 : DO
484 14019072 : i = i + 1
485 14019072 : IF (i > Nbuffer) EXIT
486 14019072 : READ (8123, END=900, ERR=900) meminfo(i:i)
487 : END DO
488 : 900 CONTINUE
489 9127 : meminfo(i:Nbuffer) = ""
490 : 901 CONTINUE
491 9127 : CLOSE (8123, ERR=902)
492 : 902 CONTINUE
493 9127 : MemTotal = get_field_value_in_bytes('MemTotal:')
494 9127 : MemFree = get_field_value_in_bytes('MemFree:')
495 9127 : Buffers = get_field_value_in_bytes('Buffers:')
496 9127 : Cached = get_field_value_in_bytes('Cached:')
497 9127 : Slab = get_field_value_in_bytes('Slab:')
498 9127 : SReclaimable = get_field_value_in_bytes('SReclaimable:')
499 : ! opinions here vary but this might work
500 9127 : MemLikelyFree = MemFree + Buffers + Cached + SReclaimable
501 :
502 : CONTAINS
503 :
504 : ! **************************************************************************************************
505 : !> \brief ...
506 : !> \param field ...
507 : !> \return ...
508 : ! **************************************************************************************************
509 54762 : INTEGER(int_8) FUNCTION get_field_value_in_bytes(field)
510 : CHARACTER(LEN=*) :: field
511 :
512 : INTEGER :: start
513 : INTEGER(KIND=int_8) :: value
514 :
515 54762 : get_field_value_in_bytes = 0
516 54762 : start = INDEX(meminfo, field)
517 54762 : IF (start .NE. 0) THEN
518 54762 : start = start + LEN_TRIM(field)
519 54762 : IF (start .LT. Nbuffer) THEN
520 54762 : READ (meminfo(start:), *, ERR=999, END=999) value
521 : ! XXXXXXX convert from Kb to bytes XXXXXXXX
522 54762 : get_field_value_in_bytes = value*1024
523 : 999 CONTINUE
524 : END IF
525 : END IF
526 54762 : END FUNCTION
527 : END SUBROUTINE m_memory_details
528 :
529 : ! **************************************************************************************************
530 : !> \brief ...
531 : !> \param hname ...
532 : ! **************************************************************************************************
533 13477 : SUBROUTINE m_hostnm(hname)
534 : CHARACTER(len=*), INTENT(OUT) :: hname
535 : #if defined(__MINGW)
536 : ! While there is a gethostname in the Windows (POSIX) API, it requires that winsocks is
537 : ! initialised prior to using it via WSAStartup(..), respectively cleaned up at the end via WSACleanup().
538 : hname = "<unknown>"
539 : #else
540 : INTEGER :: istat, i
541 : CHARACTER(len=default_path_length) :: buf
542 :
543 : INTERFACE
544 : FUNCTION gethostname(buf, buflen) BIND(C, name="gethostname") RESULT(errno)
545 : IMPORT
546 : CHARACTER(KIND=C_CHAR), DIMENSION(*) :: buf
547 : INTEGER(KIND=C_INT), VALUE :: buflen
548 : INTEGER(KIND=C_INT) :: errno
549 : END FUNCTION
550 : END INTERFACE
551 :
552 26954 : istat = gethostname(buf, LEN(buf))
553 13477 : IF (istat /= 0) THEN
554 0 : WRITE (*, *) "m_hostnm failed"
555 0 : CALL m_abort()
556 : END IF
557 13477 : i = INDEX(buf, c_null_char) - 1
558 13477 : hname = buf(1:i)
559 : #endif
560 13477 : END SUBROUTINE m_hostnm
561 :
562 : ! **************************************************************************************************
563 : !> \brief ...
564 : !> \param curdir ...
565 : ! **************************************************************************************************
566 130324 : SUBROUTINE m_getcwd(curdir)
567 : CHARACTER(len=*), INTENT(OUT) :: curdir
568 : TYPE(C_PTR) :: stat
569 : INTEGER :: i
570 : CHARACTER(len=default_path_length), TARGET :: tmp
571 :
572 : INTERFACE
573 : FUNCTION getcwd(buf, buflen) BIND(C, name="getcwd") RESULT(stat)
574 : IMPORT
575 : CHARACTER(KIND=C_CHAR), DIMENSION(*) :: buf
576 : INTEGER(KIND=C_INT), VALUE :: buflen
577 : TYPE(C_PTR) :: stat
578 : END FUNCTION
579 : END INTERFACE
580 :
581 260648 : stat = getcwd(tmp, LEN(tmp))
582 130324 : IF (.NOT. C_ASSOCIATED(stat)) THEN
583 0 : WRITE (*, *) "m_getcwd failed"
584 0 : CALL m_abort()
585 : END IF
586 130324 : i = INDEX(tmp, c_null_char) - 1
587 130324 : curdir = tmp(1:i)
588 130324 : END SUBROUTINE m_getcwd
589 :
590 : ! **************************************************************************************************
591 : !> \brief ...
592 : !> \param dir ...
593 : !> \param ierror ...
594 : ! **************************************************************************************************
595 2914 : SUBROUTINE m_chdir(dir, ierror)
596 : CHARACTER(len=*), INTENT(IN) :: dir
597 : INTEGER, INTENT(OUT) :: ierror
598 :
599 : INTERFACE
600 : FUNCTION chdir(path) BIND(C, name="chdir") RESULT(errno)
601 : IMPORT
602 : CHARACTER(KIND=C_CHAR), DIMENSION(*) :: path
603 : INTEGER(KIND=C_INT) :: errno
604 : END FUNCTION
605 : END INTERFACE
606 :
607 2914 : ierror = chdir(TRIM(dir)//c_null_char)
608 2914 : END SUBROUTINE m_chdir
609 :
610 : ! **************************************************************************************************
611 : !> \brief ...
612 : !> \param pid ...
613 : ! **************************************************************************************************
614 13477 : SUBROUTINE m_getpid(pid)
615 : INTEGER, INTENT(OUT) :: pid
616 :
617 : INTERFACE
618 : FUNCTION getpid() BIND(C, name="getpid") RESULT(pid)
619 : IMPORT
620 : INTEGER(KIND=C_INT) :: pid
621 : END FUNCTION
622 : END INTERFACE
623 :
624 13477 : pid = getpid()
625 13477 : END SUBROUTINE m_getpid
626 :
627 : ! **************************************************************************************************
628 : !> \brief ...
629 : !> \param path ...
630 : !> \return ...
631 : ! **************************************************************************************************
632 11472 : FUNCTION m_unlink(path) RESULT(istat)
633 :
634 : CHARACTER(LEN=*), INTENT(IN) :: path
635 :
636 : INTEGER :: istat
637 :
638 : INTERFACE
639 : FUNCTION unlink(path) BIND(C, name="unlink") RESULT(errno)
640 : IMPORT
641 : CHARACTER(KIND=C_CHAR), DIMENSION(*) :: path
642 : INTEGER(KIND=C_INT) :: errno
643 : END FUNCTION
644 : END INTERFACE
645 :
646 11472 : istat = unlink(TRIM(path)//c_null_char)
647 11472 : END FUNCTION m_unlink
648 :
649 : ! **************************************************************************************************
650 : !> \brief ...
651 : !> \param source ...
652 : !> \param TARGET ...
653 : ! **************************************************************************************************
654 11472 : SUBROUTINE m_mov(source, TARGET)
655 :
656 : CHARACTER(LEN=*), INTENT(IN) :: source, TARGET
657 :
658 : INTEGER :: istat
659 :
660 : INTERFACE
661 : FUNCTION rename(src, dest) BIND(C, name="rename") RESULT(errno)
662 : IMPORT
663 : CHARACTER(KIND=C_CHAR), DIMENSION(*) :: src, dest
664 : INTEGER(KIND=C_INT) :: errno
665 : END FUNCTION
666 : END INTERFACE
667 :
668 11472 : IF (TARGET == source) THEN
669 0 : WRITE (*, *) "Warning: m_mov ", TRIM(TARGET), " equals ", TRIM(source)
670 0 : RETURN
671 : END IF
672 :
673 : ! first remove target (needed on windows / mingw)
674 11472 : istat = m_unlink(TARGET)
675 : ! ignore istat of unlink
676 :
677 : ! now move
678 11472 : istat = rename(TRIM(source)//c_null_char, TRIM(TARGET)//c_null_char)
679 11472 : IF (istat .NE. 0) THEN
680 0 : WRITE (*, *) "Trying to move "//TRIM(source)//" to "//TRIM(TARGET)//"."
681 0 : WRITE (*, *) "rename returned status: ", istat
682 0 : WRITE (*, *) "Problem moving file"
683 0 : CALL m_abort()
684 : END IF
685 : END SUBROUTINE m_mov
686 :
687 : ! **************************************************************************************************
688 : !> \brief ...
689 : !> \param user ...
690 : ! **************************************************************************************************
691 13231 : SUBROUTINE m_getlog(user)
692 :
693 : CHARACTER(LEN=*), INTENT(OUT) :: user
694 :
695 : INTEGER :: istat
696 :
697 : ! on a posix system LOGNAME should be defined
698 13231 : CALL get_environment_variable("LOGNAME", value=user, status=istat)
699 : ! nope, check alternative
700 13231 : IF (istat /= 0) &
701 13231 : CALL get_environment_variable("USER", value=user, status=istat)
702 : ! nope, check alternative
703 13231 : IF (istat /= 0) &
704 13231 : CALL get_environment_variable("USERNAME", value=user, status=istat)
705 : ! fall back
706 13231 : IF (istat /= 0) &
707 13231 : user = "<unknown>"
708 :
709 13231 : END SUBROUTINE m_getlog
710 :
711 : ! **************************************************************************************************
712 : !> \brief Retrieve environment variable OMP_STACKSIZE
713 : !> \param omp_stacksize Value of OMP_STACKSIZE
714 : ! **************************************************************************************************
715 4667 : SUBROUTINE m_omp_get_stacksize(omp_stacksize)
716 : CHARACTER(LEN=*), INTENT(OUT) :: omp_stacksize
717 :
718 : INTEGER :: istat
719 :
720 4667 : omp_stacksize = ""
721 4667 : CALL get_environment_variable("OMP_STACKSIZE", value=omp_stacksize, status=istat)
722 : ! Fall back, if OMP_STACKSIZE is not set
723 4667 : IF (istat /= 0) omp_stacksize = "default"
724 :
725 4667 : END SUBROUTINE m_omp_get_stacksize
726 :
727 : END MODULE machine
|
