global.F90

Go to the documentation of this file.

!! Copyright (C) 2002-2006 M. Marques, A. Castro, A. Rubio, G. Bertsch
!!
!! This program is free software; you can redistribute it and/or modify
!! it under the terms of the GNU General Public License as published by
!! the Free Software Foundation; either version 2, or (at your option)
!! any later version.
!!
!! This program is distributed in the hope that it will be useful,
!! but WITHOUT ANY WARRANTY; without even the implied warranty of
!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!! GNU General Public License for more details.
!!
!! You should have received a copy of the GNU General Public License
!! along with this program; if not, write to the Free Software
!! Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
!! 02110-1301, USA.
!!
 
#include "global.h"
 
module global_oct_m
  use, intrinsic :: iso_c_binding, only: c_int
  use, intrinsic :: iso_fortran_env
  use hardware_oct_m
  use loct_oct_m
  use mpi_oct_m
  use string_oct_m
  use varinfo_oct_m
#ifdef HAVE_OPENMP
  use omp_lib
#endif
 
  implicit none
 
  private
 
  public ::               &
    conf_t,               &
    global_init,          &
    global_end,           &
    init_octopus_globals, &
    optional_default,     &
    assert_die,           &
    not_in_openmp,        &
    operator(+),          &
    bitand,               &
    int32, int64,         &
    real32, real64,       &
    i4_to_i8,             &
    i8_to_i4
  ! Make these kind variables from kind_oct_m public here so that they are
  ! available basically everywhere in the code. They still need to be in a
  ! separate module because they are also needed in some low-level modules.
 
  interface
    function openblas_get_version(major, minor, patch) bind(C) result(ierr)
      use, intrinsic :: iso_c_binding, only: c_int
      integer(c_int), intent(inout) :: major, minor, patch
      integer(c_int) :: ierr
    end function
  end interface
 
  integer, public, parameter :: MAX_PATH_LEN=512
  integer, public, parameter :: MAX_OUTPUT_TYPES=46
 
  type conf_t
    logical            :: devel_version
    logical            :: report_memory
    character(len=256) :: share = share_dir          
    character(len=256) :: build_dir = build_dir      
    character(len=256) :: git_commit  = git_commit   
    character(len=50)  :: config_time = build_time   
    character(len=20)  :: version = package_version  
    character(len=256) :: cc = cc                    
    character(len=256) :: cxx = cxx                  
    character(len=256) :: fc = fc                    
    ! Split flag definitions in case they don`t fit in one line, following preprocessing
    character(len=256) :: cflags = &
      cflags //&
      cflags_extra
    character(len=256) :: cxxflags = &
      cxxflags //&
      cxxflags_extra
    character(len=512) :: fcflags = &
      fcflags //&
      fcflags_extra
    integer            :: target_states_block_size = -1
  contains
    procedure :: init => conf_init
  end type conf_t
 
  type(conf_t),      public :: conf
 
  real(real64), public, parameter :: R_SMALL = 1e-8_real64
 
  real(real64), public, parameter :: R_MIN_ATOM_DIST = 1e-3_real64
 
  real(real64), public, parameter :: M_Pi        = 3.1415926535897932384626433832795029_real64
  real(real64), public, parameter :: M_E         = 2.7182818284590452353602874713526625_real64
  real(real64), public, parameter :: M_ZERO      = 0.0_real64
  real(real64), public, parameter :: M_ONE       = 1.0_real64
  real(real64), public, parameter :: M_TWO       = 2.0_real64
  real(real64), public, parameter :: M_THREE     = 3.0_real64
  real(real64), public, parameter :: M_FOUR      = 4.0_real64
  real(real64), public, parameter :: M_FIVE      = 5.0_real64
  real(real64), public, parameter :: M_HALF      = 0.5_real64
  real(real64), public, parameter :: M_THIRD     = m_one/m_three
  real(real64), public, parameter :: M_TWOTHIRD  = m_two/m_three
  real(real64), public, parameter :: M_FOURTH    = m_one/m_four
  complex(real64), public, parameter :: M_z0        = (0.0_real64, 0.0_real64)
  complex(real64), public, parameter :: M_z1        = (1.0_real64, 0.0_real64)
  complex(real64), public, parameter :: M_z2        = (2.0_real64, 0.0_real64)
  complex(real64), public, parameter :: M_z2I       = (0.0_real64, 2.0_real64)
  complex(real64), public, parameter :: M_zI        = (0.0_real64, 1.0_real64)
 
  real(real64), public, parameter :: M_EPSILON   =  epsilon(m_one)
  real(real64), public, parameter :: M_TINY      =  tiny(m_one)
  real(real64), public, parameter :: M_HUGE      =  huge(m_one)
  real(real64), public, parameter :: M_MIN_EXP_ARG = -650_real64
  real(real64), public, parameter :: M_MAX_EXP_ARG = 700_real64
  real(real64), public, protected :: M_PINF
  real(real64), public, protected :: M_NINF
  real(real64), public, protected :: M_SNAN
  real(real64), public, protected :: M_QNAN
 
  real(real64), public, parameter :: M_MIN_OCC = 1.0e-10_real64
  real(real64), public, parameter :: M_MIN_DENSITY = 1.0e-20_real64
  real(real64), public, parameter :: M_DEGENERARY_THRESHOLD = 1.0e-6_real64
 
  real(real64), public, parameter :: LMM_R_SINGLE_ATOM = 100.0_real64
 
  real(real64), public, parameter :: P_a_B =  0.52917720859_real64
  real(real64), public, parameter :: P_Ang =  m_one / p_a_b
  real(real64), public, parameter :: P_Ry  =  13.60569193_real64
  real(real64), public, parameter :: P_eV  =  m_one / p_ry
  real(real64), public, parameter :: P_Kb  =  8.617343e-5_real64/(m_two*p_ry)  
  real(real64), public, parameter :: P_c   =  137.035999679_real64
  
  real(real64), public, parameter :: P_g   =  2.00231930436118_real64
  real(real64), public, parameter :: P_PROTON_CHARGE = -1.0_real64
  real(real64), public, parameter :: P_ep  =  m_one/(m_four*m_pi)
  real(real64), public, parameter :: p_mu  =  m_four*m_pi/(p_c**2)
 
  integer, public, parameter ::        &
    independent_particles = 2,         &
    hartree               = 1,         &
    hartree_fock          = 3,         &
    kohn_sham_dft         = 4,         &
    generalized_kohn_sham_dft = 5,     &
    rdmft                 = 7
 
  integer, public :: stderr, stdin, stdout
 
  integer, public :: s_epoch_sec, s_epoch_usec
 
  character(len=80), public          :: sub_stack(50)
  real(real64), public               :: time_stack(50)
  integer, public                    :: no_sub_stack = 0
 
  logical, public :: in_profiling_mode = .false.
 
  integer,    public :: global_alloc_err
  integer(int64), public :: global_sizeof
  character(len=100), public :: global_alloc_errmsg
  !$omp threadprivate(global_alloc_err, global_sizeof, global_alloc_errmsg)
 
  ! The code directories should be defined here, and not hard coded in the Fortran files.
  character(len=*), public, parameter :: gs_dir = "gs/"
  character(len=*), public, parameter :: td_dir = "td/"
  character(len=*), public, parameter :: static_dir = "static/"
  character(len=*), public, parameter :: em_resp_dir = "em_resp/"
  character(len=*), public, parameter :: em_resp_fd_dir = "em_resp_fd/"
  character(len=*), public, parameter :: kdotp_dir = "kdotp/"
  character(len=*), public, parameter :: vib_modes_dir = "vib_modes/"
  character(len=*), public, parameter :: vdw_dir = "vdw/"
  character(len=*), public, parameter :: casida_dir = "casida/"
  character(len=*), public, parameter :: oct_dir = "opt-control/"
  character(len=*), public, parameter :: pcm_dir = "pcm/"
  character(len=*), public, parameter :: partition_dir = "partition/"
  character(len=*), public, parameter :: iteration_dir = "iteration/"
  character(len=*), public, parameter :: dm_dir = "dm/"
 
  type(mpi_comm), public, parameter :: serial_dummy_comm = mpi_comm_undefined
 
  ! End of declaration of public objects.
  ! ---------------------------------------------------------
 
  interface optional_default
    module procedure doptional_default, zoptional_default, ioptional_default, loptional_default
    module procedure looptional_default, soptional_default
  end interface optional_default
 
 
  interface
    subroutine assert_die(s, f, l)
      implicit none
      character(len=*), intent(in) :: s, f
      integer, intent(in) :: l
    end subroutine assert_die
  end interface
 
  interface operator (+)
    module procedure cat
  end interface operator (+)
 
  interface bitand
    module procedure bitand48
    module procedure bitand84
    module procedure bitand88
    module procedure bitand44
  end interface bitand
 
  interface i4_to_i8
    module procedure i4_to_i8_0, i4_to_i8_1
  end interface i4_to_i8
 
  interface i8_to_i4
    module procedure i8_to_i4_0, i8_to_i4_1
  end interface i8_to_i4
 
contains
 
  subroutine conf_init(this)
    class(conf_t), intent(inout) :: this
 
    character(len=MAX_PATH_LEN) :: share
    character(len=MAX_PATH_LEN) :: path_exe, dir_exe
 
    ! First, get the environment variable OCTOPUS_SHARE that overrides the default
    call loct_getenv("OCTOPUS_SHARE", share)
    if (trim(share) /= "") then
      this%share = trim(share)
      return
    end if
    ! Second, try a share directory next to the binary; this makes it work in the build tree
    call loct_executable_path(path_exe)
    if (trim(path_exe) /= "") then
      ! we got a useable path, search for the share folder
      call loct_dirname(path_exe, dir_exe)
      share = trim(dir_exe) // "/share"
      if (loct_dir_exists(share)) then
        this%share = trim(share)
        return
      end if
    end if
    ! Third, take the value from the configuration step, check if it exists
    if (.not.loct_dir_exists(conf%share)) then
      write(*, "(A)") "Error: could not find share directory."
      write(*, "(A, A)") "Configured location: ", trim(conf%share)
      stop
    end if
 
  end subroutine conf_init
 
 
  subroutine global_init(communicator)
    type(mpi_comm), intent(in), optional :: communicator
 
    type(mpi_comm) :: comm
 
    if (present(communicator)) then
      comm = communicator
      call check_threading_support(comm)
    else
      call mpi_init_comm(comm)
    endif
 
    call init_octopus_globals(comm)
 
    call global_check_openblas_version()
 
    ! Order of call is important. mpi_world is used implicitly by blacs_init
    call blacs_init()
 
  end subroutine global_init
 
 
  subroutine global_check_openblas_version()
 
    integer(c_int) :: ierr, major, minor, patch
 
    major = 0
    minor = 0
    patch = 0
    ierr = openblas_get_version(major, minor, patch)
 
    if (ierr == 0) then
      ! Implies that the formatting of the config message has changed
      error stop  "openblas_get_config failed to return a version"
    endif
    if (ierr == 1 .and. major == 0 .and. minor == 3 .and. patch == 32) then
      error stop  "Octopus is linked to OpenBLAS 0.3.32, which is buggy"
    end if
 
  end subroutine global_check_openblas_version
 
 
  subroutine init_octopus_globals(comm)
    type(mpi_comm), intent(in) :: comm
 
    character(len=256) :: path
 
    call mpi_grp_init(mpi_world, comm)
 
    call mpi_world%barrier()
    ! Get epoch time at node startup, just after the barrier to synchronize nodes first.
    call loct_gettimeofday(s_epoch_sec, s_epoch_usec)
 
    ! These defaults are initialised here because the Intel 2022a compiler complains:
    ! "This array or function or substring is invalid in constant expressions"
    ! This is not a problem with Intel 2023a, and so can be returned to hardware.F90
    ! once Intel 2022a support is dropped
    default_l1 = cache_t(  32*1024, 64)  
    default_l2 = cache_t(4096*1024, 64)  
 
    ! TODO(Alex) Issue 1013. Change hardware class to a free function, and make cache_t instance global.
    call cpu_hardware%init(default_l1, default_l2)
 
    call conf%init()
 
    ! initialize info for the input variables
    path = trim(conf%share)//'/varinfo'
    call varinfo_init(string_f_to_c(path))
 
    block
      use, intrinsic :: ieee_arithmetic, only: &
        ieee_negative_inf, &
        ieee_positive_inf, &
        ieee_quiet_nan, &
        ieee_signaling_nan, &
        ieee_support_inf, &
        ieee_support_nan, &
        ieee_value
      if (ieee_support_inf(m_pinf)) then
        m_pinf = ieee_value(m_pinf, ieee_positive_inf)
      else
        m_pinf = huge(m_pinf)
      end if
      if (ieee_support_inf(m_ninf)) then
        m_ninf = ieee_value(m_ninf, ieee_negative_inf)
      else
        m_ninf = -huge(m_ninf)
      end if
      if (ieee_support_nan(m_qnan)) then
        m_qnan = ieee_value(m_qnan, ieee_quiet_nan)
      else
        m_qnan = real(0.0, kind(m_qnan))
      end if
      if (ieee_support_nan(m_snan)) then
        m_snan = ieee_value(m_snan, ieee_signaling_nan)
      else
        m_snan = real(0.0, kind(m_snan))
      end if
    end block
 
  end subroutine init_octopus_globals
 
 
  subroutine global_end()
 
    call varinfo_end()
    call mpi_mod_end()
 
  end subroutine global_end
 
 
  real(real64) pure function doptional_default(opt, def) result(val)
    real(real64), optional, intent(in) :: opt
    real(real64),    intent(in) :: def
 
    val = def
    if (present(opt)) val = opt
  end function doptional_default
 
  !----------------------------------------------------------
 
  complex(real64) pure function zoptional_default(opt, def) result(val)
    complex(real64), optional, intent(in) :: opt
    complex(real64), intent(in) :: def
 
    val = def
    if (present(opt)) val = opt
  end function zoptional_default
 
  !----------------------------------------------------------
 
  integer pure function ioptional_default(opt, def) result(val)
    integer, optional, intent(in) :: opt
    integer,           intent(in) :: def
 
    val = def
    if (present(opt)) val = opt
  end function ioptional_default
 
  !----------------------------------------------------------
 
  integer(int64) pure function loptional_default(opt, def) result(val)
    integer(int64), optional, intent(in) :: opt
    integer(int64),           intent(in) :: def
 
    val = def
    if (present(opt)) val = opt
  end function loptional_default
 
  !----------------------------------------------------------
 
  logical pure function looptional_default(opt, def) result(val)
    logical, optional, intent(in) :: opt
    logical,           intent(in) :: def
 
    val = def
    if (present(opt)) val = opt
  end function looptional_default
 
  !----------------------------------------------------------
 
  character(len=80) pure function soptional_default(opt, def) result(val)
    character(len=*), optional, intent(in) :: opt
    character(len=*),           intent(in) :: def
 
    val = def
    if (present(opt)) val = opt
  end function soptional_default
 
  !-----------------------------------------------------------
 
  logical &
#ifndef have_openmp
    pure &
#endif
    function not_in_openmp()
 
#ifdef HAVE_OPENMP
    not_in_openmp = .not. omp_in_parallel()
#else
    not_in_openmp = .true.
#endif
 
  end function not_in_openmp
 
  !-----------------------------------------------------------
 
  function cat(str1, str2)
    character(len=*), intent(in) :: str1
    character(len=*), intent(in) :: str2
 
    character(len=len(str1) + len(str2)) :: cat
    cat = str1//str2
 
  end function cat
 
  ! -----------------------------------------------------------
 
  integer(int64) pure function bitand48(val1, val2)
    integer(int32), intent(in) :: val1
    integer(int64), intent(in) :: val2
 
    bitand48 = iand(int(val1, int64), val2)
 
  end function bitand48
 
  ! -----------------------------------------------------------
 
  integer(int64) pure function bitand84(val1, val2)
    integer(int64), intent(in) :: val1
    integer(int32), intent(in) :: val2
 
    bitand84 = iand(val1, int(val2, int64))
 
  end function bitand84
 
  ! -----------------------------------------------------------
 
  integer(int64) pure function bitand88(val1, val2)
    integer(int64), intent(in) :: val1
    integer(int64), intent(in) :: val2
 
    bitand88 = iand(val1, val2)
 
  end function bitand88
 
  ! -----------------------------------------------------------
 
  integer(int32) pure function bitand44(val1, val2)
    integer(int32), intent(in) :: val1
    integer(int32), intent(in) :: val2
 
    bitand44 = iand(val1, val2)
 
  end function bitand44
 
  ! -----------------------------------------------------------
 
  integer(int64) pure function i4_to_i8_0(ii)
    integer(int32), intent(in) :: ii
 
    i4_to_i8_0 = int(ii, int64)
  end function i4_to_i8_0
 
  ! -----------------------------------------------------------
 
  integer(int32) pure function i8_to_i4_0(ii)
    integer(int64), intent(in) :: ii
 
    i8_to_i4_0 = int(ii, int32)
  end function i8_to_i4_0
 
  ! -----------------------------------------------------------
 
  pure function i4_to_i8_1(ii)
    integer(int32), intent(in) :: ii(:)
    integer(int64) :: i4_to_i8_1(lbound(ii, 1, kind=int64):ubound(ii, 1, kind=int64))
 
    i4_to_i8_1 = int(ii, int64)
  end function i4_to_i8_1
 
  ! -----------------------------------------------------------
 
  pure function i8_to_i4_1(ii)
    integer(int64), intent(in) :: ii(:)
    integer(int32) :: i8_to_i4_1(lbound(ii, 1, kind=int64):ubound(ii, 1, kind=int64))
 
    i8_to_i4_1 = int(ii, int32)
  end function i8_to_i4_1
 
end module global_oct_m
 
!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End: