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