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