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