machine.F

Go to the documentation of this file.

!--------------------------------------------------------------------------------------------------!
!   CP2K: A general program to perform molecular dynamics simulations                              !
!   Copyright 2000-2024 CP2K developers group <https://cp2k.org>                                   !
!                                                                                                  !
!   SPDX-License-Identifier: GPL-2.0-or-later                                                      !
!--------------------------------------------------------------------------------------------------!
 
! **************************************************************************************************
!> \brief Machine interface based on Fortran 2003 and POSIX
!> \par History
!>      JGH (05.07.2001) : added G95 interface
!>      - m_flush added (12.06.2002,MK)
!>      - Missing print_memory added (24.09.2002,MK)
!>      - Migrate to generic implementation based on F2003 + POSIX (2014, Ole Schuett)
!> \author APSI, JGH, Ole Schuett
! **************************************************************************************************
MODULE machine
   USE iso_c_binding, ONLY: c_char, &
                            c_int, &
                            c_ptr, &
                            c_null_char, &
                            c_associated
   USE iso_fortran_env, ONLY: input_unit, &
                              output_unit
   USE omp_lib, ONLY: omp_get_wtime
   USE kinds, ONLY: default_path_length, &
                    default_string_length, &
                    dp, &
                    int_8
#if defined(__LIBXSMM)
   USE libxsmm, ONLY: libxsmm_timer_tick, &
                      libxsmm_timer_duration, &
                      libxsmm_get_target_archid, &
                      libxsmm_x86_sse4
#endif
 
   IMPLICIT NONE
 
   ! Except for some error handling code, all code should
   ! get a unit number from the print keys or from the logger, in order
   ! to guarantee correct output behavior,
   ! for example in farming or path integral runs
   ! default_input_unit should never be used
   ! but we need to know what it is, as we should not try to open it for output
   INTEGER, PUBLIC, PARAMETER                   :: default_output_unit = output_unit, &
                                                   default_input_unit = input_unit
 
#include "machine_cpuid.h"
   ! Enumerates the target architectures or instruction set extensions.
   ! A feature is present if within range for the respective architecture.
   ! For example, to check for MACHINE_X86_AVX the following is true:
   ! MACHINE_X86_AVX <= m_cpuid() and MACHINE_X86 >= m_cpuid().
   ! For example, to check for MACHINE_ARM_SOME the following is true:
   ! MACHINE_ARM_SOME <= m_cpuid() and MACHINE_ARM >= m_cpuid().
   INTEGER, PUBLIC, PARAMETER :: &
      machine_cpu_generic = cp_machine_cpu_generic, &
      machine_x86_sse4 = cp_machine_x86_sse4, &
      machine_x86_avx = cp_machine_x86_avx, &
      machine_x86_avx2 = cp_machine_x86_avx2, &
      machine_x86_avx512 = cp_machine_x86_avx512, &
      machine_x86 = machine_x86_avx512 ! marks end of range
   ! other arch to be added as needed e.g.,
   !MACHINE_ARM_SOME    = 2000
   !MACHINE_ARM_ELSE    = 2001
   !MACHINE_ARM = MACHINE_ARM_ELSE
   !MACHINE_PWR_????    = 3000
 
   PRIVATE
 
   PUBLIC :: m_walltime, m_datum, m_hostnm, m_flush, &
             m_getcwd, m_getlog, m_getpid, m_procrun, m_abort, &
             m_chdir, m_mov, m_memory, m_memory_details, m_energy, &
             m_cpuinfo, m_cpuid_static, m_cpuid, m_cpuid_name, &
             m_get_omp_stacksize
 
   INTERFACE
      ! **********************************************************************************************
      !> \brief Target architecture or instruction set extension according to compiler target flags.
      !> \return cpuid according to MACHINE_* integer-parameter.
      !> \par History
      !>      04.2019 created [Hans Pabst]
      ! **********************************************************************************************
      PURE FUNCTION m_cpuid_static() BIND(C)
         IMPORT :: c_int
         INTEGER(C_INT) :: m_cpuid_static
      END FUNCTION m_cpuid_static
   END INTERFACE
 
   ! Flushing is enabled by default because without it crash reports can get lost.
   ! For performance reasons it can be disabled via the input in &GLOBAL.
   LOGICAL, SAVE, PUBLIC :: flush_should_flush = .true.
 
   INTEGER(KIND=int_8), SAVE, PUBLIC :: m_memory_max = 0
 
