cp_error_handling.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 Module that contains the routines for error handling
!> \author Ole Schuett
! **************************************************************************************************
MODULE cp_error_handling
   USE base_hooks,                      ONLY: cp_abort_hook,&
                                              cp_hint_hook,&
                                              cp_warn_hook
   USE cp_log_handling,                 ONLY: cp_logger_get_default_io_unit
   USE kinds,                           ONLY: dp
   USE machine,                         ONLY: default_output_unit,&
                                              m_flush,&
                                              m_walltime
   USE message_passing,                 ONLY: mp_abort
   USE print_messages,                  ONLY: print_message
   USE timings,                         ONLY: print_stack
 
!$ USE OMP_LIB, ONLY: omp_get_thread_num
 
   IMPLICIT NONE
   PRIVATE
 
   CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'cp_error_handling'
 
   !API public routines
   PUBLIC :: cp_error_handling_setup
 
   !API (via pointer assignment to hook, PR67982, not meant to be called directly)
   PUBLIC :: cp_abort_handler, cp_warn_handler, cp_hint_handler
 
   INTEGER, PUBLIC, SAVE :: warning_counter = 0
 
CONTAINS
 
! **************************************************************************************************
!> \brief Registers handlers with base_hooks.F
!> \author Ole Schuett
! **************************************************************************************************
   SUBROUTINE cp_error_handling_setup()
      cp_abort_hook => cp_abort_handler
      cp_warn_hook => cp_warn_handler
      cp_hint_hook => cp_hint_handler
   END SUBROUTINE cp_error_handling_setup
 
! **************************************************************************************************
!> \brief Abort program with error message
!> \param location ...
!> \param message ...
!> \author Ole Schuett
! **************************************************************************************************
   SUBROUTINE cp_abort_handler(location, message)
      CHARACTER(len=*), INTENT(in)                       :: location, message
 
      INTEGER                                            :: unit_nr
 
      CALL delay_non_master() ! cleaner output if all ranks abort simultaneously
 
      unit_nr = cp_logger_get_default_io_unit()
      IF (unit_nr <= 0) &
         unit_nr = default_output_unit ! fall back to stdout
 
      CALL print_abort_message(message, location, unit_nr)
      CALL print_stack(unit_nr)
      FLUSH (unit_nr)  ! ignore &GLOBAL / FLUSH_SHOULD_FLUSH
 
      CALL mp_abort()
   END SUBROUTINE cp_abort_handler
 
! **************************************************************************************************
!> \brief Signal a warning
!> \param location ...
!> \param message ...
!> \author Ole Schuett
! **************************************************************************************************
   SUBROUTINE cp_warn_handler(location, message)
      CHARACTER(len=*), INTENT(in)                       :: location, message
 
      INTEGER                                            :: unit_nr
 
!$OMP MASTER
      warning_counter = warning_counter + 1
