1!--------------------------------------------------------------------------------------------------! 2! Copyright (C) by the DBCSR developers group - All rights reserved ! 3! This file is part of the DBCSR library. ! 4! ! 5! For information on the license, see the LICENSE file. ! 6! For further information please visit https://dbcsr.cp2k.org ! 7! SPDX-License-Identifier: GPL-2.0+ ! 8!--------------------------------------------------------------------------------------------------! 9 10MODULE dbcsr_print_messages 11 !! Perform an abnormal program termination. 12 !! @note These routines are low-level and thus provide also an error recovery 13 !! when dependencies do not allow the use of the error logger. Only 14 !! the master (root) process will dump, if para_env is available and 15 !! properly specified. Otherwise (without any information about the 16 !! parallel environment) most likely more than one process or even all 17 !! processes will send their error dump to the default output unit. 18 19#include "base/dbcsr_base_uses.f90" 20 IMPLICIT NONE 21 22 PRIVATE 23 24 CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'dbcsr_print_messages' 25 26 PUBLIC :: print_message 27 28CONTAINS 29 30 SUBROUTINE print_message(message, output_unit, declev, before, after) 31 !! Perform a basic blocking of the text in message and print it 32 !! optionally decorated with a frame of stars as defined by declev. 33 !! @note 34 !! after : Number of empty lines after the message. 35 !! before : Number of empty lines before the message. 36 !! declev : Decoration level (0,1,2, ... star lines). 37 !! message : String with the message text. 38 !! output_unit: Logical unit number of output unit. 39 40 CHARACTER(LEN=*), INTENT(IN) :: message 41 INTEGER, INTENT(IN) :: output_unit 42 INTEGER, INTENT(IN), OPTIONAL :: declev, before, after 43 44 INTEGER :: blank_lines_after, blank_lines_before, & 45 decoration_level, i, ibreak, ipos1, & 46 ipos2, maxrowlen, msglen, nrow, rowlen 47 48 IF (PRESENT(after)) THEN 49 blank_lines_after = MAX(after, 0) 50 ELSE 51 blank_lines_after = 1 52 END IF 53 54 IF (PRESENT(before)) THEN 55 blank_lines_before = MAX(before, 0) 56 ELSE 57 blank_lines_before = 1 58 END IF 59 60 IF (PRESENT(declev)) THEN 61 decoration_level = MAX(declev, 0) 62 ELSE 63 decoration_level = 0 64 END IF 65 66 IF (decoration_level == 0) THEN 67 rowlen = 78 68 ELSE 69 rowlen = 70 70 END IF 71 72 msglen = LEN_TRIM(message) 73 74 ! Calculate number of rows 75 76 nrow = msglen/(rowlen + 1) + 1 77 78 ! Calculate appropriate row length 79 80 rowlen = MIN(msglen, rowlen) 81 82 ! Generate the blank lines before the message 83 84 DO i = 1, blank_lines_before 85 WRITE (UNIT=output_unit, FMT="(A)") "" 86 END DO 87 88 ! Scan for the longest row 89 90 ipos1 = 1 91 ipos2 = rowlen 92 maxrowlen = 0 93 94 DO 95 IF (ipos2 < msglen) THEN 96 i = INDEX(message(ipos1:ipos2), " ", BACK=.TRUE.) 97 IF (i == 0) THEN 98 ibreak = ipos2 99 ELSE 100 ibreak = ipos1 + i - 2 101 END IF 102 ELSE 103 ibreak = ipos2 104 END IF 105 106 maxrowlen = MAX(maxrowlen, ibreak - ipos1 + 1) 107 108 ipos1 = ibreak + 2 109 ipos2 = MIN(msglen, ipos1 + rowlen - 1) 110 111 ! When the last row is processed, exit loop 112 113 IF (ipos1 > msglen) EXIT 114 115 END DO 116 117 ! Generate the first set of star rows 118 119 IF (decoration_level > 1) THEN 120 DO i = 1, decoration_level - 1 121 WRITE (UNIT=output_unit, FMT="(T2,A)") REPEAT("*", maxrowlen + 8) 122 END DO 123 END IF 124 125 ! Break long messages 126 127 ipos1 = 1 128 ipos2 = rowlen 129 130 DO 131 IF (ipos2 < msglen) THEN 132 i = INDEX(message(ipos1:ipos2), " ", BACK=.TRUE.) 133 IF (i == 0) THEN 134 ibreak = ipos2 135 ELSE 136 ibreak = ipos1 + i - 2 137 END IF 138 ELSE 139 ibreak = ipos2 140 END IF 141 142 IF (decoration_level == 0) THEN 143 WRITE (UNIT=output_unit, FMT="(T2,A)") message(ipos1:ibreak) 144 ELSE IF (decoration_level > 0) THEN 145 WRITE (UNIT=output_unit, FMT="(T2,A)") & 146 "*** "//message(ipos1:ibreak)//REPEAT(" ", ipos1 + maxrowlen - ibreak)//"***" 147 END IF 148 149 ipos1 = ibreak + 2 150 ipos2 = MIN(msglen, ipos1 + rowlen - 1) 151 152 ! When the last row is processed, exit loop 153 154 IF (ipos1 > msglen) EXIT 155 END DO 156 157 ! Generate the second set star rows 158 159 IF (decoration_level > 1) THEN 160 DO i = 1, decoration_level - 1 161 WRITE (UNIT=output_unit, FMT="(T2,A)") REPEAT("*", maxrowlen + 8) 162 END DO 163 END IF 164 165 ! Generate the blank lines after the message 166 167 DO i = 1, blank_lines_after 168 WRITE (UNIT=output_unit, FMT="(A)") "" 169 END DO 170 171 END SUBROUTINE print_message 172 173END MODULE dbcsr_print_messages 174