CONTAINS
 
! **************************************************************************************************
!> \brief flushes units if the &GLOBAL flag is set accordingly
!> \param lunit ...
!> \par History
!>      10.2008 created [Joost VandeVondele]
!> \note
!>      flushing might degrade performance significantly (30% and more)
! **************************************************************************************************
   SUBROUTINE m_flush(lunit)
      INTEGER, INTENT(IN)                                :: lunit
 
      IF (flush_should_flush) FLUSH (lunit)
 
   END SUBROUTINE
 
! **************************************************************************************************
!> \brief returns time from a real-time clock, protected against rolling
!>      early/easily
!> \return ...
!> \par History
!>      03.2006 created [Joost VandeVondele]
!> \note
!>      same implementation for all machines.
!>      might still roll, if not called multiple times per count_max/count_rate
! **************************************************************************************************
   FUNCTION m_walltime() RESULT(wt)
      REAL(kind=dp)                                      :: wt
 
#if defined(__LIBXSMM)
      wt = libxsmm_timer_duration(0_int_8, libxsmm_timer_tick())
#else
      wt = omp_get_wtime()
#endif
   END FUNCTION m_walltime
 
! **************************************************************************************************
!> \brief reads /proc/cpuinfo if it exists (i.e. Linux) to return relevant info
!> \param model_name as obtained from the 'model name' field, UNKNOWN otherwise
! **************************************************************************************************
   SUBROUTINE m_cpuinfo(model_name)
      CHARACTER(LEN=default_string_length)               :: model_name
 
      INTEGER, PARAMETER                                 :: bufferlen = 2048
 
      CHARACTER(LEN=bufferlen)                           :: buffer
      INTEGER                                            :: i, icol, iline, imod, stat
 
      model_name = "UNKNOWN"
      buffer = ""
      OPEN (121245, file="/proc/cpuinfo", action="READ", status="OLD", access="STREAM", iostat=stat)
      IF (stat == 0) THEN
         DO i = 1, bufferlen
            READ (121245, END=999) buffer(I:I)
         END DO
999      CLOSE (121245)
         imod = index(buffer, "model name")
         IF (imod > 0) THEN
            icol = imod - 1 + index(buffer(imod:), ":")
            iline = icol - 1 + index(buffer(icol:), new_line('A'))
            IF (iline == icol - 1) iline = bufferlen + 1
            model_name = buffer(icol + 1:iline - 1)
         END IF
      END IF
   END SUBROUTINE m_cpuinfo
 
! **************************************************************************************************
!> \brief Target architecture or instruction set extension according to CPU-check at runtime.
!> \return cpuid according to MACHINE_* integer-parameter.
!> \par History
!>      04.2019 created [Hans Pabst]
! **************************************************************************************************
   PURE FUNCTION m_cpuid() RESULT(cpuid)
      INTEGER :: cpuid
#if defined(__LIBXSMM)
      cpuid = libxsmm_get_target_archid()
      cpuid = merge(min(machine_x86_sse4 + cpuid - libxsmm_x86_sse4, machine_x86), &
                    machine_cpu_generic, libxsmm_x86_sse4 .LE. cpuid)
#else
      cpuid = m_cpuid_static()
#endif
   END FUNCTION m_cpuid
 
! **************************************************************************************************
!> \brief Determine name of target architecture for a given CPUID.
!> \param cpuid integer value (MACHINE_*)
!> \return name or short name.
!> \par History
!>      06.2019 created [Hans Pabst]
! **************************************************************************************************
   FUNCTION m_cpuid_name(cpuid)
      INTEGER                                            :: cpuid
      CHARACTER(len=default_string_length), POINTER      :: m_cpuid_name
 
      CHARACTER(len=default_string_length), SAVE, TARGET :: name_generic = "generic", &
         name_unknown = "unknown", name_x86_avx = "x86_avx", name_x86_avx2 = "x86_avx2", &
         name_x86_avx512 = "x86_avx512", name_x86_sse4 = "x86_sse4"
 
      SELECT CASE (cpuid)
      CASE (machine_cpu_generic)
         m_cpuid_name => name_generic
      CASE (machine_x86_sse4)
         m_cpuid_name => name_x86_sse4
      CASE (machine_x86_avx)
         m_cpuid_name => name_x86_avx
      CASE (machine_x86_avx2)
         m_cpuid_name => name_x86_avx2
      CASE (machine_x86_avx512)
         m_cpuid_name => name_x86_avx512
      CASE DEFAULT
         m_cpuid_name => name_unknown
      END SELECT
   END FUNCTION m_cpuid_name
 
