PROGRAM WORADR C C Routine to read a WORD-11 document that contains a list of C address and produce a multicolumn text file of those address. C The address file must be in WORD-11 text form (normal document C with black lines terminating each address block). If in C WORD-11 list format (each address block terminated with a <>) then C you must use the LIST processing feature of WORD-11 to generate C a document in the above text form (easy to do!). C The WORD-11 Transfer C utility can be used to convert the output from this program C (file WORADDRES.TXT) to a new WORD-11 document. The user can C specify the number of address across the page, and the number C of lines to allocate for each address. This allows one to set up C a sheet of labels for printing. Up to 20 rows per address can be C accomodated, and up to 132 characters per row are output. C C FORTRAN/F77 WORADDRES/LIST C WORADDRES=WORADDRES C LB:[1,24]CHSLIB/LB C / C UNITS=3 C ASG=TI:3 C ACTFIL=3 C MAXBUF=512 C SUPLIB=FCSFSL:SV C // C C Modifications: C C 30-SEP-83 Brad L. Tinney C Doesn't handle a word-wrapped line correctly, should act C like a carriage return. Also, doesnt insert the correct C number of tabs to bring a later column across other null C fields. C IMPLICIT INTEGER (A-Z) C PARAMETER (NROWS=20) C BYTE BUF(512) CHARACTER*132 ADDRES(NROWS),STRING,FILNAM*32,TIMES*8 CHARACTER ATIME*8,ADATE*9 CHARACTER DOC*3,TAB LOGICAL EOF,TERM DIMENSION ROWLEN(NROWS),NTABS(NROWS) DATA WORD11,TEXT,CRT/1,2,3/,TAB/"11/ C COMMON /BUFFER/ BUF,VBN,IDX COMMON /ADRES/ ADDRES COMMON /LENGTH/ ROWLEN,NTABS COMMON /LUNS/ WORD11,TEXT,CRT C FILNAM = 'WPS000.WPS' CALL TIMER(0,TIMES) CALL DATE(ADATE) CALL TIME(ATIME) WRITE (CRT,1) ATIME,ADATE 1 FORMAT (/,T5,'WORD-11 Addresses to Multiple column list', $ 5X,A8,2X,A9/) 5 WRITE (CRT,6) 6 FORMAT ('$Enter the Document number to convert (eg. 28) : ') READ (CRT,7,END=99,ERR=5) N,DOC 7 FORMAT (Q,A3) IF (N.LE.0) GO TO 5 IF (N.EQ.1) THEN DOC(3:3) = DOC (1:1) DOC(1:2) = '00' ELSEIF (N.EQ.2) THEN DOC(2:3) = DOC(1:2) DOC(1:1) = '0' ENDIF FILNAM(4:6) = DOC(1:3) OPEN (UNIT=WORD11,FILE=FILNAM,STATUS='OLD',READONLY,ERR=5) 20 WRITE (CRT,21) 21 FORMAT ('$Enter the number of addresses to be placed across', $ ' the page : ') READ (CRT,22,ERR=20,END=99) MAXCOL 22 FORMAT (I5) 25 WRITE (CRT,26) 26 FORMAT ('$Enter the number of lines to allocate for each', $ ' address : ') READ (CRT,22,ERR=25,END=99) MAXROW OPEN (UNIT=TEXT,FILE='WORADDRES.TXT',STATUS='NEW', $ CARRIAGECONTROL='LIST') C C Now that the file is open, get the document name and verify C that it is the correct document. C VBN = 1 CALL GETBUF(EOF) WRITE (CRT,9) DOC,(BUF(I),I=74,124),MAXCOL,MAXROW 9 FORMAT (/,5X,A3,' - ',51A1,/, $ 5X,I3,' - Address blocks across the page',/, $ 5X,I3,' - Lines per address block',//, $ '$OK (Y/N) ? ') READ (CRT,10,ERR=15,END=99) ANS 10 FORMAT (A1) IF (ANS.NE.'Y'.AND.ANS.NE.'y') THEN 15 CLOSE (UNIT=WORD11) CLOSE (UNIT=TEXT,DISPOSE='DELETE') GO TO 5 ENDIF IDX = 513 ! Init conditions VBN = 3 C C Set up for a new set of address C 40 ROW = 1 COL = 1 DO 45 I=1,MAXROW NTABS(I) = 1 45 ROWLEN(I) = 0 C C Get the next address C 50 CALL GETSTR(STRING,LEN,TERM,EOF) IF (TERM) THEN 51 ROW = 1 COL = COL+1 IF (COL.GT.MAXCOL) THEN C C Write out the existing arrays C 55 DO 60 I=1,MAXROW IF (ROWLEN(I).EQ.0) THEN WRITE (TEXT,56) 56 FORMAT () ELSE WRITE (TEXT,57) ADDRES(I) 57 FORMAT (A) ENDIF 60 CONTINUE IF (EOF) GO TO 99 GO TO 40 ELSE GO TO 50 ENDIF ENDIF IF (EOF) GO TO 55 C C Not the end of anything, add to the existing block C IF (COL.NE.1) THEN 61 NTABS(ROW) = NTABS(ROW)+1 ONE = 1 CALL ADDSTR(TAB,ONE,ROW) IF (NTABS(ROW).LT.COL) GO TO 61 ENDIF CALL ADDSTR(STRING,LEN,ROW) ROW = ROW+1 C C Check if more than the allowed number of rows. If so, skip the C rest of the address. C IF (ROW.GT.MAXROW) THEN 65 CALL GETSTR(STRING,LEN,TERM,EOF) IF (.NOT.EOF.AND..NOT.TERM) GO TO 65 GO TO 51 ELSE GO TO 50 ENDIF C C That should do it! C 99 CALL TIMER(1,TIMES) CALL TSKLOG(CRT,'WORADRES',TIMES,0) END SUBROUTINE GETSTR(STRING,LEN,TERM,EOF) C C Routine to get the next line from the document. C TERM = .TRUE. iff address terminator found C EOF = .TRUE. iff end of file read C IMPLICIT INTEGER (A-Z) BYTE BUF(512),BSTRNG(132),TAB BYTE C,WTAB,BOLD,UNDER,OVER,SUPER,SUB,RET,CEN,HYP,PM,NP,PCB,PCE BYTE FTNB,FNTE,FIGB,FIGE,SFK,EOD,RULB,RULE,SPACE CHARACTER*132 STRING LOGICAL TERM,EOF,RULER,PRNTR,FIGURE,FOOTNT C DATA RULER/.TRUE./,PRNTR,FOOTNT,FIGURE/3*.FALSE./ DATA TAB/"11/,SPACE/' '/ DATA WTAB,BOLD,UNDER,OVER,SUPER/"232,"226,"230,"260,"234/ DATA SUB,RET,CEN,HYP,PM,NP/"236,"222,"224,"264,"202,"204/ DATA PCB,PCE,FTNB,FNTE,FIGB,FIGE/"206,"210,"216,"220,"216,"220/ DATA SFK,EOD,RULB,RULE/"300,"244,"242,"376/ C COMMON /BUFFER/ BUF,VBN,IDX C BIDX = 1 EOF = .FALSE. TERM = .FALSE. 5 IF (IDX.GT.512) THEN CALL GETBUF(EOF) IF (EOF) RETURN ENDIF IF (RULER) THEN CALL SKIP(RULE,EOF) IF (EOF) RETURN IDX = IDX+1 RULER = .FALSE. IF (IDX.GT.512) GO TO 5 ELSEIF (PRNTR) THEN CALL SKIP(PCE,EOF) PRNTR = .FALSE. ELSEIF (FOOTNT) THEN CALL SKIP(FTNE,EOF) FOOTNT = .FALSE. ELSEIF (FIGURE) THEN CALL SKIP(FIGE,EOF) FIGURE = .FALSE. ENDIF IF (EOF) RETURN C C Now that we are out of the blocks look for a character C C = BUF(IDX) IF (C.EQ.WTAB) THEN BSTRNG(BIDX) = TAB ! A Word-11 tab to an ASCII tab BIDX = BIDX+1 ELSEIF (C.EQ.RET.OR.C.EQ.CEN) THEN LEN = BIDX-1 ! A carriage return or centre! IF (LEN.LE.0) THEN TERM = .TRUE. ELSE DECODE (LEN,21,BSTRNG) STRING 21 FORMAT (A) ENDIF IDX = IDX+1 RETURN ELSEIF (C.EQ.EOD) THEN EOF = .TRUE. ! End of data marker RETURN ELSEIF (C.GE.SPACE) THEN BSTRNG(BIDX) = BUF(IDX) ! Got a real character! BIDX = BIDX+1 ELSE PRNTR = C.EQ.PCB ! Start a printer control block? FOOTNT = C.EQ.FTNB ! Start a footnote block? FIGURE = C.EQ.FIGB ! Start a figure??????? RULER = C.EQ.RULB ! Start a ruler? ENDIF C C Bump pointer and continue C IDX = IDX+1 GO TO 5 END SUBROUTINE GETBUF(EOF) C C Get a 512 byte buffer into (BUF) from WORD11 C IMPLICIT INTEGER (A-Z) BYTE BUF(512) LOGICAL EOF DIMENSION ISB(2),DPB(6) C COMMON /BUFFER/ BUF,VBN,IDX COMMON /LUNS/ WORD11,TEXT,CRT C CALL GETADR(DPB,BUF) DPB(2) = 512 DPB(4) = 0 DPB(5) = VBN CALL WTQIO("10400,WORD11,1,,ISB,DPB) EOF = ISB(1).NE.1 VBN = VBN+1 IDX = 1 RETURN END SUBROUTINE SKIP(CODE,EOF) C C Search for end of block terminated by CODE C Update IDX to point to next location past CODE C IMPLICIT INTEGER (A-Z) BYTE BUF(512),CODE LOGICAL EOF C COMMON /BUFFER/ BUF,VBN,IDX C 35 DO 40 I=IDX,512 IF (BUF(I).EQ.CODE) GO TO 45 40 CONTINUE CALL GETBUF(EOF) IF (EOF) RETURN GO TO 35 45 IDX = I+1 IF (IDX.GT.512) CALL GETBUF(EOF) RETURN END SUBROUTINE ADDSTR(STRING,LEN,ROW) C C Routine to add a string to the specified row of ADDRES. C IMPLICIT INTEGER (A-Z) C PARAMETER (NROWS=20) C CHARACTER*132 ADDRES(NROWS),STRING DIMENSION ROWLEN(NROWS),NTABS(NROWS) C COMMON /ADRES/ ADDRES COMMON /LENGTH/ ROWLEN,NTABS C START = ROWLEN(ROW)+1 END = ROWLEN(ROW)+LEN ADDRES(ROW)(START:END) = STRING(1:LEN) ROWLEN(ROW) = END RETURN END