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