! **************************************************************************************************
!> \brief returns the energy used since some time in the past.
!>        The precise meaning depends on the infrastructure is available.
!>        In the cray_pm_energy case, this is the energy used by the node in kJ.
!> \return ...
!> \par History
!>      09.2013 created [Joost VandeVondele, Ole Schuett]
! **************************************************************************************************
   FUNCTION m_energy() RESULT(wt)
      REAL(kind=dp)                            :: wt
 
#if defined(__CRAY_PM_ENERGY)
      wt = read_energy("/sys/cray/pm_counters/energy")
#elif defined(__CRAY_PM_ACCEL_ENERGY)
      wt = read_energy("/sys/cray/pm_counters/accel_energy")
#else
      wt = 0.0 ! fallback default
#endif
 
   END FUNCTION m_energy
 
#if defined(__CRAY_PM_ACCEL_ENERGY) || defined(__CRAY_PM_ENERGY)
! **************************************************************************************************
!> \brief reads energy values from the sys-filesystem
!> \param filename ...
!> \return ...
!> \par History
!>      09.2013 created [Joost VandeVondele, Ole Schuett]
! **************************************************************************************************
   FUNCTION read_energy(filename) RESULT(wt)
      CHARACTER(LEN=*)                                   :: filename
      REAL(kind=dp)                                      :: wt
 
      CHARACTER(LEN=80)                                  :: data
      INTEGER                                            :: i, iostat
      INTEGER(KIND=int_8)                                :: raw
 
      OPEN (121245, file=filename, action="READ", status="OLD", access="STREAM")
      DO i = 1, 80
         READ (121245, END=999) DATA(I:I)
      END DO
999   CLOSE (121245)
      DATA(i:80) = ""
      READ (DATA, *, iostat=iostat) raw
      IF (iostat .NE. 0) THEN
         wt = 0.0_dp
      ELSE
         ! convert from J to kJ
         wt = raw/1000.0_dp
      END IF
   END FUNCTION read_energy
#endif
 
! **************************************************************************************************
!> \brief returns a datum in human readable format using a standard Fortran routine
!> \param cal_date ...
!> \par History
!>      10.2009 created [Joost VandeVondele]
! **************************************************************************************************
   SUBROUTINE m_datum(cal_date)
      CHARACTER(len=*), INTENT(OUT)                      :: cal_date
 
      CHARACTER(len=10)                                  :: time
      CHARACTER(len=8)                                   :: date
 
      CALL date_and_time(date=date, time=time)
      cal_date = date(1:4)//"-"//date(5:6)//"-"//date(7:8)//" "//time(1:2)//":"//time(3:4)//":"//time(5:10)
 
   END SUBROUTINE m_datum
 
! **************************************************************************************************
!> \brief Can be used to get a nice core
! **************************************************************************************************
   SUBROUTINE m_abort()
      INTERFACE
         SUBROUTINE abort() BIND(C, name="abort")
         END SUBROUTINE
      END INTERFACE
 
      CALL abort()
   END SUBROUTINE m_abort
 
! **************************************************************************************************
!> \brief Returns if a process is running on the local machine
!>        1 if yes and 0 if not
!> \param pid ...
!> \return ...
! **************************************************************************************************
   FUNCTION m_procrun(pid) RESULT(run_on)
      INTEGER, INTENT(IN)       ::   pid
      INTEGER                   ::   run_on
#if defined(__MINGW)
      run_on = 0
