GCC Code Coverage Report


Directory: ./
File: misc/xerprn.f
Date: 2022-01-11 19:19:34
Exec Total Coverage
Lines: 0 52 0.0%
Branches: 0 52 0.0%

Line Branch Exec Source
1 *DECK XERPRN
2 SUBROUTINE XERPRN (PREFIX, NPREF, MESSG, NWRAP)
3 IMPLICIT NONE
4 C***BEGIN PROLOGUE XERPRN
5 C***SUBSIDIARY
6 C***PURPOSE Print error messages processed by XERMSG.
7 C***LIBRARY SLATEC (XERROR)
8 C***CATEGORY R3C
9 C***TYPE ALL (XERPRN-A)
10 C***KEYWORDS ERROR MESSAGES, PRINTING, XERROR
11 C***AUTHOR Fong, Kirby, (NMFECC at LLNL)
12 C***DESCRIPTION
13 C
14 C This routine sends one or more lines to each of the (up to five)
15 C logical units to which error messages are to be sent. This routine
16 C is called several times by XERMSG, sometimes with a single line to
17 C print and sometimes with a (potentially very long) message that may
18 C wrap around into multiple lines.
19 C
20 C PREFIX Input argument of type CHARACTER. This argument contains
21 C characters to be put at the beginning of each line before
22 C the body of the message. No more than 16 characters of
23 C PREFIX will be used.
24 C
25 C NPREF Input argument of type INTEGER. This argument is the number
26 C of characters to use from PREFIX. If it is negative, the
27 C intrinsic function LEN is used to determine its length. If
28 C it is zero, PREFIX is not used. If it exceeds 16 or if
29 C LEN(PREFIX) exceeds 16, only the first 16 characters will be
30 C used. If NPREF is positive and the length of PREFIX is less
31 C than NPREF, a copy of PREFIX extended with blanks to length
32 C NPREF will be used.
33 C
34 C MESSG Input argument of type CHARACTER. This is the text of a
35 C message to be printed. If it is a long message, it will be
36 C broken into pieces for printing on multiple lines. Each line
37 C will start with the appropriate prefix and be followed by a
38 C piece of the message. NWRAP is the number of characters per
39 C piece; that is, after each NWRAP characters, we break and
40 C start a new line. In addition the characters '$$' embedded
41 C in MESSG are a sentinel for a new line. The counting of
42 C characters up to NWRAP starts over for each new line. The
43 C value of NWRAP typically used by XERMSG is 72 since many
44 C older error messages in the SLATEC Library are laid out to
45 C rely on wrap-around every 72 characters.
46 C
47 C NWRAP Input argument of type INTEGER. This gives the maximum size
48 C piece into which to break MESSG for printing on multiple
49 C lines. An embedded '$$' ends a line, and the count restarts
50 C at the following character. If a line break does not occur
51 C on a blank (it would split a word) that word is moved to the
52 C next line. Values of NWRAP less than 16 will be treated as
53 C 16. Values of NWRAP greater than 132 will be treated as 132.
54 C The actual line length will be NPREF + NWRAP after NPREF has
55 C been adjusted to fall between 0 and 16 and NWRAP has been
56 C adjusted to fall between 16 and 132.
57 C
58 C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
59 C Error-handling Package, SAND82-0800, Sandia
60 C Laboratories, 1982.
61 C***ROUTINES CALLED I1MACH, XGETUA
62 C***REVISION HISTORY (YYMMDD)
63 C 880621 DATE WRITTEN
64 C 880708 REVISED AFTER THE SLATEC CML SUBCOMMITTEE MEETING OF
65 C JUNE 29 AND 30 TO CHANGE THE NAME TO XERPRN AND TO REWORK
66 C THE HANDLING OF THE NEW LINE SENTINEL TO BEHAVE LIKE THE
67 C SLASH CHARACTER IN FORMAT STATEMENTS.
68 C 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO
69 C STREAMLINE THE CODING AND FIX A BUG THAT CAUSED EXTRA BLANK
70 C LINES TO BE PRINTED.
71 C 890721 REVISED TO ADD A NEW FEATURE. A NEGATIVE VALUE OF NPREF
72 C CAUSES LEN(PREFIX) TO BE USED AS THE LENGTH.
73 C 891013 REVISED TO CORRECT ERROR IN CALCULATING PREFIX LENGTH.
74 C 891214 Prologue converted to Version 4.0 format. (WRB)
75 C 900510 Added code to break messages between words. (RWC)
76 C 920501 Reformatted the REFERENCES section. (WRB)
77 C***END PROLOGUE XERPRN
78 CHARACTER*(*) PREFIX, MESSG
79 INTEGER NPREF, NWRAP
80 CHARACTER*148 CBUFF
81 INTEGER IU(5), NUNIT
82 CHARACTER*2 NEWLIN
83 PARAMETER (NEWLIN = '$$')
84 INTEGER N, I1MACH, I, LPREF, LWRAP, LENMSG, NEXTC
85 INTEGER LPIECE, IDELTA
86 C***FIRST EXECUTABLE STATEMENT XERPRN
87 CALL XGETUA(IU,NUNIT)
88 C
89 C A ZERO VALUE FOR A LOGICAL UNIT NUMBER MEANS TO USE THE STANDARD
90 C ERROR MESSAGE UNIT INSTEAD. I1MACH(4) RETRIEVES THE STANDARD
91 C ERROR MESSAGE UNIT.
92 C
93 N = I1MACH(4)
94 DO 10 I=1,NUNIT
95 IF (IU(I) .EQ. 0) IU(I) = N
96 10 CONTINUE
97 C
98 C LPREF IS THE LENGTH OF THE PREFIX. THE PREFIX IS PLACED AT THE
99 C BEGINNING OF CBUFF, THE CHARACTER BUFFER, AND KEPT THERE DURING
100 C THE REST OF THIS ROUTINE.
101 C
102 IF ( NPREF .LT. 0 ) THEN
103 LPREF = LEN(PREFIX)
104 ELSE
105 LPREF = NPREF
106 ENDIF
107 LPREF = MIN(16, LPREF)
108 IF (LPREF .NE. 0) CBUFF(1:LPREF) = PREFIX
109 C
110 C LWRAP IS THE MAXIMUM NUMBER OF CHARACTERS WE WANT TO TAKE AT ONE
111 C TIME FROM MESSG TO PRINT ON ONE LINE.
112 C
113 LWRAP = MAX(16, MIN(132, NWRAP))
114 C
115 C SET LENMSG TO THE LENGTH OF MESSG, IGNORE ANY TRAILING BLANKS.
116 C
117 LENMSG = LEN(MESSG)
118 N = LENMSG
119 DO 20 I=1,N
120 IF (MESSG(LENMSG:LENMSG) .NE. ' ') GO TO 30
121 LENMSG = LENMSG - 1
122 20 CONTINUE
123 30 CONTINUE
124 C
125 C IF THE MESSAGE IS ALL BLANKS, THEN PRINT ONE BLANK LINE.
126 C
127 IF (LENMSG .EQ. 0) THEN
128 CBUFF(LPREF+1:LPREF+1) = ' '
129 DO 40 I=1,NUNIT
130 WRITE(IU(I), '(A)') CBUFF(1:LPREF+1)
131 40 CONTINUE
132 RETURN
133 ENDIF
134 C
135 C SET NEXTC TO THE POSITION IN MESSG WHERE THE NEXT SUBSTRING
136 C STARTS. FROM THIS POSITION WE SCAN FOR THE NEW LINE SENTINEL.
137 C WHEN NEXTC EXCEEDS LENMSG, THERE IS NO MORE TO PRINT.
138 C WE LOOP BACK TO LABEL 50 UNTIL ALL PIECES HAVE BEEN PRINTED.
139 C
140 C WE LOOK FOR THE NEXT OCCURRENCE OF THE NEW LINE SENTINEL. THE
141 C INDEX INTRINSIC FUNCTION RETURNS ZERO IF THERE IS NO OCCURRENCE
142 C OR IF THE LENGTH OF THE FIRST ARGUMENT IS LESS THAN THE LENGTH
143 C OF THE SECOND ARGUMENT.
144 C
145 C THERE ARE SEVERAL CASES WHICH SHOULD BE CHECKED FOR IN THE
146 C FOLLOWING ORDER. WE ARE ATTEMPTING TO SET LPIECE TO THE NUMBER
147 C OF CHARACTERS THAT SHOULD BE TAKEN FROM MESSG STARTING AT
148 C POSITION NEXTC.
149 C
150 C LPIECE .EQ. 0 THE NEW LINE SENTINEL DOES NOT OCCUR IN THE
151 C REMAINDER OF THE CHARACTER STRING. LPIECE
152 C SHOULD BE SET TO LWRAP OR LENMSG+1-NEXTC,
153 C WHICHEVER IS LESS.
154 C
155 C LPIECE .EQ. 1 THE NEW LINE SENTINEL STARTS AT MESSG(NEXTC:
156 C NEXTC). LPIECE IS EFFECTIVELY ZERO, AND WE
157 C PRINT NOTHING TO AVOID PRODUCING UNNECESSARY
158 C BLANK LINES. THIS TAKES CARE OF THE SITUATION
159 C WHERE THE LIBRARY ROUTINE HAS A MESSAGE OF
160 C EXACTLY 72 CHARACTERS FOLLOWED BY A NEW LINE
161 C SENTINEL FOLLOWED BY MORE CHARACTERS. NEXTC
162 C SHOULD BE INCREMENTED BY 2.
163 C
164 C LPIECE .GT. LWRAP+1 REDUCE LPIECE TO LWRAP.
165 C
166 C ELSE THIS LAST CASE MEANS 2 .LE. LPIECE .LE. LWRAP+1
167 C RESET LPIECE = LPIECE-1. NOTE THAT THIS
168 C PROPERLY HANDLES THE END CASE WHERE LPIECE .EQ.
169 C LWRAP+1. THAT IS, THE SENTINEL FALLS EXACTLY
170 C AT THE END OF A LINE.
171 C
172 NEXTC = 1
173 50 LPIECE = INDEX(MESSG(NEXTC:LENMSG), NEWLIN)
174 IF (LPIECE .EQ. 0) THEN
175 C
176 C THERE WAS NO NEW LINE SENTINEL FOUND.
177 C
178 IDELTA = 0
179 LPIECE = MIN(LWRAP, LENMSG+1-NEXTC)
180 IF (LPIECE .LT. LENMSG+1-NEXTC) THEN
181 DO 52 I=LPIECE+1,2,-1
182 IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN
183 LPIECE = I-1
184 IDELTA = 1
185 GOTO 54
186 ENDIF
187 52 CONTINUE
188 ENDIF
189 54 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1)
190 NEXTC = NEXTC + LPIECE + IDELTA
191 ELSEIF (LPIECE .EQ. 1) THEN
192 C
193 C WE HAVE A NEW LINE SENTINEL AT MESSG(NEXTC:NEXTC+1).
194 C DON'T PRINT A BLANK LINE.
195 C
196 NEXTC = NEXTC + 2
197 GO TO 50
198 ELSEIF (LPIECE .GT. LWRAP+1) THEN
199 C
200 C LPIECE SHOULD BE SET DOWN TO LWRAP.
201 C
202 IDELTA = 0
203 LPIECE = LWRAP
204 DO 56 I=LPIECE+1,2,-1
205 IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN
206 LPIECE = I-1
207 IDELTA = 1
208 GOTO 58
209 ENDIF
210 56 CONTINUE
211 58 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1)
212 NEXTC = NEXTC + LPIECE + IDELTA
213 ELSE
214 C
215 C IF WE ARRIVE HERE, IT MEANS 2 .LE. LPIECE .LE. LWRAP+1.
216 C WE SHOULD DECREMENT LPIECE BY ONE.
217 C
218 LPIECE = LPIECE - 1
219 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1)
220 NEXTC = NEXTC + LPIECE + 2
221 ENDIF
222 C
223 C PRINT
224 C
225 DO 60 I=1,NUNIT
226 WRITE(IU(I), '(A)') CBUFF(1:LPREF+LPIECE)
227 60 CONTINUE
228 C
229 IF (NEXTC .LE. LENMSG) GO TO 50
230 RETURN
231 END
232