GNU Octave  9.1.0
A high-level interpreted language, primarily intended for numerical computations, mostly compatible with Matlab
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
charNDArray max(char d, const charNDArray &m)
Definition: chNDArray.cc:230
charNDArray min(char d, const charNDArray &m)
Definition: chNDArray.cc:207
integer function i1mach(i)
Definition: i1mach.f:23
subroutine xerprn(PREFIX, NPREF, MESSG, NWRAP)
Definition: xerprn.f:3
subroutine xgetua(IUNITA, N)
Definition: xgetua.f:3