#else
      INTEGER                   ::   istat
 
      INTERFACE
         FUNCTION kill(pid, sig) BIND(C, name="kill") RESULT(errno)
            IMPORT
            INTEGER(KIND=C_INT), VALUE                :: pid, sig
            INTEGER(KIND=C_INT)                      :: errno
         END FUNCTION
      END INTERFACE
 
      ! If sig is 0, then no signal is sent, but error checking is still
      ! performed; this can be used to check for the existence of a process
      ! ID or process group ID.
 
      istat = kill(pid=pid, sig=0)
      IF (istat == 0) THEN
         run_on = 1 ! no error, process exists
      ELSE
         run_on = 0 ! error, process probably does not exist
      END IF
#endif
   END FUNCTION m_procrun
 
! **************************************************************************************************
!> \brief Returns the total amount of memory [bytes] in use, if known, zero otherwise
!> \param mem ...
! **************************************************************************************************
   SUBROUTINE m_memory(mem)
 
      INTEGER(KIND=int_8), OPTIONAL, INTENT(OUT)         :: mem
      INTEGER(KIND=int_8)                      :: mem_local
 
      !
      ! __NO_STATM_ACCESS can be used to disable the stuff, if getpagesize
      ! lead to linking errors or /proc/self/statm can not be opened
      !
#if defined(__NO_STATM_ACCESS)
      mem_local = 0
#else
      INTEGER(KIND=int_8)                      :: m1, m2, m3
      CHARACTER(LEN=80) :: data
      INTEGER :: iostat, i
 
      ! the size of a page, might not be available everywhere
      INTERFACE
         FUNCTION getpagesize() BIND(C, name="getpagesize") RESULT(RES)
            IMPORT
            INTEGER(C_INT) :: res
         END FUNCTION
      END INTERFACE
 
      !
      ! reading from statm
      !
      mem_local = -1
      DATA = ""
      OPEN (121245, file="/proc/self/statm", action="READ", status="OLD", access="STREAM")
      DO i = 1, 80
         READ (121245, END=999) DATA(I:I)
      END DO
999   CLOSE (121245)
      DATA(i:80) = ""
      ! m1 = total
      ! m2 = resident
      ! m3 = shared
      READ (DATA, *, iostat=iostat) m1, m2, m3
      IF (iostat .NE. 0) THEN
         mem_local = 0
      ELSE
         mem_local = m2
#if defined(__STATM_TOTAL)
         mem_local = m1
#endif
#if defined(__STATM_RESIDENT)
         mem_local = m2
#endif
         mem_local = mem_local*getpagesize()
      END IF
#endif
 
      m_memory_max = max(mem_local, m_memory_max)
      IF (PRESENT(mem)) mem = mem_local
 
   END SUBROUTINE m_memory
 
! **************************************************************************************************
!> \brief get more detailed memory info, all units are bytes.
!>         the only 'useful' option is MemLikelyFree which is an estimate of remaining memory
!>         assumed to give info like /proc/meminfo while MeMLikelyFree is the amount of
!>         memory we're likely to be able to allocate, but not necessarily in one chunk
!>         zero means not available...
!> \param MemTotal ...
!> \param MemFree ...
!> \param Buffers ...
!> \param Cached ...
!> \param Slab ...
!> \param SReclaimable ...
!> \param MemLikelyFree ...
! **************************************************************************************************
   SUBROUTINE m_memory_details(MemTotal, MemFree, Buffers, Cached, Slab, SReclaimable, MemLikelyFree)
 
      INTEGER(kind=int_8), OPTIONAL :: memtotal, memfree, buffers, cached, slab, sreclaimable, memlikelyfree
 
      INTEGER, PARAMETER :: nbuffer = 10000
      CHARACTER(LEN=Nbuffer) :: meminfo
 
      INTEGER :: i
 
      memtotal = 0
      memfree = 0
      buffers = 0
      cached = 0
      slab = 0
      sreclaimable = 0
      memlikelyfree = 0
      meminfo = ""
 
      OPEN (unit=8123, file="/proc/meminfo", access="STREAM", err=901)
      i = 0
      DO
         i = i + 1
         IF (i > nbuffer) EXIT
         READ (8123, END=900, ERR=900) meminfo(i:i)
      END DO
900   CONTINUE
      meminfo(i:nbuffer) = ""
901   CONTINUE
      CLOSE (8123, err=902)
