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