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