dbcsr_error_handling.F Source File


Source Code

# 1 "/__w/dbcsr/dbcsr/src/core/dbcsr_error_handling.F" 1
!--------------------------------------------------------------------------------------------------!
! Copyright (C) by the DBCSR developers group - All rights reserved                                !
! This file is part of the DBCSR library.                                                          !
!                                                                                                  !
! For information on the license, see the LICENSE file.                                            !
! For further information please visit https://dbcsr.cp2k.org                                      !
! SPDX-License-Identifier: GPL-2.0+                                                                !
!--------------------------------------------------------------------------------------------------!

MODULE dbcsr_error_handling
   !! Module that contains the routines for error handling
   USE dbcsr_base_hooks, ONLY: dbcsr_abort_hook, &
                               dbcsr_warn_hook
   USE dbcsr_kinds, ONLY: dp
   USE dbcsr_log_handling, ONLY: dbcsr_logger_get_default_io_unit
   USE dbcsr_machine, ONLY: default_output_unit, &
                            m_flush, &
                            m_walltime
   USE dbcsr_mpiwrap, ONLY: mp_abort
   USE dbcsr_print_messages, ONLY: print_message
   USE dbcsr_timings, ONLY: print_stack

!$ USE OMP_LIB, ONLY: omp_get_thread_num

   IMPLICIT NONE
   PRIVATE

   CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'dbcsr_error_handling'

   !API public routines
   PUBLIC :: dbcsr_error_handling_setup

   !API (via pointer assignment to hook, PR67982, not meant to be called directly)
   PUBLIC :: dbcsr_abort_handler, dbcsr_warn_handler

   INTEGER, PUBLIC, SAVE :: warning_counter = 0

CONTAINS

   SUBROUTINE dbcsr_error_handling_setup()
      !! Registers handlers with base_hooks.F
      dbcsr_abort_hook => dbcsr_abort_handler
      dbcsr_warn_hook => dbcsr_warn_handler
   END SUBROUTINE dbcsr_error_handling_setup

   SUBROUTINE dbcsr_abort_handler(location, message)
      !! Abort program with error message
      CHARACTER(len=*), INTENT(in)                       :: location, message

      INTEGER                                            :: unit_nr

      CALL delay_non_master() ! cleaner output if all ranks abort simultaneously

      unit_nr = dbcsr_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)
      CALL m_flush(unit_nr)

      CALL mp_abort()
   END SUBROUTINE dbcsr_abort_handler

   SUBROUTINE dbcsr_warn_handler(location, message)
      !! Signal a warning
      CHARACTER(len=*), INTENT(in)                       :: location, message

      INTEGER                                            :: unit_nr

!$OMP MASTER
      warning_counter = warning_counter + 1
!$OMP END MASTER

      unit_nr = dbcsr_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 dbcsr_warn_handler

   SUBROUTINE delay_non_master()
      !! Delay non-master ranks/threads, used by dbcsr_abort_handler()
      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 = dbcsr_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

   SUBROUTINE print_abort_message(message, location, output_unit)
      !! Prints a nicely formatted abort message box
      CHARACTER(LEN=*), INTENT(IN)                       :: message, location
      INTEGER, INTENT(IN)                                :: output_unit

      CHARACTER(LEN=*), PARAMETER :: img = "   ___   "//"  /   \  "//" [ABORT] "//"  \___/  "// &
                                     "    |    "//"  O/|    "//" /| |    "//" / \     "
      INTEGER, PARAMETER :: img_height = 8, img_width = 9, screen_width = 80, &
                            txt_width = screen_width - img_width - 5

      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 + img_width - 1)
            c = c + img_width
         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:c + img_width - 1)
      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

   FUNCTION next_linebreak(message, pos, rowlen) RESULT(ibreak)
      !! Helper routine for print_abort_message()
      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 dbcsr_error_handling