DOCPRT
* /--- FILE TYPE = E
* /--- BLOCK DOCPRT 00 000 80/09/16 10.18
PROGRAM DOCPRT(OUTPUT,PARAM,DEBUG=OUTPUT,TAPE4=PARAM)
***** DOCPRT
*
* PROGRAM TO PRINT DOCUMENTOR FILES.
*
* PRINTS NEW FORMAT (NAMESET TYPE) DOCUMENTOR FILES.
* ALLOWS SELECTION OF PARAMETERS AT THE SUBSECTION
* LEVEL, ALONG WITH A NUMBER OF OTHER CONTROLS.
*
*
**
* FOR THE FORMAT OF DOCUMENTOR FILES, SEE THE
* DOCUMENT -DOCSPEC-.
*
*
*
** DATA STRUCTURES
*
* COMMON /TITLES/
**
* HOLDS THE TITLES OF THE CURRENT MAJOR SECTION.
*
*
* COMMON /SECT/
**
* HOLDS THE SECTION CURRENTLY BEING PRINTED.
*
*
* COMMON /MISC/
**
* MISC INFO FOR THE DOCUMENT (TITLES, ETC). THE
* SECOND RECORD OF THE MISC INFO NAME. MUST
* CORRESPOND TO THE DEFINES ON PLATO.
*
*
*
* COMMON /DIREC/
**
* HOLDS THE NAMESET DIRECTORY FOR PLATLIB ROUTINES.
*
*
* COMMON /PARAM/
**
* PARAMETERS USED TO CONTROL PRINTS. READ IN FROM
* AN AUXILLIARY FILE WHEN THE PRINT IS INITIALIZED.
*
*
*
* COMMON /PGNO/
**
* PAGE NUMBERS OF SECTIONS, GENERATED DURING PRINT.
*
*
* /--- BLOCK DOCPRT 00 000 84/02/14 22.34
*
*
* COMMON /PRINT/
**
* PRINT CONTROLS. USED IN CONJUNCTION WITH */
* CONTROLS TO PRODUCE PRINTS.
*
*
*
*
****
*CALL DOCPRTC
****
*
*
LOGICAL SECTBIT
INTEGER NAME(3)
* /--- BLOCK DOCPRT 00 000 84/02/14 22.35
** LOGIC -
*
* ATTACH THE DOCUMENT, CHECK FOR CORRECT FILE TYPE.
*
CALL EXECARG(FNAME)
CALL ATTACH(DIR,FNAME,0,IERR)
IF (IERR.NE.-1) GOTO 5000
IF ((IFTYPE(DIR).NE."DOCUMENT Q") .AND.
1 (IFTYPE(DIR).NE."NAMESET K"))
2 GOTO 5000
**
* SETUP FOR PRINTING.
C
C OUTPUT ACCOUNTING DAYFILE MESSAGE.
C
CALL ACCT
C
C READ SELECTION BITS
C
READ (4,1001) SECBITS(1)
READ (4,1001) SECBITS(2)
1001 FORMAT(O20)
*
PRTP =SECTBIT(100)
ABSTR =SECTBIT(101)
OUTLINE=SECTBIT(102)
PRTEXT =SECTBIT(103)
C
C INITIALIZE PROGRAM PARAMETERS.
C
CALL PINIT
MS=-1
C
C SETNAME TO THE MISC INFO NAME.
C
NAME(1)=5L;MISC
NAME(2)=0
NAME(3)=0
CALL SETNAME(DIR,NAME,IERR)
IF (IERR.NE.-1) GOTO 5000
IF (IRECS(DIR).NE.2) GOTO 5000
CALL NDATAIN(DIR,2,DOCTTL1(1),1)
IF (IERR.NE.-1) CALL ERROR("DATAIN",IERR)
**
* PRINT THE TITLE PAGE IF SELECTED.
*
IF (PRTP) CALL TTLPAGE
**
* PRINT THE ABSTRACT IF SELECTED.
*
IF (ABSTR) CALL ABSTRCT
**
* SETUP PAGE NUMBERS AND PAGE TITLE.
*
IPGNO=1
DO 200 I=1,10
PTITLE(I)=PGHDRE(I)
200 CONTINUE
CALL CLEAN(PTITLE,10)
**
* PRINT THE TEXT OF EACH SECTION, IF TEXT SELECTED
* AND THE SECTION SELECTED.
*
IF (PRTEXT) CALL PTEXT
**
* PRINT THE OUTLINE IF SELECTED.
*
IF (OUTLINE) CALL OUTLIN
C
C DONE WITH PRINT. DETACH THE FILE AND LEAVE.
C
CALL DETACH(DIR)
STOP
C
C ERROR MESSAGE IF NOT A DOCUMENT.
C
5000 PRINT *,"FILE ",FNAME," IS NOT A DOCUMENTOR FILE."
CALL DETACH(DIR)
STOP
C
END
* /--- BLOCK TTLPAGE 00 000 80/07/31 13.21
SUBROUTINE TTLPAGE
** TTLPAGE
*
* PRINT THE TITLE PAGE OF THE CURRENT DOCUMENT.
*
C
C COMMON DECKS.
C
*CALL,DOCPRTC
C
C HLINES = .TRUE. IF THE 2 LINE HEADER EXISTS.
C INTRO = .TRUE. IF AN INTRODUCTION EXISTS.
C
LOGICAL HLINES,INTRO
INTEGER NAME(3)
C
C CHECK IF THERE IS A TITLE PAGE. FIRST CHECK FOR
C HEADER LINES EXISTING.
C
C THE HEADER LINE CHECK SHOULD USE A BITCNT FUNCTION
C SOMEDAY.
C
HLINES=(DOCTTL1(1).NE.0).OR.((DOCTTL1(1).AND.MASK(30)).NE.0)
C
NAME(1)=7L;AUTHOR
NAME(2)=NAME(3)=0
CALL SETNAME(DIR,NAME,IERR)
INTRO=(IERR.EQ.-1)
C
IF (.NOT.(HLINES.OR.INTRO)) RETURN
C
C FEED DOWN 10 SPACES.
C
CALL NEWPAGE
CALL BLANKLN(10)
C
C CHECK IF HEADER LINES EXIST. IF SO, PRINT THEM.
C
IF (HLINES) GOTO 100
CALL BLANKLN(6)
GOTO 200
C
100 CONTINUE
CALL CLEAN(DOCTTL1,5)
CALL CLEAN(DOCTTL2,5)
PRINT 2000,(DOCTTL1(I),I=1,5),(DOCTTL2(I),I=1,5)
2000 FORMAT (9X,5(10H**********),4H****/
1 9X,1H*,52X,1H*/
2 9X,2H* ,5A10/
2 1H+,61X,1H*/
3 9X,2H* ,5A10/
3 1H+,61X,1H*/
4 9X,1H*,52X,1H*/
5 9X,5(10H**********),4H****/)
C
200 CONTINUE
C
C NOW PRINT THE CURRENT DATE.
C
CALL BLANKLN(6)
CALL DATE(IDATE)
PRINT 2001,IDATE
2001 FORMAT (9X,30X,A10)
C
C PRINT THE INTRODUCTION, IF ANY.
C
IF (.NOT.INTRO) RETURN
C
CALL BLANKLN(10)
CALL NDATAIN(DIR,1,SECTION,IRECS(DIR),IERR)
IF (IERR.NE.-1) CALL ERROR("DATAIN",IERR)
C
CALL PRSECT
C
RETURN
END
* /--- BLOCK ABSTRCT 00 000 80/07/31 13.21
SUBROUTINE ABSTRCT
** ABSTRCT
*
* PRINT THE DOCUMENT ABSTRACT, IF ANY.
*
* READS THE ABSTRACT AND PRINTS IT ON A NEW PAGE.
*
*
*CALL,DOCPRTC
INTEGER NAME(3)
C
C SETNAME TO THE ABSTRACT NAME.
C
NAME(1)=5L;DESC
NAME(2)=0
NAME(3)=0
CALL SETNAME(DIR,NAME,IERR)
IF (IERR.NE.-1) RETURN
C
C READ THE ABSTRACT AND PRINT IT.
C
CALL NDATAIN(DIR,1,SECTION,IRECS(DIR),IERR)
IF (IERR.NE.-1) CALL ERROR("DATAIN",IERR)
C
CALL NEWPAGE
C
CALL PRSECT
RETURN
END
* /--- BLOCK OUTLIN 00 000 80/09/15 16.50
SUBROUTINE OUTLIN
** OUTLIN
*
* PRINT THE DOCUMENT OUTLINE. PRINTS THE OUTLINE
* FOR SELECTED SUBSECTIONS ONLY. A SPACE IS PRINTED
* BEFORE EACH NEW MAJOR SECTION (DEFAULT).
*
C
*CALL,DOCPRTC
C
INTEGER CURSECT(3)
C
C TURN OFF PAGE NUMBERING AND TITLES.
C
IPGNO = 0
LENTTL = 0
SCTIND = 1
C
C FIRST PRINT THE PAGE HEADING.
C
CALL NEWPAGE
CALL PRLINE(1H ,1)
PRINT 2000
2000 FORMAT ("+",31X,"'TABLE OF 'CONTENTS")
CALL PRLINE(1H ,1)
C
C LOOP THRU EACH SECTION, PRINTING IT IF SELECTED.
C
CALL SETBLNK(DIR,IERR)
IF (IERR.NE.-1) CALL ERROR("SETBLNK",IERR)
LASTONE = 0
C
100 CONTINUE
CALL NXTSCT(CURSECT,INDEX)
IF (INDEX .EQ. -1) GOTO 500
C-- PRINT THE CURRENTLY SELECTED SECTION.
IF (INDEX.EQ.LASTONE) GOTO 1001
CALL BLANKLN(1)
LASTONE = INDEX
1001 CONTINUE
IF (PRTEXT) CALL PRINTTL(PAGENO(SCTIND))
IF (.NOT. PRTEXT) CALL PRINTTL(0)
SCTIND = SCTIND + 1
C
GOTO 100
C
500 CONTINUE
RETURN
END
* /--- BLOCK PTEXT 00 000 80/09/15 16.50
SUBROUTINE PTEXT
** PTEXT
*
* PRINT THE TEXT OF A DOCUMENT. PRINTS ONLY THOSE
* SUBSECTIONS WHICH ARE SELECTED.
*
*
C
*CALL,DOCPRTC
C
INTEGER CURSECT(3)
C
C
C START PRINTING TEXT ON A NEW PAGE.
C ALSO TURN ON PAGE NUMBERS.
C
CALL NEWPAGE
IPGNO=1
SCTIND = 1
C
C LOOP THRU EACH SECTION, PRINTING IT IF SELECTED.
C
CALL SETBLNK(DIR,IERR)
IF (IERR.NE.-1) CALL ERROR("SETBLNK",IERR)
C
100 CONTINUE
CALL NXTSCT(CURSECT,INDEX)
IF (INDEX .EQ. -1) GOTO 500
C-- PRINT THE CURRENTLY SELECTED SECTION.
IF (INDEX.EQ.LASTONE) GOTO 1001
CALL NEWPAGE
LASTONE = INDEX
1001 CONTINUE
CALL PRLINE(1H ,1)
CALL PRINTTL(0)
PAGENO(SCTIND) = IPGNO - 1
SCTIND = SCTIND + 1
CALL PRLINE(1H ,1)
C-- READ IN THE SECTION.
CALL NDATAIN(DIR,1,SECTION,IRECS(DIR),IERR)
IF (IERR.NE.-1) CALL ERROR("DATAIN",IERR)
C-- PRINT THE SECTION.
CALL PRSECT
C
GOTO 100
C
500 CONTINUE
RETURN
END
*
SUBROUTINE PRSECT
** PRSECT
*
* PRINT THE CURRENTLY READ IN SECTION.
*
*CALL,DOCPRTC
C
CALL PBUFFER(SECTION(6),(SECTION(1).AND.777B))
RETURN
END
*
* /--- BLOCK PBUFFER 00 000 80/09/09 16.15
SUBROUTINE NXTSCT(SCTNUM, MSNUM)
*
** NXTSCT
*
* GET THE NEXT SECTION TO BE PRINTED. USES THE
* SETNEXT ROUTINE TO STEP THROUGH THE FILE UNTIL A
* SELECTED SECTION IS FOUND.
*
* EXIT -
*
* SCTNUM = THE SECTION NUMBER (3 WORDS).
* MSNUM = MAJOR SECTION OF SCTNUM. -1 IF END
* OF FILE.
*
*
*CALL DOCPRTC
LOGICAL SECTBIT
INTEGER SCTNUM(3)
C
100 CONTINUE
MSNUM = -1
C
C SET NEXT SECTION. IF END OF FILE, EXIT LOOP.
C
CALL SETNEXT(DIR,IERR)
IF (IERR.NE.-1) RETURN
C
C GET SECTION NAME AND CHECK FOR ; NAME.
C
CALL GETNAME(DIR,SCTNUM)
IF ( (SHIFT(SCTNUM,6).AND.77B) .EQ.1R; ) RETURN
C
C GET MAJOR SECTION NUMBER.
C
DIGIT10 = SHIFT(SCTNUM,6).AND.77B
IF (DIGIT10.NE.0) DIGIT10=DIGIT10-1R0
DIGIT1 = (SHIFT(SCTNUM,12).AND.77B)-1R0
MSNUM = 10*DIGIT10 + DIGIT1
C
C CHECK IF THIS SECTION PRINTABLE.
C
IF (.NOT.SECTBIT(MSNUM)) GOTO 100
C
RETURN
END
* /--- BLOCK PBUFFER 00 000 80/09/09 16.15
SUBROUTINE PBUFFER(IBUF,LENGTH)
** PBUFFER
*
* PRINT A BUFFER OF TEXT. PRINTS THE TEXT,
* PROCESSING */, *LIST, ETC. CONTROLS.
*
*
*
INTEGER IBUF(508)
C PROCESS EACH LINE, ONE BY ONE, UNTIL END OF TEXT.
C
C INDEX IS THE CURRENT TEXT POINTER.
C LLEN IS THE LENGTH OF THE CURRENT LINE.
C
ISTATUS=0
INDEX=1
C
IF (LENGTH.EQ.0) RETURN
C
C FORCE END OF LINE AT END OF BUFFER.
C
IBUF(LENGTH+1)=0
C
100 CONTINUE
CALL NEXTLIN(IBUF,INDEX,LLEN)
C
C CHECK FOR */, ETC CONTROLS.
C
IF (((IBUF(INDEX).AND.MASK(6)).EQ.1L*)
1 .OR.(ISTATUS.EQ.1))
1 CALL FORMAT(IBUF(INDEX),LLEN,ISTATUS)
C
C
C PRINT THE CURRENT LINE OF TEXT UNLESS VALID */
C LINE FOUND.
C
IF (ISTATUS.EQ.0)
1 CALL PRLINE(IBUF(INDEX),LLEN)
IF (ISTATUS.EQ.-1) ISTATUS=0
C
C UPDATE TEXT POINTER AND CHECK FOR END OF TEXT.
C
INDEX=INDEX+LLEN
IF (INDEX.LE.LENGTH) GOTO 100
RETURN
END
* /--- BLOCK PRBUF-UTIL 00 000 80/08/27 16.25
SUBROUTINE NEXTLIN(IBUF,IPTR,LLEN)
** NEXTLIN(IBUF,IPTR,LLEN)
*
* FIND THE LENGTH OF THE CURRENT LINE.
*
* IBUF IS THE TEXT BUFFER.
* IPTR IS THE CURRENT POINTER INTO THE TEXT.
* LLEN RETURNS THE LENGTH OF THE NEXT LINE.
*
* IT IS ASSUMED THAT AN END OF LINE EXISTS.
*
INTEGER IBUF(507)
LOGICAL EOL
C
C SCAN THE TEXT WORD BY WORD UNTIL AN END OF LINE
C IS FOUND.
C
INDEX=IPTR-1
C-- LOOP
100 CONTINUE
INDEX=INDEX+1
IF (.NOT.EOL(IBUF(INDEX))) GOTO 100
C-- ENDLOOP
LLEN=INDEX-IPTR+1
RETURN
END
*
LOGICAL FUNCTION EOL(IWORD)
** LOGICAL EOL(IWORD)
*
* FUNCTION. RETURNS TRUE IF IWORD IS AN END OF
* LINE (LOWER 12 BITS ZERO), ELSE FALSE.
*
EOL=((IWORD .AND. 7777B) .EQ. 0)
RETURN
END
*
SUBROUTINE ERROR(ITYPE,IERR)
** ERROR(ITYPE,IERR)
*
* REPORT AN ERROR IN THE PRINT. PRINTS THE ERROR
* TYPE AND NUMBER. ERROR TYPE IS AN A10 CONSTANT,
* ERROR NUMBER IS THE ERROR RETURNED FROM VARIOUS
* SUBROUTINES.
*
EXTERNAL RWORDS,NDATOUT
PRINT *,"ERROR ",ITYPE,", NUMBER ",IERR
CALL STRACE
STOP
END
*
SUBROUTINE FWORD(BUF,LEN,POS,WORD)
** FWORD(BUF,LEN,POS,WORD)
*
* GET THE FIRST WORD FROM THE BUFFER BUF, OF LENGTH
* LEN, RETURNING THE POSITION+1 OF THE END OF THE
* WORD IN POS AND THE WORD IN WORD. BUF IS IN
* R1 FORMAT. LEADING SPACES ARE DROPPED.
*
*
*
INTEGER BUF(LEN),POS,WORD
C
IWORD=0
C
C-- SKIP SPACES.
DO 100 POS=1,LEN
IF (BUF(POS).NE.1R ) GOTO 150
IF (BUF(POS).EQ.0) RETURN
100 CONTINUE
RETURN
C
C-- FIND A SPACE OR ZERO AT THE END OF THE LINE (TO ISOLATE
C-- THE WORD).
150 CONTINUE
IWSTRT=POS
DO 200 POS=IWSTRT,LEN
IF (BUF(POS).EQ.1R ) GOTO 250
IF (BUF(POS).EQ.0) GOTO 250
200 CONTINUE
RETURN
C
C-- FOUND SPACE ALSO. ENCODE THE WORD.
250 CONTINUE
ITPOS =POS-1
ENCODE (10,1000,WORD) (BUF(I),I=IWSTRT,ITPOS)
1000 FORMAT (10R1)
RETURN
END
* /--- BLOCK FORMAT 00 000 80/09/15 17.17
SUBROUTINE FORMAT(LINE,LLEN,ISTATUS)
** FORMAT(LINE,LLEN,RSTATUS)
*
* ENTRY -
*
* LINE - ARRAY HOLDING THE CURRENT LINE. A10
* FORMAT.
* LLEN - LENGTH OF -LINE- IN WORDS.
*
* EXIT -
*
* ISTATUS - RETURN STATUS.
* -1 = VALID */ LINE FOUND.
* 0 = ILLEGAL */ LINE FOUND.
* 1 = SEND THE NEXT LINE TO THIS ROUTINE.
* USED FOR */GRAPHU.
*
* PROCESS */, *LIST, *TYPE, AND *FORMAT WORDS.
* THE CONTROLS PROCESSED ARE BASICALLY THE SAME AS
* LESSON -PRINT- FOR LOCAL PRINTERS -
*
* */, *LIST, *TYPE, AND *FORMAT ARE SYNONYMOUS.
*
* THE DIRECTIVES PROCESSED ARE -
*
* */EJECT
* */GRAPHU (IGNORED)
*
*
INTEGER LINE(LLEN),FBUF(150)
C
C IF ISTATUS=1, SKIPPING */GRAPHU FOR */END.
C
IF (ISTATUS.NE.1) GOTO 100
IF (LINE(1).EQ.5L*/END) ISTATUS=-1
RETURN
C
C EXPAND THE LINE OUT (VIA DECODE), CHECK FOR VALID
C */ TYPE, AND GET THE FIRST */ WORD.
C
100 CONTINUE
LCHAR=LLEN*10
DECODE (LCHAR,2000,LINE) LCHAR,(FBUF(I),I=1,LCHAR)
2000 FORMAT (=(R1))
C
C-- INITIALIZE TO BAD */ TYPE.
ISTATUS=0
IF (FBUF(1).NE.1R*) RETURN
C
C-- */ HAS NO SPACE BEFORE DIRECTIVE, ENCODE DIRECTLY.
IPOS=3
IF (FBUF(2).EQ.1R/) GOTO 200
C-- SPACE AFTER * MEANS INVALID.
IF (FBUF(2).EQ.1R ) RETURN
C
C-- FIND THE FIRST WORD.
CALL FWORD(FBUF(2),LCHAR-1,IPOS,IWORD)
IPOS=IPOS+1
C
IF (IWORD.EQ.0) RETURN
IF (IWORD.EQ."LIST") GOTO 200
IF (IWORD.EQ."TYPE") GOTO 200
IF (IWORD.EQ."FORMAT") GOTO 200
RETURN
C
C-- HAVE A LIST COMMAND. GET NEXT WORD FROM IT.
200 CONTINUE
CALL FWORD(FBUF(IPOS),LCHAR-IPOS+1,IPOS2,IWORD)
IPOS=IPOS+IPOS2
IF (IWORD.NE."EJECT") GOTO 300
CALL NEWPAGE
ISTATUS=-1
RETURN
*
300 CONTINUE
IF (IWORD.EQ."GRAPHU") ISTATUS=1
C
RETURN
END
* /--- BLOCK PRINTTL 00 000 80/07/31 17.40
SUBROUTINE PRINTTL(IPAGE)
** PRINTTL
*
* PRINT THE TITLE LINE OF THE CURRENT SUBSECTION.
*
C
*CALL,DOCPRTC
C
INTEGER CSECT(3),DSECT(3),TITLE(5),LINE(14)
C
C
DO 50 I = 1,14
50 LINE(I) = 0
C
C FIRST GET THE SECTION NAME AND TITLE. BE SURE THE
C TITLE HAS AN EOL AT THE END (EXTRA ZERO WORD).
C
CALL GETNAME(DIR,CSECT)
CALL SECTDSP(CSECT,DSECT,SLEN)
CALL GETTTL(TITLE)
TITLE(5) = 0
C
C GET ALPHA PAGE NUMBER.
C
ENCODE (10,2000,IPG) IPAGE
2000 FORMAT (I4)
IPG = IPG .AND. MASK(24)
C
C PACK THE FINAL LINE TOGETHER, DEPENDING ON WHETHER
C WE INCLUDE PAGE NUMBER OR NOT.
C
IF (IPAGE .EQ. 0)
1 CALL CONCAT(LINE, LLEN, DSECT, 4L , TITLE)
IF (IPAGE .NE. 0)
1 CALL CONCAT(LINE, LLEN, DSECT, 4L , TITLE,
2 60, IPG)
C
C
CALL PRLINE(LINE,LLEN)
RETURN
END
* /--- BLOCK DOCFUNC 00 000 84/03/03 18.01
SUBROUTINE GETTTL(TITLE)
** GETTTL(TITLE)
*
* RETURNS THE TITLE OF THE CURRENTLY SET SECTION
* IN THE VARIABLE *TITLE*.
*
*CALL,DOCPRTC
INTEGER TITLE(4),SECT(3),NAME(3)
C
C GET THE SECTION NAME.
C
CALL GETNAME(DIR,SECT,INFO)
C
C FIRST CHECK IF THE CURRENT MAJOR SECTION TITLES
C ARE LOADED. IF NOT, LOAD NEW TITLES.
C
IF (MS.EQ.MSNUM(SECT)) GOTO 100
MS=MSNUM(SECT)
NAME(1)=8L;TITLES. .OR. MS
NAME(2)=0
NAME(3)=0
CALL SETNAME(DIR,NAME,IERR)
IF (IERR.NE.-1) CALL ERROR("T SETNAME",IERR)
CALL NDATAIN(DIR,1,TTL,IRECS(DIR),IERR)
IF (IERR.NE.-1) CALL ERROR("DATAIN",IERR)
C
CALL SETNAME(DIR,SECT,IERR)
IF (IERR.NE.-1) CALL ERROR("S SETNAME",IERR)
100 CONTINUE
C
C NOW GET THE TITLE FROM THE TITLE ARRAY READ IN.
C
IPNT=4*ITPNT(INFO)-3
IF (INDENT(INFO).EQ.0) IPNT=5
TITLE(1)=TTL(IPNT)
TITLE(2)=TTL(IPNT+1)
TITLE(3)=TTL(IPNT+2)
TITLE(4)=TTL(IPNT+3)
RETURN
END
*
INTEGER FUNCTION MSNUM(ISECT)
** MSNUM(ISECT)
*
* RETURN THE MAJOR SECTION NUMBER OF SECTION
* -ISECT-. MAJOR SECTION NUMBER IS RETURNED IN THE
* STANDARD DOCUMENTOR DISPLAY CODE FORMAT FOR
* SECTION NUMBERS.
*
MSNUM=SHIFT(ISECT,12).AND.7777B
RETURN
END
*
INTEGER FUNCTION ITPNT(INFO)
** ITPNT(INFO)
*
* RETURNS THE TITLE POINTER OF THE SECTION WITH
* ZINFO *INFO*.
*
ITPNT=SHIFT(INFO,-4).AND.377B
RETURN
END
*
INTEGER FUNCTION INDENT(INFO)
** INDENT(INFO)
*
* RETURNS THE INDENT LEVEL OF THE SECTION WITH ZINFO
* *INFO*.
*
INDENT=INFO.AND.17B
RETURN
END
*
* /--- BLOCK DOCFUNC 00 000 80/07/31 20.07
SUBROUTINE SECTDSP(SECT,DSECT,NCHR)
** SECTDSP(SECT,DSECT,NCHR)
*
* ENTRY - SECT IS THE CURRENT SECTION NUMBER IN
* DOCUMENTOR FORMAT (NAMESET NAME FORM).
*
* EXIT - DSECT IS THE SECTION NUMBER IN DISPLAY
* FORMAT. NCHR IS THE NUMBER OF CHARACTERS
* IN THE PACKED SECTION NUMBER.
*
C
INTEGER SECT(3),DSECT(3),TEMP(26)
C
C CONVERT SECT TO R FORMAT DISPLAY CODE.
C
DECODE (26,2000,SECT) (TEMP(I),I=1,26)
2000 FORMAT (26R1)
C
C LOOP THRU, REMOVING 0 CHARACTERS AND PACKING THE
C SECTION NAME.
C
INPTR=0
DO 100 IOPTR=1,26
IF (TEMP(IOPTR).EQ.0) GOTO 100
INPTR=INPTR+1
TEMP(INPTR)=TEMP(IOPTR)
100 CONTINUE
C
INPTR = INPTR + 1
DO 200 IOPTR = INPTR,26
200 TEMP(IOPTR) = 0
C
C REPACK THE NEW SECTION NUMBER AND RETURN.
C
NCHR=INPTR-1
ENCODE (26,2000,DSECT) (TEMP(I),I=1,26)
C
C ZERO THE BOTTOM 4 CHARACTERS OF DSECT.
C
DSECT(3) = DSECT(3) .AND. MASK(36)
RETURN
END
*
LOGICAL FUNCTION SECTBIT(INDEX)
** SECTBIT(INDEX)
*
* RETURNS THE VALUE OF SELECTION BIT -INDEX- (ON
* OR OFF).
*
*
C
*CALL,DOCPRTC
C
IWORD=(INDEX+59)/60
IBIT =MOD(INDEX-1,60)+1
SECTBIT = (SHIFT(SECBITS(IWORD),IBIT).AND.1) .EQ. 1
RETURN
END
* /--- BLOCK PR LINES 00 000 80/08/27 16.20
SUBROUTINE PINIT
** PINIT
*
* INITIALIZE PRINT PARAMETERS.
*
*
C
C COMMON FOR PRINT PARAMETERS.
C
*CALL,DOCPRTC
C
C INITIALIZE STUFF.
C LINNO SET LARGE TO SIMULATE END OF PAGE.
C
LENTTL=0
ISPACE=1
IPGNO=0
LINNO=1000
C
DO 100 I=1,15
PTITLE(I)=0
100 CONTINUE
RETURN
C
END
*
SUBROUTINE NEWPAGE
** NEWPAGE
*
* ADVANCE TO A NEW PAGE.
*
*
*
*CALL,DOCPRTC
C
LINNO=1000
RETURN
END
*
SUBROUTINE PRLINE(LINE,LLEN)
** PRLINE(LINE,LEN)
*
* PRINT A LINE OF THE MODULE. KEEPS TRACK OF
* POSITION ON THE PAGE AND CURRENT SPACING BETWEEN
* LINES.
*
C
C COMMON FOR PRINT PARAMETERS.
C
*CALL,DOCPRTC
C
INTEGER LINE(LLEN)
C
C CHECK FOR END OF PAGE.
C IF AT END OF PAGE, PRINT THE TITLE + NEW PAGE ^$.
C
IF (LINNO.LE.56) GOTO 100
C
PRINT 2000
IF (IPGNO.EQ.0) GOTO 50
PRINT 2001,IPGNO
IPGNO=IPGNO+1
50 CONTINUE
LINNO=0
IF (LENTTL.NE.0)
1 PRINT 2002,LENTTL,(PTITLE(I),I=1,LENTTL)
PRINT 2003
2000 FORMAT (1H1)
2001 FORMAT (50X,"PAGE ",I4)
2002 FORMAT (19X,=(A10)//)
2003 FORMAT (//)
100 CONTINUE
C
C PRINT THE LINE
C
ISP=1
200 CONTINUE
IF (ISP.GE.ISPACE) GOTO 300
PRINT 2004
2004 FORMAT (1X)
ISP=ISP+1
GOTO 200
300 CONTINUE
C
C CLEAN THE LINE TO AVOID TRAILING COLONS FROM NOS.
C
CALL CLEAN(LINE,LLEN)
C
PRINT 2005,LLEN,(LINE(I),I=1,LLEN)
2005 FORMAT (9X,=(A10))
C
LINNO=LINNO+ISPACE
C
RETURN
END
*
SUBROUTINE BLANKLN(NUMCR)
** BLANKLN(NUMCR)
*
* PRINT *NUMCR* BLANK LINES.
*
DO 100 I=1,NUMCR
CALL PRLINE(" ",1)
100 CONTINUE
RETURN
END
*
* /--- BLOCK UTIL 00 000 80/07/29 15.01
SUBROUTINE CLEAN(ISTR,LEN)
** CLEAN(ISTR,LEN)
*
* CONVERTS ZERO CODES (00B) TO SPACES WITHIN A
* CHARACTER STRING.
*
INTEGER ISTR(LEN)
C
C LOOP THRU EACH WORD IN THE STRING.
C
DO 200 I=1,LEN
IWORD=ISTR(I)
C
C LOOP THRU EACH CHARACTER. IF THE CHARACTER IS A
C ZERO CODE, REPLACE IT WITH A SPACE.
C
DO 100 J=1,10
IF ((IWORD.AND.77B).EQ.0) IWORD=IWORD.OR.1R
IWORD=SHIFT(IWORD,6)
100 CONTINUE
C
ISTR(I)=IWORD
200 CONTINUE
C
RETURN
END
INTEGER FUNCTION CNTCHR(ICHR,ISTR,LEN)
** CNTCHR(ICHR,ISTR,LEN)
*
* COUNT THE NUMBER OF OCCURRENCES OF CHARACTER ICHR
* IN THE STRING ISTR.
*
INTEGER ISTR(LEN)
C
C LOOP THRU EACH WORD IN THE STRING.
C
CNTCHR = 0
DO 200 I=1,LEN
IWORD=ISTR(I)
C
C LOOP THRU EACH CHARACTER. IF THE CHARACTER IS A
C ZERO CODE, REPLACE IT WITH A SPACE.
C
DO 100 J=1,10
IF ((IWORD.AND.77B).EQ.ICHR) CNTCHR = CNTCHR + 1
IWORD=SHIFT(IWORD,6)
100 CONTINUE
C
200 CONTINUE
C
RETURN
END
* /--- BLOCK CONCAT 00 000 84/03/04 17.27
IDENT CONCAT
ENTRY CONCAT
TITLE CONCAT - CONCATENATE STRING
BASE DECIMAL
*** CONCAT - CONCATENATE STRINGS (FORTRAN CALLABLE)
* S. BIRTH FEBRUARY 1982.
*
* FROM FORTRAN -
*
* CALL CONCAT(OUTSTRING,OUTWORDS,IN1,IN2, ... ,INI)
*
* WHERE *IN1 - INI* IS ANY NUMBER OF STRINGS
* EACH TERMINATED BY AN END OF LINE. OUTSTRING
* SHOULD BE AS LARGE AS THE SUM OF ALL THE INPUT
* STRINGS.
*
* THE NUMBER OF WORDS IN OUTSTRING IS RETURNED,
* INCLUDING AN END OF LINE.
*
* NOTE THAT IT IS LEGAL FOR THE SAME STRING TO
* APPEAR MORE THAN ONCE AS INPUT. IT IS ALSO
* LEGAL FOR THE SAME STRING TO APPEAR AS *OUTSTRING*
* AND AS *IN1,* THE FIRST INPUT STRING. SO THE
* FOLLOWING IS LEGAL -
*
* PERIOD = L"."
* STRING(1) = 3LCAT
* CALL CONCAT(STRING,WORDS,STRING,PERIOD,PERIOD)
*
* IT IS NOT LEGAL, HOWEVER, TO HAVE THE OUTPUT
* STRING APPEAR IN THE LIST OF INPUTS IN ANY OTHER
* POSITION; IT IS NOT POSSIBLE TO CONCATENATE A
* PREFIX ONTO A STRING.
*
*
* REGISTER USE IN THIS ROUTINE IS;
*
* A1 = ADDRESS OF PARAMETER LIST.
* A2 = ADDRESS OF CURRENT PARAMETER IN PARM LIST.
* A3 = ADDRESS OF CURRENT INPUT WORD.
* A6 = ADDRESS TO WRITE INTO (WORK REGISTER).
*
* X0 = 7777B (END OF LINE MASK)
* X1 = ADDRESS OF OUTPUT STRING (START OF IT).
* X2 = ADDRESS OF START OF CURRENT PARM STRING.
* X3 = CURRENT WORD OF PARM STRING.
* X4 = LMASK(6) (CHARACTER MASK).
* X6 = OUTPUT WORD BEING PACKED UP.
* X7 = WORK REGISTER (ESCAPE CHARACTER CHECK).
*
* B1 = 1
* B3 = CHARACTERS REMAINING IN X3
* B4 = CURRENT COLUMN
* B5 = MISC CONSTANTS (10, 30)
* B6 = CHARACTERS IN OUTPUT (X6)
* B7 = WORDS WRITTEN TO OUTPUT STRING.
*
MAXWORDS = 30 MAXIMUM OUTPUT STRING WORDS
CPW = 10 CHARACTERS PER WORD
* /--- BLOCK CONCAT 00 000 84/03/04 17.27
TRACEW SET *
VFD 42/0HCONCAT,18/CONCAT
CONCAT CON 0
SB1 1 CONSTANTS
SX0 7777B EOL MASK
MX4 6 CHARACTER MASK
SB2 B0 EXTRA SPACES NEEDED
* INITIALIZATION
* A1/X1 = FWA OF PARAM LIST
SA2 A1+1 A2/X2 = CURRENT WORD IN LIST
SB4 B0 B4 = COLUMN COUNT
MX6 0 X6 = OUTPUT REGISTER
SB6 B0 B6 = CHARS IN X6
SB7 B0 B7 = WORDS WRITTEN TO OUTSTRING
* LOOP ON INPUT STRINGS
CON2 SA2 A2+B1 GET NEXT PARAMETER
ZR X2,CON10 IF END OF LIST
SA3 X2 A3/X3 = CURRENT INPUT WORD
BX5 -X0*X3 CHECK FOR TAB FUNCTION
ZR X5,CON3 BRANCH IF TAB FUNCTION
SB3 CPW B3 = CHARACTERS IN X3
SB2 B0 B2 = 0 SPACES
EQ CON5
* TAB FUNCTION, SET VARS TO ADD SPACES.
CON3 SB3 0 B3 = CHARS IN X3 = 0
SB2 X3 B2 = TAB STOP TO REACH.
SX3 0 NEEDED TO TERMINATE LOOP OK.
SB2 B2-B4 B2 = CHARS TO GO FOR COLUMN.
LE B2,B0,CON2 SKIP IF ALREADY THERE.
* LOOP ON INPUT CHARACTERS TRANSFERRED
CON4 SX5 55B
LX5 54 CREATE LEFT JUSTIFIED SPACE.
SB2 B2-B1 DECREMENT SPACE COUNT.
EQ CON5A GO STORE IT AWAY.
CON5 BX5 X3*X4 NEXT CHARACTER
SB3 B3-B1
LX3 6
ZR X5,CON8 IF ZERO CHARACTER
* /--- BLOCK CONCAT 00 000 84/03/04 17.27
* WRITE CHAR TO OUTPUT REGISTER
CON5A BX6 X5+X6 WRITE ONE CHAR TO X6
SB6 B6+B1
SB4 B4+B1
LX6 6
SB5 CPW
LT B6,B5,CON6 IF X6 NOT FULL
SA6 X1+B7 WRITE WORD TO OUTSTRING
SB7 B7+B1
SB6 B0
MX6 0
SB5 MAXWORDS
GT B7,B5,CONERR2 IF OUTSTRING TOO LONG
* CHECK FOR ESCAPE CHARACTER (76B OR 70B)
CON6 LX5 6 CHAR IN BITS 5 - 0
SX7 70B CHECK SHIFT CODE
IX7 X5-X7
ZR X7,CON7
SX7 76B CHECK ACCESS CODE
IX7 X5-X7
NZ X7,CON8 IF NORMAL CHAR
CON7 SB4 B4-B1 ADJUST COUNT
* FIND NEXT INPUT CHARACTER
CON8 GT B2,B0,CON4 IF MORE SPACES TO GET.
GT B3,B0,CON5 IF X3 NOT EMPTY
BX5 X3*X0
ZR X5,CON2 IF EOL ENCOUNTERED
SA3 A3+B1 GET NEXT WORD
SB3 CPW
EQ CON5
* WRITE X6 TO OUTSTRING AND PUT EOL
CON10 SB5 CPW
SX5 B5-B6 LEFT JUSTIFY X6
SX7 6
IX5 X5*X7 SHIFT COUNT
SB5 X5
LX6 X6,B5 FIRST CHAR ON LEFT.
SA6 X1+B7
SB7 B7+B1
BX5 X6*X0
ZR X5,CON12 IF EOL ALREADY EXISTS
MX6 0
SA6 X1+B7 WRITE ZERO WORD
SB7 B7+B1
CON12 SX6 B7 RETURN OUTSTRING WORDCOUNT
SA2 A1+B1 IN 2ND PARAMETER
SA6 X2
EQ CONCAT RETURN
CONERR2 EQ CONCAT
END