902   CONTINUE
      memtotal = get_field_value_in_bytes('MemTotal:')
      memfree = get_field_value_in_bytes('MemFree:')
      buffers = get_field_value_in_bytes('Buffers:')
      cached = get_field_value_in_bytes('Cached:')
      slab = get_field_value_in_bytes('Slab:')
      sreclaimable = get_field_value_in_bytes('SReclaimable:')
      ! opinions here vary but this might work
      memlikelyfree = memfree + buffers + cached + sreclaimable
 
   CONTAINS
 
! **************************************************************************************************
!> \brief ...
!> \param field ...
!> \return ...
! **************************************************************************************************
      INTEGER(int_8) FUNCTION get_field_value_in_bytes(field)
      CHARACTER(LEN=*)                                   :: field
 
      INTEGER                                            :: start
      INTEGER(KIND=int_8)                                :: value
 
         get_field_value_in_bytes = 0
         start = index(meminfo, field)
         IF (start .NE. 0) THEN
            start = start + len_trim(field)
            IF (start .LT. nbuffer) THEN
               READ (meminfo(start:), *, err=999, END=999) value
               ! XXXXXXX convert from Kb to bytes XXXXXXXX
               get_field_value_in_bytes = value*1024
999            CONTINUE
            END IF
         END IF
      END FUNCTION
   END SUBROUTINE m_memory_details
 
! **************************************************************************************************
!> \brief ...
!> \param hname ...
! **************************************************************************************************
   SUBROUTINE m_hostnm(hname)
      CHARACTER(len=*), INTENT(OUT)            :: hname
#if defined(__MINGW)
      ! While there is a gethostname in the Windows (POSIX) API, it requires that winsocks is
      ! initialised prior to using it via WSAStartup(..), respectively cleaned up at the end via WSACleanup().
      hname = "<unknown>"
#else
      INTEGER                                  :: istat, i
      CHARACTER(len=default_path_length)       :: buf
 
      INTERFACE
         FUNCTION gethostname(buf, buflen) BIND(C, name="gethostname") RESULT(errno)
            IMPORT
            CHARACTER(KIND=C_CHAR), DIMENSION(*)     :: buf
            INTEGER(KIND=C_INT), VALUE               :: buflen
            INTEGER(KIND=C_INT)                      :: errno
         END FUNCTION
      END INTERFACE
 
      istat = gethostname(buf, len(buf))
      IF (istat /= 0) THEN
         WRITE (*, *) "m_hostnm failed"
         CALL m_abort()
      END IF
      i = index(buf, c_null_char) - 1
      hname = buf(1:i)
#endif
   END SUBROUTINE m_hostnm
 
! **************************************************************************************************
!> \brief ...
!> \param curdir ...
! **************************************************************************************************
   SUBROUTINE m_getcwd(curdir)
      CHARACTER(len=*), INTENT(OUT)            :: curdir
      TYPE(c_ptr)                              :: stat
      INTEGER                                  :: i
      CHARACTER(len=default_path_length), TARGET  :: tmp
 
      INTERFACE
         FUNCTION getcwd(buf, buflen) BIND(C, name="getcwd") RESULT(stat)
            IMPORT
            CHARACTER(KIND=C_CHAR), DIMENSION(*)     :: buf
            INTEGER(KIND=C_INT), VALUE               :: buflen
            TYPE(c_ptr)                              :: stat
         END FUNCTION
      END INTERFACE
 
      stat = getcwd(tmp, len(tmp))
      IF (.NOT. c_associated(stat)) THEN
         WRITE (*, *) "m_getcwd failed"
         CALL m_abort()
      END IF
      i = index(tmp, c_null_char) - 1
      curdir = tmp(1:i)
   END SUBROUTINE m_getcwd
 
