!DECK XERPRN SUBROUTINE XERPRN (PREFIX, NPREF, MESSG, NWRAP) IMPLICIT NONE !***BEGIN PROLOGUE XERPRN !***SUBSIDIARY !***PURPOSE Print error messages processed by XERMSG. !***LIBRARY SLATEC (XERROR) !***CATEGORY R3C !***TYPE ALL (XERPRN-A) !***KEYWORDS ERROR MESSAGES, PRINTING, XERROR !***AUTHOR Fong, Kirby, (NMFECC at LLNL) !***DESCRIPTION ! ! This routine sends one or more lines to each of the (up to five) ! logical units to which error messages are to be sent. This routine ! is called several times by XERMSG, sometimes with a single line to ! print and sometimes with a (potentially very long) message that may ! wrap around into multiple lines. ! ! PREFIX Input argument of type CHARACTER. This argument contains ! characters to be put at the beginning of each line before ! the body of the message. No more than 16 characters of ! PREFIX will be used. ! ! NPREF Input argument of type INTEGER. This argument is the number ! of characters to use from PREFIX. If it is negative, the ! intrinsic function LEN is used to determine its length. If ! it is zero, PREFIX is not used. If it exceeds 16 or if ! LEN(PREFIX) exceeds 16, only the first 16 characters will be ! used. If NPREF is positive and the length of PREFIX is less ! than NPREF, a copy of PREFIX extended with blanks to length ! NPREF will be used. ! ! MESSG Input argument of type CHARACTER. This is the text of a ! message to be printed. If it is a long message, it will be ! broken into pieces for printing on multiple lines. Each line ! will start with the appropriate prefix and be followed by a ! piece of the message. NWRAP is the number of characters per ! piece; that is, after each NWRAP characters, we break and ! start a new line. In addition the characters '$$' embedded ! in MESSG are a sentinel for a new line. The counting of ! characters up to NWRAP starts over for each new line. The ! value of NWRAP typically used by XERMSG is 72 since many ! older error messages in the SLATEC Library are laid out to ! rely on wrap-around every 72 characters. ! ! NWRAP Input argument of type INTEGER. This gives the maximum size ! piece into which to break MESSG for printing on multiple ! lines. An embedded '$$' ends a line, and the count restarts ! at the following character. If a line break does not occur ! on a blank (it would split a word) that word is moved to the ! next line. Values of NWRAP less than 16 will be treated as ! 16. Values of NWRAP greater than 132 will be treated as 132. ! The actual line length will be NPREF + NWRAP after NPREF has ! been adjusted to fall between 0 and 16 and NWRAP has been ! adjusted to fall between 16 and 132. ! !***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC ! Error-handling Package, SAND82-0800, Sandia ! Laboratories, 1982. !***ROUTINES CALLED I1MACH, XGETUA !***REVISION HISTORY (YYMMDD) ! 880621 DATE WRITTEN ! 880708 REVISED AFTER THE SLATEC CML SUBCOMMITTEE MEETING OF ! JUNE 29 AND 30 TO CHANGE THE NAME TO XERPRN AND TO REWORK ! THE HANDLING OF THE NEW LINE SENTINEL TO BEHAVE LIKE THE ! SLASH CHARACTER IN FORMAT STATEMENTS. ! 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO ! STREAMLINE THE CODING AND FIX A BUG THAT CAUSED EXTRA BLANK ! LINES TO BE PRINTED. ! 890721 REVISED TO ADD A NEW FEATURE. A NEGATIVE VALUE OF NPREF ! CAUSES LEN(PREFIX) TO BE USED AS THE LENGTH. ! 891013 REVISED TO CORRECT ERROR IN CALCULATING PREFIX LENGTH. ! 891214 Prologue converted to Version 4.0 format. (WRB) ! 900510 Added code to break messages between words. (RWC) ! 920501 Reformatted the REFERENCES section. (WRB) !***END PROLOGUE XERPRN CHARACTER(len=*) :: PREFIX, MESSG INTEGER :: NPREF, NWRAP CHARACTER(len=148) :: CBUFF INTEGER :: IU(5), NUNIT CHARACTER(len=2) :: NEWLIN PARAMETER (NEWLIN = '$$') INTEGER :: N, I1MACH, I, LPREF, LWRAP, LENMSG, NEXTC INTEGER :: LPIECE, IDELTA !***FIRST EXECUTABLE STATEMENT XERPRN CALL XGETUA(IU,NUNIT) ! ! A ZERO VALUE FOR A LOGICAL UNIT NUMBER MEANS TO USE THE STANDARD ! ERROR MESSAGE UNIT INSTEAD. I1MACH(4) RETRIEVES THE STANDARD ! ERROR MESSAGE UNIT. ! N = I1MACH(4) DO I=1,NUNIT IF (IU(I) .EQ. 0) IU(I) = N END DO ! ! LPREF IS THE LENGTH OF THE PREFIX. THE PREFIX IS PLACED AT THE ! BEGINNING OF CBUFF, THE CHARACTER BUFFER, AND KEPT THERE DURING ! THE REST OF THIS ROUTINE. ! IF ( NPREF .LT. 0 ) THEN LPREF = LEN(PREFIX) ELSE LPREF = NPREF ENDIF LPREF = MIN(16, LPREF) IF (LPREF .NE. 0) CBUFF(1:LPREF) = PREFIX ! ! LWRAP IS THE MAXIMUM NUMBER OF CHARACTERS WE WANT TO TAKE AT ONE ! TIME FROM MESSG TO PRINT ON ONE LINE. ! LWRAP = MAX(16, MIN(132, NWRAP)) ! ! SET LENMSG TO THE LENGTH OF MESSG, IGNORE ANY TRAILING BLANKS. ! LENMSG = LEN(MESSG) N = LENMSG DO I=1,N IF (MESSG(LENMSG:LENMSG) .NE. ' ') GO TO 30 LENMSG = LENMSG - 1 END DO 30 CONTINUE ! ! IF THE MESSAGE IS ALL BLANKS, THEN PRINT ONE BLANK LINE. ! IF (LENMSG .EQ. 0) THEN CBUFF(LPREF+1:LPREF+1) = ' ' DO I=1,NUNIT WRITE(IU(I), '(A)') CBUFF(1:LPREF+1) END DO RETURN ENDIF ! ! SET NEXTC TO THE POSITION IN MESSG WHERE THE NEXT SUBSTRING ! STARTS. FROM THIS POSITION WE SCAN FOR THE NEW LINE SENTINEL. ! WHEN NEXTC EXCEEDS LENMSG, THERE IS NO MORE TO PRINT. ! WE LOOP BACK TO LABEL 50 UNTIL ALL PIECES HAVE BEEN PRINTED. ! ! WE LOOK FOR THE NEXT OCCURRENCE OF THE NEW LINE SENTINEL. THE ! INDEX INTRINSIC FUNCTION RETURNS ZERO IF THERE IS NO OCCURRENCE ! OR IF THE LENGTH OF THE FIRST ARGUMENT IS LESS THAN THE LENGTH ! OF THE SECOND ARGUMENT. ! ! THERE ARE SEVERAL CASES WHICH SHOULD BE CHECKED FOR IN THE ! FOLLOWING ORDER. WE ARE ATTEMPTING TO SET LPIECE TO THE NUMBER ! OF CHARACTERS THAT SHOULD BE TAKEN FROM MESSG STARTING AT ! POSITION NEXTC. ! ! LPIECE .EQ. 0 THE NEW LINE SENTINEL DOES NOT OCCUR IN THE ! REMAINDER OF THE CHARACTER STRING. LPIECE ! SHOULD BE SET TO LWRAP OR LENMSG+1-NEXTC, ! WHICHEVER IS LESS. ! ! LPIECE .EQ. 1 THE NEW LINE SENTINEL STARTS AT MESSG(NEXTC: ! NEXTC). LPIECE IS EFFECTIVELY ZERO, AND WE ! PRINT NOTHING TO AVOID PRODUCING UNNECESSARY ! BLANK LINES. THIS TAKES CARE OF THE SITUATION ! WHERE THE LIBRARY ROUTINE HAS A MESSAGE OF ! EXACTLY 72 CHARACTERS FOLLOWED BY A NEW LINE ! SENTINEL FOLLOWED BY MORE CHARACTERS. NEXTC ! SHOULD BE INCREMENTED BY 2. ! ! LPIECE .GT. LWRAP+1 REDUCE LPIECE TO LWRAP. ! ! ELSE THIS LAST CASE MEANS 2 .LE. LPIECE .LE. LWRAP+1 ! RESET LPIECE = LPIECE-1. NOTE THAT THIS ! PROPERLY HANDLES THE END CASE WHERE LPIECE .EQ. ! LWRAP+1. THAT IS, THE SENTINEL FALLS EXACTLY ! AT THE END OF A LINE. ! NEXTC = 1 50 LPIECE = INDEX(MESSG(NEXTC:LENMSG), NEWLIN) IF (LPIECE .EQ. 0) THEN ! ! THERE WAS NO NEW LINE SENTINEL FOUND. ! IDELTA = 0 LPIECE = MIN(LWRAP, LENMSG+1-NEXTC) IF (LPIECE .LT. LENMSG+1-NEXTC) THEN DO I=LPIECE+1,2,-1 IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN LPIECE = I-1 IDELTA = 1 GOTO 54 ENDIF END DO ENDIF 54 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) NEXTC = NEXTC + LPIECE + IDELTA ELSEIF (LPIECE .EQ. 1) THEN ! ! WE HAVE A NEW LINE SENTINEL AT MESSG(NEXTC:NEXTC+1). ! DON'T PRINT A BLANK LINE. ! NEXTC = NEXTC + 2 GO TO 50 ELSEIF (LPIECE .GT. LWRAP+1) THEN ! ! LPIECE SHOULD BE SET DOWN TO LWRAP. ! IDELTA = 0 LPIECE = LWRAP DO I=LPIECE+1,2,-1 IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN LPIECE = I-1 IDELTA = 1 GOTO 58 ENDIF END DO 58 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) NEXTC = NEXTC + LPIECE + IDELTA ELSE ! ! IF WE ARRIVE HERE, IT MEANS 2 .LE. LPIECE .LE. LWRAP+1. ! WE SHOULD DECREMENT LPIECE BY ONE. ! LPIECE = LPIECE - 1 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) NEXTC = NEXTC + LPIECE + 2 ENDIF ! ! PRINT ! DO I=1,NUNIT WRITE(IU(I), '(A)') CBUFF(1:LPREF+LPIECE) END DO ! IF (NEXTC .LE. LENMSG) GO TO 50 RETURN END SUBROUTINE XERPRN