GNU Octave  3.8.0
A high-level interpreted language, primarily intended for numerical computations, mostly compatible with Matlab
 All Classes Namespaces Files Functions Variables Typedefs Enumerations Enumerator Properties Friends Macros Pages
xerprn.f
Go to the documentation of this file.
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