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