# 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