! **************************************************************************************************
!> \brief ...
!> \param dir ...
!> \param ierror ...
! **************************************************************************************************
   SUBROUTINE m_chdir(dir, ierror)
      CHARACTER(len=*), INTENT(IN)             :: dir
      INTEGER, INTENT(OUT)                     :: ierror
 
      INTERFACE
         FUNCTION chdir(path) BIND(C, name="chdir") RESULT(errno)
            IMPORT
            CHARACTER(KIND=C_CHAR), DIMENSION(*)     :: path
            INTEGER(KIND=C_INT)                      :: errno
         END FUNCTION
      END INTERFACE
 
      ierror = chdir(trim(dir)//c_null_char)
   END SUBROUTINE m_chdir
 
! **************************************************************************************************
!> \brief ...
!> \param pid ...
! **************************************************************************************************
   SUBROUTINE m_getpid(pid)
      INTEGER, INTENT(OUT)                     :: pid
 
      INTERFACE
         FUNCTION getpid() BIND(C, name="getpid") RESULT(pid)
            IMPORT
            INTEGER(KIND=C_INT)              :: pid
         END FUNCTION
      END INTERFACE
 
      pid = getpid()
   END SUBROUTINE m_getpid
 
! **************************************************************************************************
!> \brief ...
!> \param path ...
!> \return ...
! **************************************************************************************************
   FUNCTION m_unlink(path) RESULT(istat)
 
      CHARACTER(LEN=*), INTENT(IN)             :: path
 
      INTEGER                                  :: istat
 
      INTERFACE
         FUNCTION unlink(path) BIND(C, name="unlink") RESULT(errno)
            IMPORT
            CHARACTER(KIND=C_CHAR), DIMENSION(*)     :: path
            INTEGER(KIND=C_INT)                      :: errno
         END FUNCTION
      END INTERFACE
 
      istat = unlink(trim(path)//c_null_char)
   END FUNCTION m_unlink
 
! **************************************************************************************************
!> \brief ...
!> \param source ...
!> \param TARGET ...
! **************************************************************************************************
   SUBROUTINE m_mov(source, TARGET)
 
      CHARACTER(LEN=*), INTENT(IN)             :: source, target
 
      INTEGER                                  :: istat
 
      INTERFACE
         FUNCTION rename(src, dest) BIND(C, name="rename") RESULT(errno)
            IMPORT
            CHARACTER(KIND=C_CHAR), DIMENSION(*)     :: src, dest
            INTEGER(KIND=C_INT)                      :: errno
         END FUNCTION
      END INTERFACE
 
      IF (TARGET == source) THEN
         WRITE (*, *) "Warning: m_mov ", trim(TARGET), " equals ", trim(source)
         RETURN
      END IF
 
      ! first remove target (needed on windows / mingw)
      istat = m_unlink(TARGET)
      ! ignore istat of unlink
 
      ! now move
      istat = rename(trim(source)//c_null_char, trim(TARGET)//c_null_char)
      IF (istat .NE. 0) THEN
         WRITE (*, *) "Trying to move "//trim(source)//" to "//trim(TARGET)//"."
         WRITE (*, *) "rename returned status: ", istat
         WRITE (*, *) "Problem moving file"
         CALL m_abort()
      END IF
   END SUBROUTINE m_mov
 
! **************************************************************************************************
!> \brief ...
!> \param user ...
! **************************************************************************************************
   SUBROUTINE m_getlog(user)
 
      CHARACTER(LEN=*), INTENT(OUT) :: user
 
      INTEGER                       :: istat
 
      ! on a posix system LOGNAME should be defined
      CALL get_environment_variable("LOGNAME", value=user, status=istat)
      ! nope, check alternative
      IF (istat /= 0) &
         CALL get_environment_variable("USER", value=user, status=istat)
      ! nope, check alternative
      IF (istat /= 0) &
         CALL get_environment_variable("USERNAME", value=user, status=istat)
      ! fall back
      IF (istat /= 0) &
         user = "<unknown>"
 
   END SUBROUTINE m_getlog
 
! **************************************************************************************************
!> \brief Retrieve environment variable OMP_STACKSIZE
!> \param omp_stacksize Value of OMP_STACKSIZE
! **************************************************************************************************
   SUBROUTINE m_get_omp_stacksize(omp_stacksize)
      CHARACTER(LEN=*), INTENT(OUT)                      :: omp_stacksize
 
      INTEGER                                            :: istat
 
      omp_stacksize = ""
      CALL get_environment_variable("OMP_STACKSIZE", value=omp_stacksize, status=istat)
      ! Fall back, if OMP_STACKSIZE is not set
      IF (istat /= 0) omp_stacksize = "default"
 
   END SUBROUTINE m_get_omp_stacksize
 
END MODULE machine