| 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 |
|---|