!$OMP END MASTER
 
      unit_nr = cp_logger_get_default_io_unit()
      IF (unit_nr > 0) THEN
         CALL print_message("WARNING in "//trim(location)//' :: '//trim(adjustl(message)), unit_nr, 1, 1, 1)
         CALL m_flush(unit_nr)
      END IF
   END SUBROUTINE cp_warn_handler
 
! **************************************************************************************************
!> \brief Signal a hint
!> \param location ...
!> \param message ...
!> \author Ole Schuett
! **************************************************************************************************
   SUBROUTINE cp_hint_handler(location, message)
      CHARACTER(len=*), INTENT(in)                       :: location, message
 
      INTEGER                                            :: unit_nr
 
      unit_nr = cp_logger_get_default_io_unit()
      IF (unit_nr > 0) THEN
         CALL print_message("HINT in "//trim(location)//' :: '//trim(adjustl(message)), unit_nr, 1, 1, 1)
         CALL m_flush(unit_nr)
      END IF
   END SUBROUTINE cp_hint_handler
 
! **************************************************************************************************
!> \brief Delay non-master ranks/threads, used by cp_abort_handler()
!> \author Ole Schuett
! **************************************************************************************************
   SUBROUTINE delay_non_master()
      INTEGER                                            :: unit_nr
      REAL(kind=dp)                                      :: t1, wait_time
 
      wait_time = 0.0_dp
 
      ! we (ab)use the logger to determine the first MPI rank
      unit_nr = cp_logger_get_default_io_unit()
      IF (unit_nr <= 0) &
         wait_time = wait_time + 1.0_dp ! rank-0 gets a head start of one second.
 
!$    IF (omp_get_thread_num() /= 0) &
!$       wait_time = wait_time + 1.0_dp ! master threads gets another second
 
      ! sleep
      IF (wait_time > 0.0_dp) THEN
         t1 = m_walltime()
         DO
            IF (m_walltime() - t1 > wait_time .OR. t1 < 0) EXIT
         END DO
      END IF
 
   END SUBROUTINE delay_non_master
 
! **************************************************************************************************
!> \brief Prints a nicely formatted abort message box
!> \param message ...
!> \param location ...
!> \param output_unit ...
!> \author Ole Schuett
! **************************************************************************************************
   SUBROUTINE print_abort_message(message, location, output_unit)
      CHARACTER(LEN=*), INTENT(IN)                       :: message, location
      INTEGER, INTENT(IN)                                :: output_unit
 
      INTEGER, PARAMETER :: img_height = 8, img_width = 9, screen_width = 80, &
         txt_width = screen_width - img_width - 5
      CHARACTER(LEN=img_width), DIMENSION(img_height), PARAMETER :: img = ["   ___   ", "  /   \  "&
         , " [ABORT] ", "  \___/  ", "    |    ", "  O/|    ", " /| |    ", " / \     "]
 
      CHARACTER(LEN=screen_width)                        :: msg_line
      INTEGER                                            :: a, b, c, fill, i, img_start, indent, &
                                                            msg_height, msg_start
 
! count message lines
 
      a = 1; b = -1; msg_height = 0
      DO WHILE (b < len_trim(message))
         b = next_linebreak(message, a, txt_width)
         a = b + 1
         msg_height = msg_height + 1
      END DO
 
      ! calculate message and image starting lines
      IF (img_height > msg_height) THEN
         msg_start = (img_height - msg_height)/2 + 1
         img_start = 1
      ELSE
         msg_start = 1
         img_start = msg_height - img_height + 2
      END IF
 
      ! print empty line
      WRITE (unit=output_unit, fmt="(A)") ""
 
      ! print opening line
      WRITE (unit=output_unit, fmt="(T2,A)") repeat("*", screen_width - 1)
 
      ! print body
      a = 1; b = -1; c = 1
      DO i = 1, max(img_height - 1, msg_height)
         WRITE (unit=output_unit, fmt="(A)", advance='no') " *"
         IF (i < img_start) THEN
            WRITE (unit=output_unit, fmt="(A)", advance='no') repeat(" ", img_width)
         ELSE
            WRITE (unit=output_unit, fmt="(A)", advance='no') img(c)
            c = c + 1
         END IF
         IF (i < msg_start) THEN
            WRITE (unit=output_unit, fmt="(A)", advance='no') repeat(" ", txt_width + 2)
         ELSE
            b = next_linebreak(message, a, txt_width)
            msg_line = message(a:b)
            a = b + 1
            fill = (txt_width - len_trim(msg_line))/2 + 1
            indent = txt_width - len_trim(msg_line) - fill + 2
            WRITE (unit=output_unit, fmt="(A)", advance='no') repeat(" ", indent)
            WRITE (unit=output_unit, fmt="(A)", advance='no') trim(msg_line)
            WRITE (unit=output_unit, fmt="(A)", advance='no') repeat(" ", fill)
         END IF
         WRITE (unit=output_unit, fmt="(A)", advance='yes') "*"
      END DO
 
      ! print location line
      WRITE (unit=output_unit, fmt="(A)", advance='no') " *"
      WRITE (unit=output_unit, fmt="(A)", advance='no') img(c)
      indent = txt_width - len_trim(location) + 1
      WRITE (unit=output_unit, fmt="(A)", advance='no') repeat(" ", indent)
      WRITE (unit=output_unit, fmt="(A)", advance='no') trim(location)
      WRITE (unit=output_unit, fmt="(A)", advance='yes') " *"
 
      ! print closing line
      WRITE (unit=output_unit, fmt="(T2,A)") repeat("*", screen_width - 1)
 
      ! print empty line
      WRITE (unit=output_unit, fmt="(A)") ""
 
   END SUBROUTINE print_abort_message
 
! **************************************************************************************************
!> \brief Helper routine for print_abort_message()
!> \param message ...
!> \param pos ...
!> \param rowlen ...
!> \return ...
!> \author Ole Schuett
! **************************************************************************************************
   FUNCTION next_linebreak(message, pos, rowlen) RESULT(ibreak)
      CHARACTER(LEN=*), INTENT(IN)                       :: message
      INTEGER, INTENT(IN)                                :: pos, rowlen
      INTEGER                                            :: ibreak
 
      INTEGER                                            :: i, n
 
      n = len_trim(message)
      IF (n - pos <= rowlen) THEN
         ibreak = n ! remaining message shorter than line
      ELSE
         i = index(message(pos + 1:pos + 1 + rowlen), " ", back=.true.)
         IF (i == 0) THEN
            ibreak = pos + rowlen - 1 ! no space found, break mid-word
         ELSE
            ibreak = pos + i ! break at space closest to rowlen
         END IF
      END IF
   END FUNCTION next_linebreak
 
END MODULE cp_error_handling