LCOV - code coverage report
Current view: top level - src/common - cp_error_handling.F (source / functions) Hit Total Coverage
Test: CP2K Regtests (git:0de0cc2) Lines: 19 88 21.6 %
Date: 2024-03-28 07:31:50 Functions: 3 7 42.9 %

          Line data    Source code
       1             : !--------------------------------------------------------------------------------------------------!
       2             : !   CP2K: A general program to perform molecular dynamics simulations                              !
       3             : !   Copyright 2000-2024 CP2K developers group <https://cp2k.org>                                   !
       4             : !                                                                                                  !
       5             : !   SPDX-License-Identifier: GPL-2.0-or-later                                                      !
       6             : !--------------------------------------------------------------------------------------------------!
       7             : 
       8             : ! **************************************************************************************************
       9             : !> \brief Module that contains the routines for error handling
      10             : !> \author Ole Schuett
      11             : ! **************************************************************************************************
      12             : MODULE cp_error_handling
      13             :    USE base_hooks,                      ONLY: cp_abort_hook,&
      14             :                                               cp_hint_hook,&
      15             :                                               cp_warn_hook
      16             :    USE cp_log_handling,                 ONLY: cp_logger_get_default_io_unit
      17             :    USE kinds,                           ONLY: dp
      18             :    USE machine,                         ONLY: default_output_unit,&
      19             :                                               m_flush,&
      20             :                                               m_walltime
      21             :    USE message_passing,                 ONLY: mp_abort
      22             :    USE print_messages,                  ONLY: print_message
      23             :    USE timings,                         ONLY: print_stack
      24             : 
      25             : !$ USE OMP_LIB, ONLY: omp_get_thread_num
      26             : 
      27             :    IMPLICIT NONE
      28             :    PRIVATE
      29             : 
      30             :    CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'cp_error_handling'
      31             : 
      32             :    !API public routines
      33             :    PUBLIC :: cp_error_handling_setup
      34             : 
      35             :    !API (via pointer assignment to hook, PR67982, not meant to be called directly)
      36             :    PUBLIC :: cp_abort_handler, cp_warn_handler, cp_hint_handler
      37             : 
      38             :    INTEGER, PUBLIC, SAVE :: warning_counter = 0
      39             : 
      40             : CONTAINS
      41             : 
      42             : ! **************************************************************************************************
      43             : !> \brief Registers handlers with base_hooks.F
      44             : !> \author Ole Schuett
      45             : ! **************************************************************************************************
      46        8388 :    SUBROUTINE cp_error_handling_setup()
      47        8388 :       cp_abort_hook => cp_abort_handler
      48        8388 :       cp_warn_hook => cp_warn_handler
      49        8388 :       cp_hint_hook => cp_hint_handler
      50        8388 :    END SUBROUTINE cp_error_handling_setup
      51             : 
      52             : ! **************************************************************************************************
      53             : !> \brief Abort program with error message
      54             : !> \param location ...
      55             : !> \param message ...
      56             : !> \author Ole Schuett
      57             : ! **************************************************************************************************
      58           0 :    SUBROUTINE cp_abort_handler(location, message)
      59             :       CHARACTER(len=*), INTENT(in)                       :: location, message
      60             : 
      61             :       INTEGER                                            :: unit_nr
      62             : 
      63           0 :       CALL delay_non_master() ! cleaner output if all ranks abort simultaneously
      64             : 
      65           0 :       unit_nr = cp_logger_get_default_io_unit()
      66           0 :       IF (unit_nr <= 0) &
      67           0 :          unit_nr = default_output_unit ! fall back to stdout
      68             : 
      69           0 :       CALL print_abort_message(message, location, unit_nr)
      70           0 :       CALL print_stack(unit_nr)
      71           0 :       FLUSH (unit_nr)  ! ignore &GLOBAL / FLUSH_SHOULD_FLUSH
      72             : 
      73           0 :       CALL mp_abort()
      74           0 :    END SUBROUTINE cp_abort_handler
      75             : 
      76             : ! **************************************************************************************************
      77             : !> \brief Signal a warning
      78             : !> \param location ...
      79             : !> \param message ...
      80             : !> \author Ole Schuett
      81             : ! **************************************************************************************************
      82       24217 :    SUBROUTINE cp_warn_handler(location, message)
      83             :       CHARACTER(len=*), INTENT(in)                       :: location, message
      84             : 
      85             :       INTEGER                                            :: unit_nr
      86             : 
      87       24217 : !$OMP MASTER
      88       24217 :       warning_counter = warning_counter + 1
      89             : !$OMP END MASTER
      90             : 
      91       24217 :       unit_nr = cp_logger_get_default_io_unit()
      92       24217 :       IF (unit_nr > 0) THEN
      93       17090 :          CALL print_message("WARNING in "//TRIM(location)//' :: '//TRIM(ADJUSTL(message)), unit_nr, 1, 1, 1)
      94       17090 :          CALL m_flush(unit_nr)
      95             :       END IF
      96       24217 :    END SUBROUTINE cp_warn_handler
      97             : 
      98             : ! **************************************************************************************************
      99             : !> \brief Signal a hint
     100             : !> \param location ...
     101             : !> \param message ...
     102             : !> \author Ole Schuett
     103             : ! **************************************************************************************************
     104          56 :    SUBROUTINE cp_hint_handler(location, message)
     105             :       CHARACTER(len=*), INTENT(in)                       :: location, message
     106             : 
     107             :       INTEGER                                            :: unit_nr
     108             : 
     109         112 :       unit_nr = cp_logger_get_default_io_unit()
     110          56 :       IF (unit_nr > 0) THEN
     111          28 :          CALL print_message("HINT in "//TRIM(location)//' :: '//TRIM(ADJUSTL(message)), unit_nr, 1, 1, 1)
     112          28 :          CALL m_flush(unit_nr)
     113             :       END IF
     114          56 :    END SUBROUTINE cp_hint_handler
     115             : 
     116             : ! **************************************************************************************************
     117             : !> \brief Delay non-master ranks/threads, used by cp_abort_handler()
     118             : !> \author Ole Schuett
     119             : ! **************************************************************************************************
     120           0 :    SUBROUTINE delay_non_master()
     121             :       INTEGER                                            :: unit_nr
     122             :       REAL(KIND=dp)                                      :: t1, wait_time
     123             : 
     124           0 :       wait_time = 0.0_dp
     125             : 
     126             :       ! we (ab)use the logger to determine the first MPI rank
     127           0 :       unit_nr = cp_logger_get_default_io_unit()
     128           0 :       IF (unit_nr <= 0) &
     129           0 :          wait_time = wait_time + 1.0_dp ! rank-0 gets a head start of one second.
     130             : 
     131           0 : !$    IF (omp_get_thread_num() /= 0) &
     132           0 : !$       wait_time = wait_time + 1.0_dp ! master threads gets another second
     133             : 
     134             :       ! sleep
     135           0 :       IF (wait_time > 0.0_dp) THEN
     136           0 :          t1 = m_walltime()
     137             :          DO
     138           0 :             IF (m_walltime() - t1 > wait_time .OR. t1 < 0) EXIT
     139             :          END DO
     140             :       END IF
     141             : 
     142           0 :    END SUBROUTINE delay_non_master
     143             : 
     144             : ! **************************************************************************************************
     145             : !> \brief Prints a nicely formatted abort message box
     146             : !> \param message ...
     147             : !> \param location ...
     148             : !> \param output_unit ...
     149             : !> \author Ole Schuett
     150             : ! **************************************************************************************************
     151           0 :    SUBROUTINE print_abort_message(message, location, output_unit)
     152             :       CHARACTER(LEN=*), INTENT(IN)                       :: message, location
     153             :       INTEGER, INTENT(IN)                                :: output_unit
     154             : 
     155             :       INTEGER, PARAMETER :: img_height = 8, img_width = 9, screen_width = 80, &
     156             :          txt_width = screen_width - img_width - 5
     157             :       CHARACTER(LEN=img_width), DIMENSION(img_height), PARAMETER :: img = ["   ___   ", "  /   \  "&
     158             :          , " [ABORT] ", "  \___/  ", "    |    ", "  O/|    ", " /| |    ", " / \     "]
     159             : 
     160             :       CHARACTER(LEN=screen_width)                        :: msg_line
     161             :       INTEGER                                            :: a, b, c, fill, i, img_start, indent, &
     162             :                                                             msg_height, msg_start
     163             : 
     164             : ! count message lines
     165             : 
     166           0 :       a = 1; b = -1; msg_height = 0
     167           0 :       DO WHILE (b < LEN_TRIM(message))
     168           0 :          b = next_linebreak(message, a, txt_width)
     169           0 :          a = b + 1
     170           0 :          msg_height = msg_height + 1
     171             :       END DO
     172             : 
     173             :       ! calculate message and image starting lines
     174           0 :       IF (img_height > msg_height) THEN
     175           0 :          msg_start = (img_height - msg_height)/2 + 1
     176           0 :          img_start = 1
     177             :       ELSE
     178           0 :          msg_start = 1
     179           0 :          img_start = msg_height - img_height + 2
     180             :       END IF
     181             : 
     182             :       ! print empty line
     183           0 :       WRITE (UNIT=output_unit, FMT="(A)") ""
     184             : 
     185             :       ! print opening line
     186           0 :       WRITE (UNIT=output_unit, FMT="(T2,A)") REPEAT("*", screen_width - 1)
     187             : 
     188             :       ! print body
     189           0 :       a = 1; b = -1; c = 1
     190           0 :       DO i = 1, MAX(img_height - 1, msg_height)
     191           0 :          WRITE (UNIT=output_unit, FMT="(A)", advance='no') " *"
     192           0 :          IF (i < img_start) THEN
     193           0 :             WRITE (UNIT=output_unit, FMT="(A)", advance='no') REPEAT(" ", img_width)
     194             :          ELSE
     195           0 :             WRITE (UNIT=output_unit, FMT="(A)", advance='no') img(c)
     196           0 :             c = c + 1
     197             :          END IF
     198           0 :          IF (i < msg_start) THEN
     199           0 :             WRITE (UNIT=output_unit, FMT="(A)", advance='no') REPEAT(" ", txt_width + 2)
     200             :          ELSE
     201           0 :             b = next_linebreak(message, a, txt_width)
     202           0 :             msg_line = message(a:b)
     203           0 :             a = b + 1
     204           0 :             fill = (txt_width - LEN_TRIM(msg_line))/2 + 1
     205           0 :             indent = txt_width - LEN_TRIM(msg_line) - fill + 2
     206           0 :             WRITE (UNIT=output_unit, FMT="(A)", advance='no') REPEAT(" ", indent)
     207           0 :             WRITE (UNIT=output_unit, FMT="(A)", advance='no') TRIM(msg_line)
     208           0 :             WRITE (UNIT=output_unit, FMT="(A)", advance='no') REPEAT(" ", fill)
     209             :          END IF
     210           0 :          WRITE (UNIT=output_unit, FMT="(A)", advance='yes') "*"
     211             :       END DO
     212             : 
     213             :       ! print location line
     214           0 :       WRITE (UNIT=output_unit, FMT="(A)", advance='no') " *"
     215           0 :       WRITE (UNIT=output_unit, FMT="(A)", advance='no') img(c)
     216           0 :       indent = txt_width - LEN_TRIM(location) + 1
     217           0 :       WRITE (UNIT=output_unit, FMT="(A)", advance='no') REPEAT(" ", indent)
     218           0 :       WRITE (UNIT=output_unit, FMT="(A)", advance='no') TRIM(location)
     219           0 :       WRITE (UNIT=output_unit, FMT="(A)", advance='yes') " *"
     220             : 
     221             :       ! print closing line
     222           0 :       WRITE (UNIT=output_unit, FMT="(T2,A)") REPEAT("*", screen_width - 1)
     223             : 
     224             :       ! print empty line
     225           0 :       WRITE (UNIT=output_unit, FMT="(A)") ""
     226             : 
     227           0 :    END SUBROUTINE print_abort_message
     228             : 
     229             : ! **************************************************************************************************
     230             : !> \brief Helper routine for print_abort_message()
     231             : !> \param message ...
     232             : !> \param pos ...
     233             : !> \param rowlen ...
     234             : !> \return ...
     235             : !> \author Ole Schuett
     236             : ! **************************************************************************************************
     237           0 :    FUNCTION next_linebreak(message, pos, rowlen) RESULT(ibreak)
     238             :       CHARACTER(LEN=*), INTENT(IN)                       :: message
     239             :       INTEGER, INTENT(IN)                                :: pos, rowlen
     240             :       INTEGER                                            :: ibreak
     241             : 
     242             :       INTEGER                                            :: i, n
     243             : 
     244           0 :       n = LEN_TRIM(message)
     245           0 :       IF (n - pos <= rowlen) THEN
     246             :          ibreak = n ! remaining message shorter than line
     247             :       ELSE
     248           0 :          i = INDEX(message(pos + 1:pos + 1 + rowlen), " ", BACK=.TRUE.)
     249           0 :          IF (i == 0) THEN
     250           0 :             ibreak = pos + rowlen - 1 ! no space found, break mid-word
     251             :          ELSE
     252           0 :             ibreak = pos + i ! break at space closest to rowlen
     253             :          END IF
     254             :       END IF
     255           0 :    END FUNCTION next_linebreak
     256             : 
     257             : END MODULE cp_error_handling

Generated by: LCOV version 1.15