C C PROGRAM 'TIDYTEXT' C ================ C C BY JOHN W. CAMPBELL C C THIS PROGRAM IS USED TO FORMAT A TEXT FILE FOLLOWING CERTAIN C CONVENTIONS. THE OUTPUT MAY BE TO ANOTHER FILE AND/OR A PRINTER. IN C THE LATTER CASE A PAGED OUTPUT WILL BE PRODUCED. THIS VERSION INCLUDES C AN OPTION FOR THE HANDLING OF VAX STYLE HELP FILES C C FORTRAN 77 VERSION C C SPECIFICATION STATEMENTS C ------------------------ C LOGICAL IFSING,IFIRST,WF,PR,LI,OV,DS,BO,HP,PS DIMENSION LINMIN(5) CHARACTER*500 LINBUF CHARACTER*150 MARG,ITEXT,KTEXT,JTEXT,UTEXT,BTEXT COMMON /PAGE/MINCOL,MAXCOL,MINLIN,MAXLIN,NLINES,LREC1,LREC2, *ICUT1,ICUT2,NBLANK,ILINE,IPAGE,NCOL COMMON /TIDY/WF,PR,LI,OV,DS,BO,HP,PS CHARACTER*1 TABLE,CH0,BOLDCH,ULCH COMMON /TRANS/CH0,BOLDCH,ULCH,TABLE(256) COMMON /TRANS1/MAXTAB LOGICAL LBLANK,KEY COMMON /KEYL/LBLANK,KEY COMMON /UNITS/INDATA,IFLIN,IFLOUT,MSG,IPRINT,ILIST COMMON /LIMS/LBMAX,MXTEXT,MXT,MARGW COMMON /SECNO/ISECT(9) COMMON /PSDAT/XORIG,YORIG,XP,YP,HT,NPAGES C C INITIALISATIONS C --------------- C LBMAX=500 MXTEXT=150 MARGW=1 MARG=' ' INDATA=5 IFLIN=1 IFLOUT=2 IPRINT=7 ILIST=6 MSG=ILIST KEY=.FALSE. LBLANK=.TRUE. XORIG=15.0 YORIG=770.0 HT=12.0 XP=XORIG YP=YORIG NPAGES = 0 IFAIL=0 CALL CCPOPN(-INDATA,'DATA',5,1,LDUM,IFAIL) CALL CCPOPN(-ILIST,'TERMOUT',1,1,LDUM,IFAIL) CH0=CHAR(0) CALL GETOPT(ITEXT) IF(MINCOL.GT.1)MARGW=MINCOL-1 MXT=LREC1 IF(LREC1.LE.0)MXT=MXTEXT IF1=1 IF(LREC1.EQ.0)IF1=2 IF2=1 IF(LREC2.EQ.0)IF2=2 CALL CCPOPN(-IFLIN,'TEXTIN',5,IF1,LDUM,IFAIL) IF(HP)THEN CALL GETREC(ITEXT(1:MXT),IMAX,ILMIN,IRTYPE) IF(ITEXT(1:9).NE.'!TIDYTEXT')THEN WRITE(MSG,2001) call ccperr(1,' stop 2001') ENDIF REWIND IFLIN ENDIF IF(WF)CALL CCPOPN(-IFLOUT,'TEXTOUT',4,IF2,LDUM,IFAIL) ILINE=NLINES IF(ILINE.EQ.0)ILINE=100000 C C START OF NEW INPUT PARAGRAPH C --------------------------- C 10 IFSING=.TRUE. IFIRST=.TRUE. LMAX=0 NLIN=0 C C READ IN THE FIRST RECORD FOR THE PARAGRAPH C CALL GETREC(ITEXT(1:MXT),IMAX,ILMIN,IRTYPE) C C BRANCH FOR SPECIAL TYPE OF RECORD IF PRESENT C IF(IRTYPE.GT.0)GO TO(200,300,400,500,600),IRTYPE C C ADD CONTENTS OF RECORD TO THE LINE BUFFER C CALL ADDBUF(LINBUF,LMAX,ITEXT(1:MXT),IMAX,ILMIN,LINMIN,NLIN) C C READ ANOTHER RECORD FOR THE PARAGRAPH C 50 CALL GETREC(ITEXT(1:MXT),IMAX,ILMIN,IRTYPE) IF(IRTYPE.GT.0)GO TO 150 IFSING=.FALSE. IF(IFIRST)CALL LEADER(LINBUF,LMAX,LINMIN(1),ILMIN) IFIRST=.FALSE. CALL ADDBUF(LINBUF,LMAX,ITEXT(1:MXT),IMAX,ILMIN,LINMIN,NLIN) CALL CMPRSS(LINBUF,LMAX) C C SEE IF THERE IS SUFFICIENT TEXT IN LINBUF FOR PRINTING C 100 IOFF=LINMIN(1)-1 IWIDTH=NCOL-IOFF IF(LMAX.LT.IWIDTH)GO TO 50 C C OUTPUT A LINE FROM LINBUF C CALL PRTLIN(LINBUF,LMAX,KTEXT(1:NCOL),JTEXT,UTEXT,BTEXT,MARG, *LINMIN,NLIN,IFSING) GO TO 100 C C END OF PARAGRAPH, OUTPUT THE REMAINING CONTENTS OF LINBUF C 150 IF(LMAX.GT.0)CALL PRTLIN(LINBUF,LMAX,KTEXT(1:NCOL),JTEXT,UTEXT, *BTEXT,MARG,LINMIN,NLIN,IFSING) IF(LMAX.GT.0)GO TO 150 C C BRANCH ON SPECIAL RECORD TYPE C GO TO(200,300,400,500,600),IRTYPE C C NEW PAGE CODE '@' FOUND C ----------------------- C 200 CALL WREC(ITEXT(1:2),IMAX,JTEXT(1:NCOL),UTEXT(1:NCOL), *BTEXT(1:NCOL),MARG(1:MARGW),IFSING) GO TO 10 C C TABLE FOUND (DELIMITED BY RECORDS STARTING WITH '.') C 300 CALL TABLIN(LINBUF,LMAX,ITEXT,IMAX,JTEXT,UTEXT,BTEXT,MARG) 310 CALL GETREC(ITEXT(1:MXT),IMAX,ILMIN,IRTYPE) CALL TABLIN(LINBUF,LMAX,ITEXT,IMAX,JTEXT,UTEXT,BTEXT,MARG) IF(IRTYPE.EQ.2)GO TO 10 IF(IRTYPE.EQ.4)GO TO 500 GO TO 310 C C BLANK RECORD FOUND C ------------------ C 400 CALL WREC(ITEXT(1:1),IMAX,JTEXT(1:NCOL),UTEXT(1:NCOL), *BTEXT(1:NCOL),MARG(1:MARGW),IFSING) GO TO 10 C C END OF FILE REACHED C ------------------- C 500 IF(.NOT.PR.AND..NOT.LI)call ccperr(1,' stop 500') NBLANK=NBLANK+1 IF(NBLANK.LE.0)call ccperr(1,' stop nblank') IF(PR.AND.PS) THEN CALL PSREDO ELSE IPAGE=-1 DO 510 N=1,NBLANK CALL NEWPAG(ITEXT(1:NCOL),MARG(1:MARGW)) 510 CONTINUE END IF call ccperr(0,' Normal Termination') C C KEYNAME/COMMENT LINE (HELP OPTION ONLY) C --------------------------------------- C 600 CALL WREC(ITEXT(1:IMAX),IMAX,JTEXT(1:NCOL),UTEXT(1:NCOL), *BTEXT(1:NCOL),MARG(1:MARGW),IFSING) IFSING=.TRUE. GO TO 10 C C FORMAT STATEMENTS C ----------------- C 2001 FORMAT(/,' **HELP FILE DOES NOT START WITH TIDYTEXT FLAG**') END C C SUBROUTINE 'GETOPT' C =================== C C READ IN THE REQUIRED OPTIONS AND SET FLAGS AND PAGING DETAILS C SUBROUTINE GETOPT(ITEXT) C C PARAMETERS C C ITEXT (I/O) BUFFER FOR READING IN CONTROL DATA C C COMMON /TIDY/ FLAGS WORD 1 WF WRITE OUTPUT FILE C WORD 2 PR PRINTER OUTPUT (PAGED) C WORD 3 LI MONITOR LISTING ON TERMINAL. C WORD 4 OV OVERPRINTING AVAILABLE FOR C PRINTER OUTPUT. IF SET, THEN C UNDERLINING AND, IF REQUESTED, C BOLD PRINTING WILL BE DONE ON C THE PRINTER OUTPUT. C WORD 5 DS DOUBLE SPACE THE PRINTER O/P C WORD 6 BO BOLD PRINTING ON PRINTER C OUTPUT. (OVERPRINTING C REQUIRED, CHARACTER USED C TO INDICATE BOLD PRINT HELD C IN BOLDCH) C WORD 7 HP VAX TYPE HELP FILE C WORD 8 PS POSTSCRIPT O/P FILE (MUST ALSO GIVE C 'PR' OPTION) C C COMMON /PAGE/ WORD 1 MINCOL FIRST COLUMN FOR PRINTER OUTPUT C WORD 2 MAXCOL FINAL COLUMN FOR PRINTER OUTPUT C WORD 3 MINLIN FIRST LINE FOR PRINTER OUTPUT (>1) C WORD 4 MAXLIN FINAL LINE FOR PRINTER OUTPUT C WORD 5 NLINES NO. OF LINES IN A PAGE (SET TO 0 C IF PRINTER HAS HARDWARE FORM FEED C OR IF POSTSCRIPT OPTION USED C WORD 6 LREC1 LENGTH OF INPUT FILE RECORDS (=0 C FOR VARIABLE LENGTH BINARY RECORDS) C WORD 7 LREC2 LENGTH OF OUTPUT FILE RECORDS (=0 C FOR VARIABLE LENGTH BINARY RECORDS) C WORD 8 ICUT1 COLUMN NO. OF FIRST CUTTING LINE (0 C IF NO CUTTING LINES REQUIRED) C WORD 9 ICUT2 COLUMN NO. OF SECOND CUTTING LINE C WORD 10 NBLANK NO. OF EXTRA BLANK PAGES REQUIRED AT C THE END OF THE PRINTER OUTPUT C (PERFORMS NBLANK+1 NEW PAGE CALLS. SET C TO -1 IF NO NEW PAGE CALL REQUIRED AT C THE END) C WORD 11 ILINE LINE COUNTER FOR CURRENT PAGE C WORD 12 IPAGE PAGE NUMBER COUNTER C WORD 13 NCOL MAX NO. OF COLS TO BE OUTPUT C (=MAXCOL-MINCOL+1) C C C SPECIFICATION STATEMENTS C ------------------------ C LOGICAL IFLAG(8) DIMENSION NTRANS(2,256) CHARACTER*1 ITABL(2,8) COMMON /TIDY/IFLAG COMMON /PAGE/IWORD(10),ILINE,IPAGE,NCOL CHARACTER*72 ITEXT CHARACTER*1 IDOT,ISP CHARACTER*1 TABLE,CH0,BOLDCH,ULCH COMMON /TRANS/CH0,BOLDCH,ULCH,TABLE(256) COMMON /TRANS1/MAXTAB COMMON /UNITS/INDATA,IFLIN,IFLOUT,MSG,IPRINT,ILIST COMMON /LIMS/LBMAX,MXTEXT,MXT,MARGW COMMON /SECNO/ISECT(9) DATA ITABL/'W','F','P','R','L','I','O','V','D','S','B','O', *'H','P','P','S'/ DATA IDOT/'.'/,ISP/' '/ C C SET DEFAULTS C ------------ C NCH=0 MINCOL=6 MAXCOL=80 MINLIN=4 MAXLIN=60 NLINES=0 LREC1=80 LREC2=80 ICUT1=0 ICUT2=0 NBLANK=1 IPAGE=0 MAXTAB=0 ULCH='_' DO 2 I=1,9 ISECT(I)=0 2 CONTINUE ISECT(1)=-1 C C READ IN PAGING DETAILS C ---------------------- C READ(INDATA,1001,END=500)ITEXT DO 5 I=1,10 IWORD(I)=0 CALL GTFLD(I,ITEXT,72,MIN,MAX,0,*5) CALL DECNUM(ITEXT,MIN,MAX,1,X,IERR) IF(IERR.EQ.1)GO TO 800 IWORD(I)=NINT(X) 5 CONTINUE I=11 CALL GTFLD(11,ITEXT,72,MIN,MAX,0,*6) CALL DECNUM(ITEXT,MIN,MAX,1,X,IERR) IF(IERR.EQ.1)GO TO 800 IPAGE=NINT(X) 6 CONTINUE I=12 CALL GTFLD(12,ITEXT,72,MIN,MAX,0,*7) CALL DECNUM(ITEXT,MIN,MAX,1,X,IERR) IF(IERR.EQ.1)GO TO 800 ISECT(1)=NINT(X) 7 CONTINUE C C READ IN FLAG CODES C DO 10 I=1,8 IFLAG(I)=.FALSE. 10 CONTINUE 15 READ(INDATA,1001,END=500)ITEXT IFIELD=0 20 IFIELD=IFIELD+1 CALL GTFLD(IFIELD,ITEXT,72,MIN,MAX,0,*50) DO 30 I=1,8 IF(ITEXT(MIN:MIN).EQ.ITABL(1,I).AND.ITEXT(MIN+1:MIN+1).EQ. *ITABL(2,I))GO TO 40 30 CONTINUE IF(ITEXT(MIN:MIN).EQ.'U'.AND.ITEXT(MIN+1:MIN+1).EQ.'L')THEN ULCH=ITEXT(MIN+2:MIN+2) GO TO 20 ENDIF WRITE(MSG,2001)(ITEXT(M:M),M=MIN,MAX) GO TO 20 40 IFLAG(I)=.TRUE. IF(I.EQ.6)THEN BOLDCH=ITEXT(MIN+2:MIN+2) IF(BOLDCH.EQ.' ')BOLDCH='~' ENDIF GO TO 20 50 IF(IFIELD.GT.1)GO TO 15 NCOL=IWORD(2)-IWORD(1)+1 IF(IWORD(2).GT.MXTEXT)GO TO 810 IF(IWORD(6).GT.MXTEXT.OR.IWORD(7).GT.MXTEXT)GO TO 820 IF(NCOL.LT.25)GO TO 830 IF(IWORD(3).LE.1)GO TO 840 IF(IWORD(1).LT.1)GO TO 850 IF(IWORD(5).GT.0.AND.IWORD(4).GT.IWORD(5))GO TO 860 IF(IFLAG(1).AND.IWORD(7).GT.0.AND.NCOL.GT.IWORD(7))GO TO 870 IF(IFLAG(8))IWORD(5)=0 C C READ IN CHARACTER TRANSLATION TABLE C 200 READ(5,1001,END=500)ITEXT IFIELD=1 CALL GTFLD(1,ITEXT,72,MIN,MAX,0,*210) CALL DECNUM(ITEXT,MIN,MAX,1,X,IERR) IF(IERR.EQ.1)GO TO 800 NCH=NINT(X) 210 NN=2*NCH CALL RDNVAL(NN,NTRANS,ITEXT,MAXTAB) IF(MAXTAB.EQ.0)GO TO 500 DO 280 I=1,MAXTAB+1 ICH=I-1 DO 260 N=1,NCH IF(NTRANS(1,N).EQ.ICH)ICH=NTRANS(2,N) 260 CONTINUE 270 TABLE(I)=CHAR(ICH) 280 CONTINUE C C OUTPUT PRINTER OUTPUT CUTTING LINES IF REQUIRED C 500 IFAIL=0 IF(.NOT.IFLAG(2))RETURN CALL CCPOPN(-IPRINT,'PROUT',1,1,LDUM,IFAIL) IF(IFLAG(8))RETURN IF(IWORD(8).LE.0)RETURN N1=IWORD(8)-1 N2=IWORD(9)-IWORD(8)-1 IF(N2.LT.1)RETURN MAXLIN=IWORD(4) DO 520 M=1,MAXLIN IF(N1.GT.0)WRITE(MSG,1002)(ISP,I=1,N1),IDOT,(ISP,J=1,N2),IDOT IF(N1.EQ.0)WRITE(IPRINT,1002)IDOT,(ISP,J=1,N2),IDOT 520 CONTINUE IF(IWORD(5).EQ.0)RETURN NMAX=IWORD(5)-IWORD(4) IF(NMAX.LE.0)RETURN DO 530 N=1,NMAX WRITE(IPRINT,1002) 530 CONTINUE RETURN C C ERROR CONDTIONS C --------------- C 800 WRITE(MSG,2002)I call ccperr(1,' STOP 800') 810 WRITE(MSG,2003)MXTEXT call ccperr(1,' STOP 8100') 820 WRITE(MSG,2004)MXTEXT call ccperr(1,' STOP 820') 830 WRITE(MSG,2005) call ccperr(1,' STOP 830') 840 WRITE(MSG,2006) call ccperr(1,' STOP 840') 850 WRITE(MSG,2007) call ccperr(1,' STOP 850') 860 WRITE(MSG,2008) call ccperr(1,' STOP 860') 870 WRITE(MSG,2009) call ccperr(1,' STOP 870') C C FORMAT STATEMENTS C ------------------ C 1001 FORMAT(A72) 1002 FORMAT(' ',150A1) C 2001 FORMAT(' **UNKNOWN CODE - IGNORED** ',80A1) 2002 FORMAT(' **SYNTAX ERROR IN FIELD',I3,' **') 2003 FORMAT(' **MAX OF',I4,' COLUMNS ALLOWED**') 2004 FORMAT(' **MAX RECORD LENGTH ALLOWED IS',I4,' **') 2005 FORMAT(' **MIN NO. OF PRINT COLUMNS ALLOWED IS 25**') 2006 FORMAT(' **MIN START LINE ALLOWED IS 2**') 2007 FORMAT(' **MIN START COLUMN ALLOWED IS 1**') 2008 FORMAT(' **PAGE TOO SHORT FOR MAX LINES**') 2009 FORMAT(' **NO. OF COLS. MAY NOT BE GREATER THAN O/P REC LENGTH**') END C C C SUBROUTINE 'GETREC' C =================== C C THIS SUBROUTINE READS A RECORD FROM THE INPUT TEXT FILE AND C DETERMINES WHETHER IT IS OF A SPECIAL RECORD TYPE C C SUBROUTINE GETREC(ITEXT,IMAX,ILMIN,IRTYPE) C C PARAMETERS C C ITEXT (O) CHAR. ARRAY CONTAINING TEXT READ FROM INPUT RECORD C IMAX (O) THE NUMBER OF THE LAST NON-BLANK CHARACTER IN ITEXT C ILMIN (O) POSITION OF THE FIRST NON-BLANK CHARACTER IN ITEXT C IRTYPE (O) RECORD TYPE FLAG =0, A NORMAL LINE C =1, NEW PAGE SYMBOL '@', ' @' OR C '!@' C =2, TABLE SYMBOL '.', ' .' OR '!.' C =3, BLANK LINE C =4, END OF FILE FOUND. C =5, KEYNAME/COMMENT (HELP FILE) C C C SPECIFICATION STATEMENTS C ------------------------ C CHARACTER*(*) ITEXT COMMON /PAGE/MINCOL,MAXCOL,MINLIN,MAXLIN,NLINES,LREC1,LREC2, *ICUT1,ICUT2,NBLANK,ILINE,IPAGE,NCOL COMMON /LIMS/LBMAX,MXTEXT,MXT,MARGW LOGICAL WF,PR,LI,OV,DS,BO,HP,PS COMMON /TIDY/WF,PR,LI,OV,DS,BO,HP,PS C C INITIALISATIONS C --------------- C IRTYPE=0 IMAX=0 ILMIN=0 C C READ IN RECORD AND TEST FOR SPECIAL TYPE C ---------------------------------------- C 5 CALL RREC(ITEXT,IMAX,*350) IF(IMAX.EQ.0)GO TO 340 IF(ITEXT.EQ.'@')GO TO 300 IF(ITEXT.EQ.'.')GO TO 310 IF(HP)THEN IF(ITEXT.EQ.' @')GO TO 300 IF(ITEXT.EQ.' .')GO TO 310 IF(ITEXT(1:2).EQ.'!@')GO TO 300 IF(ITEXT(1:2).EQ.'!.')GO TO 310 IF(ITEXT(1:1).EQ.'!')GO TO 360 IF(INDEX('123456789',ITEXT(1:1)).NE.0)GO TO 360 ENDIF ILMIN=0 10 ILMIN=ILMIN+1 IF(ILMIN.GT.IMAX)RETURN IF(ITEXT(ILMIN:ILMIN).EQ.' ')GO TO 10 RETURN C C NEW PAGE SYMBOL '@' FOUND C ------------------------- C 300 IRTYPE=1 RETURN C C TABLE ON/OFF FLAG FOUND ('.') C ----------------------------- C 310 IRTYPE=2 RETURN C C BLANK RECORD FOUND C ------------------- C 340 IRTYPE=3 RETURN C C END OF FILE REACHED C ------------------- C 350 IRTYPE=4 RETURN C C KEYNAME/COMMENT FOUND (HELP FILE ONLY) C -------------------------------------- C 360 IRTYPE=5 RETURN END C C C SUBROUTINE 'ADDBUF' C =================== C C THIS SUBROUTINE ADDS TEXT FROM THE INPUT RECORD BUFFER TO THE C LINE BUFFER HOLDING PART OF THE CURRENT PARAGRAPH C SUBROUTINE ADDBUF(LINBUF,LMAX,ITEXT,IMAX,ILMIN,LINMIN,NLIN) C C PARAMETERS C C LINBUF (I/O) CHAR. ARRAY HOLDING TEXT FOR THE CURRENT PARAGRAPH C LMAX (I/O) THE POSITION IN LINBUF OF THE LAST NON-BLANK C CHARACTER ADDED C ITEXT (I) CHAR. ARRAY CONTAINING TEXT TO BE ADDED TO LINBUF C IMAX (I) NO. OF THE LAST NON-BLANK CHARACTER IN ITEXT C ILMIN (I) POSITION OF 1ST NON-BLANK CHARACTER IN ITEXT C LINMIN (I/O) ARRAY HOLDING START POSITIONS OF LINES FOR THE C CURRENT PARAGRAPH C NLIN (I/O) NO. OF ENTRIES IN LINMIN C C SPECIFICATION STATEMENTS C ------------------------ C CHARACTER*(*) LINBUF CHARACTER*(*) ITEXT DIMENSION LINMIN(5) C C ADD NEW TEXT TO LINBUF (INSERT LEADING SPACE UNLESS LMAX=0) C ----------------------------------------------------------- C IF(IMAX.EQ.0)RETURN NLIN=NLIN+1 IF(NLIN.GT.5)NLIN=5 LINMIN(NLIN)=ILMIN IF(LMAX.LE.1)GO TO 20 IF(LINBUF(LMAX:LMAX).NE.'-')GO TO 10 IF(LINBUF(LMAX-1:LMAX-1).EQ.' ')GO TO 10 LMAX=LMAX-1 GO TO 20 10 LMAX=LMAX+1 LINBUF(LMAX:LMAX)=' ' 20 I=0 30 I=I+1 IF(ITEXT(I:I).EQ.' ')GO TO 30 LMAX=LMAX+1 LINBUF(LMAX:LMAX)=ITEXT(I:I) IMIN=I+1 IF(IMIN.GT.IMAX)RETURN N=IMAX-IMIN LMAX=LMAX+1 LINBUF(LMAX:LMAX+N)=ITEXT(IMIN:IMAX) LMAX=LMAX+N RETURN END C C SUBROUTINE 'LEADER' C =================== C C THIS SUBROUTINE IS USED TO ENSURE THAT LEADER TEXT AT THE START OF C THE FIRST LINE OF A MULTILINE PARAGRAPH IS NOT COMPRESSED. THIS C IS ACHIEVED BY REPLACING SPACES WITH NULLS (TEMPORARILY) IN THE LEADER C TEXT. C SUBROUTINE LEADER(LINBUF,LMAX,LIN1,LIN2) C C C PARAMETERS C C LINBUF (I/O) CHAR. ARRAY HOLDING TEXT FOR THE CURRENT PARAGRAPH C LMAX (I/O) THE POSITION IN LINBUF OF THE LAST NON-BLANK C CHARACTER ADDED C LIN1 (I) START POSITION OF 1ST LINE OF PARAGRAPH C LIN2 (I) START POSITION OF 2ND LINE OF PARAGRAPH C C SPECIFICATION STATEMENTS C ------------------------- C CHARACTER*(*) LINBUF CHARACTER*1 ISP DIMENSION LINMIN(5) CHARACTER*1 TABLE,CH0,BOLDCH,ULCH COMMON /TRANS/CH0,BOLDCH,ULCH,TABLE(256) DATA ISP/' '/ C C REPLACE SPACES WITH NULLS IN LEADER TEXT C ---------------------------------------- C NLEAD=LIN2-LIN1 IF(NLEAD.LT.1)RETURN IF(NLEAD.GT.LMAX)LMAX=NLEAD DO 100 N=1,NLEAD IF(LINBUF(N:N).EQ.ISP)LINBUF(N:N)=CH0 100 CONTINUE RETURN END C C C SUBROUTINE 'CMPRSS' C =================== C C C THIS SUBROUTINE COMPRESSES THE CONTENTS OF LINBUF BY REMOVING C LEADING SPACES AND ONLY ALLOWING ONE SPACE BETWEEN WORDS C SUBROUTINE CMPRSS(LINBUF,LMAX) C C PARAMETERS C C LINBUF (I/O) CHAR. ARRAY HOLDING TEXT TO BE COMPRESSED C LMAX (I/0) POSITION IN LINBUF OF THE LAST NON-BLANK CHARACTER C C C SPECIFICATION STATEMENTS C ------------------------ C CHARACTER*(*) LINBUF CHARACTER*1 ISP DATA ISP/' '/ C C COMPRESS THE TEXT C ----------------- C KMAX=LMAX I=0 L=0 10 L=L+1 IF(L.GT.LMAX)GO TO 100 IF(LINBUF(L:L).NE.ISP)GO TO 30 GO TO 10 20 L=L+1 IF(L.GT.LMAX)GO TO 100 30 I=I+1 LINBUF(I:I)=LINBUF(L:L) IF(LINBUF(I:I).NE.ISP)GO TO 20 GO TO 10 100 LMAX=I IF(LMAX.GE.KMAX)RETURN KMIN=LMAX+1 LINBUF(KMIN:KMAX)=' ' RETURN END C C C SUBROUTINE 'PRTLIN' C =================== C C THIS SUBROUTINE IS USED TO PRINT A LINE FOR THE CURRENT C PARAGRAPH WITH APPROPRIATE TABBING AND JUSTIFICATION OF THE TEXT C SUBROUTINE PRTLIN(LINBUF,LMAX,KTEXT,JTEXT,UTEXT,BTEXT,MARG, *LINMIN,NLIN,IFSING) C C PARAMETERS C C LINBUF (I/O) ARRAY CONTAINING TEXT TO BE PRINTED, THE REMAINING C TEXT IS RETURNED IN THE BUFFER SHIFTED TO THE LEFT C LMAX (I/O) THE NO. OF THE LAST NON-BLANKK CHARACTER IN LINBUF C KTEXT (I/O) CHARACTER BUFFER FOR OUTPUT LINE C JTEXT (I/O) CHARACTER BUFFER FOR S/R WREC C UTEXT (I/O) CHARACTER BUFFER FOR UNDERLINES FOR S/R WREC C BTEXT (I/O) CHARACTER BUFFER FOR BOLD PRINT FOR S/R WREC C MARG (I/O) CHARACTER VARIABLE HOLDING MARGIN C LINMIN (I/O) ARRAY HOLDING START POSITIONS OF LINES FOR THE C CURRENT PARAGRAPH C NLIN (I/O) NO. OF ENTRIES IN LINMIN C IFSING (I/O) FLAG =.TRUE. SINGLE LINE PARAGRAPH (DO NOT C ADJUST INTERNAL SPACING WITHIN THE C TEXT) - MAY BE RESET TO FALSE IF TEXT C IS TOO LONG FOR THE ALLOWED WIDTH IN C WHICH CASE THE TEXT IS COMPRESSED AND C TREATED AS A MULTILINE PARAGRAPH. C =.FALSE. MULTILINE PARAGRAPH TYPE, LEFT AND C RIGHT JUSIFY THE TEXT WITH INTERNAL C PADDING OF SPACES WHERE REQUIRED.. C IF A CONTINUOUS STRING GREATER THAN C THE ALLOWED FIELD WIDTH IS FOUND THEN C THE WIDTH-1 CHARACTERS FOLLOWED BY A C DASH WILL BE PRINTED. C C C SPECIFICATION STATEMENTS C ------------------------ C LOGICAL IFSING CHARACTER*(*) LINBUF CHARACTER*(*) KTEXT,JTEXT,UTEXT,BTEXT,MARG CHARACTER*1 ISP,IDASH,CHLAST,LC DIMENSION LINMIN(5) COMMON /PAGE/MINCOL,MAXCOL,MINLIN,MAXLIN,NLINES,LREC1,LREC2, *ICUT1,ICUT2,NBLANK,ILINE,IPAGE,NCOL COMMON /UNITS/INDATA,IFLIN,IFLOUT,MSG,IPRINT,ILIST COMMON /LIMS/LBMAX,MXTEXT,MXT,MARGW CHARACTER*1 TABLE,CH0,BOLDCH,ULCH COMMON /TRANS/CH0,BOLDCH,ULCH,TABLE(256) DATA ISP/' '/,IDASH/'-'/ C C INITIALISE THE OUTPUT BUFFER C ----------------------------- C KTEXT=' ' C C CALCULATE THE FIELD WIDTH C ------------------------- C IOFF=LINMIN(1)-1 IF(NLIN.LE.1)GO TO 15 NLIN=NLIN-1 DO 10 N=1,NLIN LINMIN(N)=LINMIN(N+1) 10 CONTINUE 15 IWIDTH=NCOL-IOFF IF(LMAX.GT.IWIDTH)GO TO 20 GO TO 300 C C MULTIPLE LINE PARAGRAPHS C ------------------------ C C CHANGE TYPE OF SINGLE LINE PARAGRAPH IF LENGTH OF THE TEXT IS C GREATER THAN THE FIELD WIDTH C 20 IF(.NOT.IFSING)GO TO 30 IFSING=.FALSE. CALL CMPRSS(LINBUF,LMAX) C C FIND THE RANGE OF LINBUF WHICH MAY BE OUTPUT WITHIN 'IWIDTH' C 30 II=IWIDTH+1 40 IF(LINBUF(II:II).EQ.ISP)GO TO 60 II=II-1 IF(II.GT.0)GO TO 40 C C CONTINUOUS STRING LONGER THAN IWIDTH FOUND C IMAX=IWIDTH-1 KMAX=IWIDTH+IOFF K=IOFF KTEXT(IOFF+1:IOFF+IMAX)=LINBUF(1:IMAX) K=K+IMAX KTEXT(KMAX:KMAX)=IDASH GO TO 200 C C GET THE NO. OF WORDS WITHIN THE CHARACTER RANGE 1 TO II AND THE C POSITION OF THE LAST CHARACTER OF THE LAST WORD WITHIN THE RANGE C 60 NWRD=NWORDS(LINBUF,II,IMAX) C C GET THE NUMBER OF INTER-WORD GAPS AND THE NUMBER OF SPACES C REQUIRED FOR LEFT/RIGHT JUSTIFICATION C IF(NWRD.EQ.1)GO TO 100 NGAP=NWRD-1 NPAD=IWIDTH-IMAX NSP=NPAD/NGAP NEXTR=MOD(NPAD,NGAP) C C TRANSFER TEXT TO OUTPUT BUFFER 'KTEXT' WITH PADDING (REPLACE NULLS) C 100 K=IOFF CHLAST=' ' NW=0 DO 150 I=1,IMAX LC=LINBUF(I:I) IF(LC.EQ.' ')THEN IF(CHLAST.EQ.' ')GO TO 140 K=K+NSP+1 IF(NW.GE.NWRD-NEXTR)K=K+1 ELSE IF(CHLAST.EQ.' ')NW=NW+1 K=K+1 KTEXT(K:K)=LC IF(LC.EQ.CH0)KTEXT(K:K)=' ' ENDIF 140 CHLAST=LC 150 CONTINUE KMAX=IWIDTH+IOFF C C REMOVE IMAX CHARACTERS FROM LINBUF AND SHIFT TEXT TO C ELIMINATE LEADING SPACES C 200 LMIN=IMAX 210 LMIN=LMIN+1 IF(LMIN.GT.LMAX)GO TO 240 IF(LINBUF(LMIN:LMIN).NE.ISP)GO TO 220 GO TO 210 220 NC=LMAX-LMIN+1 LINBUF(1:NC)=LINBUF(LMIN:LMAX) LMAX=NC GO TO 500 240 LMAX=0 GO TO 500 C C SINGLE LINE PARAGRAPHS - OR LAST LINE OF A MULTIPLE LINE PARAGRAPH C ------------------------------------------------------------------ C C FILL OUTPUT BUFFER C 300 K=IOFF KTEXT(K+1:K+LMAX)=LINBUF(1:LMAX) KMAX=LMAX+IOFF LMAX=0 C C REMOVE NULLS IF PRESENT C IF(INDEX(KTEXT(1:KMAX),CH0).EQ.0)GO TO 500 DO 320 K=1,KMAX IF(KTEXT(K:K).EQ.CH0)KTEXT(K:K)=ISP 320 CONTINUE C C OUTPUT THE CURRENT LINE (FOR SINGLE OR MULTIPLE LINE TYPES) C ----------------------------------------------------------- C 500 KM=MAX(1,KMAX) CALL WREC(KTEXT(1:KM),KMAX,JTEXT(1:NCOL),UTEXT(1:NCOL), *BTEXT(1:NCOL),MARG(1:MARGW),IFSING) RETURN END C C SUBROUTINE 'TABLIN' C =================== C C THIS SUBROUTINE IS USED TO OUTPUT A LINE WITHIN A TABLE WITH THE C INSERTION OR REMOVAL OF CONTINUATION LINES AS REQUIRED. C SUBROUTINE TABLIN(LINBUF,LMAX,ITEXT,IMAX,JTEXT,UTEXT,BTEXT,MARG) C C PARAMETERS C C LINBUF (I/O) CHAR. ARRAY TO HOLD TEXT FOR TABLE LINE C LMAX (I/O) THE POSITION IN LINBUF OF THE LAST NON-BLANK C CHARACTER ADDED C ITEXT (I/O) CHAR. ARRAY CONTAINING TEXT TO BE ADDED TO LINBUF C AND INTO WHICH TO READ CONTINUATION LINES C IMAX (I/O) NO. OF THE LAST NON-BLANK CHARACTER IN ITEXT C JTEXT (I/O) CHARACTER BUFFER FOR S/R WREC C UTEXT (I/O) CHARACTER BUFFER FOR UNDERLINES FOR S/R WREC C BTEXT (I/O) CHARACTER BUFFER FOR BOLD PRINT FOR S/R WREC C MARG (I/O) CHARACTER VARIABLE HOLDING MARGIN C C SPECIFICATION STATEMENTS C ------------------------- C LOGICAL CONT CHARACTER*(*) LINBUF,ITEXT,JTEXT,UTEXT,BTEXT,MARG CHARACTER*1 CONTXX,ISAVE COMMON /PAGE/MINCOL,MAXCOL,MINLIN,MAXLIN,NLINES,LREC1,LREC2, *ICUT1,ICUT2,NBLANK,ILINE,IPAGE,NCOL COMMON /UNITS/INDATA,IFLIN,IFLOUT,MSG,IPRINT,ILIST COMMON /LIMS/LBMAX,MXTEXT,MXT,MARGW C C FORM OUTPUT RECORD(S) AND GET CONTINUATION LINES IF PRESENT C ----------------------------------------------------------- C CONTXX=CHAR(0) LMAX=0 GO TO 10 5 CALL GETREC(ITEXT(1:MXT),IMAX,ILMIN,IRTYPE) 10 CONT=.FALSE. IF(IMAX.EQ.0)GO TO 40 IF(ITEXT(IMAX:IMAX).NE.CONTXX)GO TO 20 CONT=.TRUE. IMAX=IMAX-1 IF(IMAX.EQ.0)GO TO 40 20 LINBUF(LMAX+1:LMAX+IMAX)=ITEXT(1:IMAX) LMAX=LMAX+IMAX 40 IF(LMAX.LE.NCOL)GO TO 200 ISAVE=LINBUF(NCOL:NCOL) LINBUF(NCOL:NCOL)=CONTXX CALL WREC(LINBUF(1:NCOL),NCOL,JTEXT(1:NCOL),UTEXT(1:NCOL), *BTEXT(1:NCOL),MARG(1:MARGW),.TRUE.) LINBUF(NCOL:NCOL)=ISAVE L=NCOL-1 J=0 100 L=L+1 IF(L.GT.LMAX)GO TO 110 J=J+1 LINBUF(J:J)=LINBUF(L:L) GO TO 100 110 LMAX=J GO TO 40 200 IF(CONT)GO TO 5 IF(LMAX.LT.NCOL)LINBUF(LMAX+1:NCOL)=' ' CALL WREC(LINBUF(1:NCOL),LMAX,JTEXT(1:NCOL),UTEXT(1:NCOL), *BTEXT(1:NCOL),MARG(1:MARGW),.TRUE.) RETURN END C C SUBROUTINE 'RREC' C ================= C C SUBROUTINE TO READ A RECORD FROM THE INPUT FILE C SUBROUTINE RREC(ITEXT,IMAX,*) C C PARAMETERS C C ITEXT (O) CHAR. ARRAY FOR TEXT READ FROM FILE C IMAX (O) NO. OF CHARACTERS RETURNED IN ITEXT C C RETURN 1 END OF FILE C C SPECIFICATION STATEMENTS C ----------------------- C CHARACTER*(*) ITEXT CHARACTER*1 ISP COMMON /PAGE/MINCOL,MAXCOL,MINLIN,MAXLIN,NLINES,LREC1,LREC2, *ICUT1,ICUT2,NBLANK,ILINE,IPAGE,NCOL COMMON /UNITS/INDATA,IFLIN,IFLOUT,MSG,IPRINT,ILIST COMMON /LIMS/LBMAX,MXTEXT,MXT,MARGW DATA ISP/' '/ C C FORMATTED READ C -------------- C IF(LREC1.LE.0)GO TO 100 READ(IFLIN,1000,END=400)ITEXT DO 10 I=1,LREC1 IMAX=LREC1+1-I IF(ITEXT(IMAX:IMAX).NE.ISP)RETURN 10 CONTINUE IMAX=0 RETURN C C VARIABLE LENGTH BINARY RECORD READ (MAY NOT BE AVAILABLE) C ---------------------------------- C 100 CALL CCPRVR(IFLIN,ITEXT,MXT,IMAX,*400,*800) RETURN C C END OF FILE FOUND C ----------------- C 400 RETURN 1 C C ERROR - NO VARIABLE LENGTH RECORD READ AVAILABLE C ------------------------------------------------ C 800 WRITE(MSG,2001) call ccperr(1,' STOP 800') C C FORMAT STATEMENTS C ----------------- C 1000 FORMAT(A) C 2001 FORMAT(' **VARIABLE LENGTH RECORD INPUT NOT AVAILABLE**') END C C SUBROUTINE 'WREC' C ================= C C THIS SUBROUTINE IS USED TO WRITE A RECORD TO THE OUTPUT FILE AND C OR WRITE A RECORD TO THE PRINTER C SUBROUTINE WREC(ITEXT,IMAX,JTEXT,UTEXT,BTEXT,MARG,IFSING) C PARAMETERS C C ITEXT (I) CHAR. ARRAY WITH TEXT TO BE WRITTEN C IMAX (I) NO. OF CHARACTERS IN ITEXT C JTEXT (I/O) CHARACTER BUFFER FOR TEXT OUTPUT FOR S/R WREC C UTEXT (I/O) CHARACTER BUFFER FOR UNDERLINES FOR S/R WREC C BTEXT (I/O) CHARACTER BUFFER FOR BOLD PRINT FOR S/R WREC C MARG (I/O) CHARACTER VARIABLE HOLDING MARGIN C IFSING (I) FLAG =.TRUE. SINGLE LINE PARAGRAPH, =.FALSE. C MULTIPLE LINE TYPE C C C SPECIFICATION STATEMENTS C ------------------------ C LOGICAL U,B,WF,PR,LI,OV,DS,BO,HP,PS,IFSING,NP,BOLD,ULIN CHARACTER*(*) ITEXT,JTEXT,UTEXT,BTEXT,MARG COMMON /PAGE/MINCOL,MAXCOL,MINLIN,MAXLIN,NLINES,LREC1,LREC2, *ICUT1,ICUT2,NBLANK,ILINE,IPAGE,NCOL COMMON /TIDY/WF,PR,LI,OV,DS,BO,HP,PS COMMON /UNITS/INDATA,IFLIN,IFLOUT,MSG,IPRINT,ILIST CHARACTER*1 TABLE,CH0,BOLDCH,ULCH COMMON /TRANS/CH0,BOLDCH,ULCH,TABLE(256) COMMON /TRANS1/MAXTAB LOGICAL LBLANK,KEY COMMON /KEYL/LBLANK,KEY CHARACTER*150 ULDAT CHARACTER*1 ISP,IDOT,IATCH ,ULD1(150),IT1,IT2 EQUIVALENCE (ULDAT,ULD1(1)) DATA ISP/' '/,ULD1/150*'_'/ C C WRITE RECORD TO OUTPUT FILE IF REQUIRED C --------------------------------------- C IF(.NOT.WF)GO TO 100 IF(LREC2.LE.0)GO TO 20 C C FORMATTED WRITE TO OUTPUT FILE C 10 IF(IMAX.GT.0)THEN L=NCSTR(ITEXT) WRITE(IFLOUT,1001)ITEXT(1:L) ENDIF IF(IMAX.EQ.0)WRITE(IFLOUT,1001)ISP GO TO 100 C C BINARY FILE OUTPUT (VARIABLE LENGTH RECORDS) C -------------------------------------------- C 20 IF(IMAX.EQ.0)GO TO 25 WRITE(IFLOUT)ITEXT GO TO 100 25 WRITE(IFLOUT)ISP GO TO 100 C C HARD COPY OUTPUT IF REQUIRED C ---------------------------- C 100 IF(.NOT.PR.AND..NOT.LI)RETURN IF(KEY.AND.PR.AND.ITEXT.NE.' ')THEN IF(ILINE.LT.MAXLIN)THEN ILINE=ILINE+1 CALL OUTLIN(' ',' ',.FALSE.,.FALSE.,.FALSE.) ENDIF ENDIF KEY=.FALSE. NP=.FALSE. IF(IMAX.EQ.0)GO TO 105 IF(ITEXT.EQ.'@')NP=.TRUE. IF(ITEXT.EQ.'.')ITEXT=' ' IF(HP)THEN IF(ITEXT(1:2).EQ.'!@')THEN NP=.TRUE. GO TO 105 ENDIF IF(INDEX('123456789',ITEXT(1:1)).NE.0)THEN KEY=.TRUE. GO TO 105 ENDIF IF(ITEXT(1:2).EQ.'!.')THEN ITEXT=' ' GO TO 105 ENDIF IF(ITEXT(1:1).EQ.'!')RETURN ENDIF 105 MARGIN=MINCOL-1 ULIN=.FALSE. BOLD=.FALSE. ILINE=ILINE+1 IF(ILINE.GT.MAXLIN.OR.NP)CALL NEWPAG(JTEXT,MARG) IF(NP)RETURN IF(IMAX.EQ.0)GO TO 500 C C SEARCH FOR PRESENCE OF UNDERLINE/BOLD CHARACTERS AND PERFORM CHARACTER C TRANSLATION AS REQUIRED C IF(MAXTAB.EQ.0)GO TO 130 DO 120 I=1,IMAX ICHN=ICHAR(ITEXT(I:I)) IF(ICHN.LE.MAXTAB)ITEXT(I:I)=TABLE(ICHN+1) 120 CONTINUE 130 IF(KEY)GO TO 600 IF(INDEX(ITEXT,ULCH).GT.0)ULIN=.TRUE. IF(BO.AND.INDEX(ITEXT,BOLDCH).GT.0)BOLD=.TRUE. IF(.NOT.ULIN.AND..NOT.BOLD)GO TO 300 C C UNDERLINE AND BOLD PRINT PROCESSING C JTEXT=' ' UTEXT=' ' BTEXT=' ' JT=0 K=0 MLAST=0 150 K=K+1 IF(K.GT.IMAX)GO TO 200 M1=K IF(ITEXT(K:K).EQ.ISP)GO TO 150 155 M2=K K=K+1 IF(K.GT.IMAX)GO TO 160 IF(ITEXT(K:K).NE.ISP)GO TO 155 160 JT=JT+M1-MLAST-1 MLAST=M2 NC=M2-M1+1 U=.FALSE. B=.FALSE. IF(INDEX(ITEXT(M1:M2),ULCH).GT.0)U=.TRUE. IF(.NOT.BO)GO TO 165 IF(INDEX(ITEXT(M1:M2),BOLDCH).GT.0)B=.TRUE. 165 IF(.NOT.U.AND..NOT.B)GO TO 180 C C GET NO. OF CHARACTERS FROM END OF STRING (0-2) TO BE REPLACED C WITH SPACES (MULTIPLE LINE) OR DELETED (SINGLE LINE) C NR=0 IT1=ITEXT(M2:M2) IF(BO)THEN IT2=ITEXT(M2-1:M2-1) IF(IT1.EQ.ULCH.OR.IT1.EQ.BOLDCH)NR=1 IF(M2.GT.M1.AND.IT2.EQ.ULCH.AND.IT1.EQ.BOLDCH)NR=2 IF(M2.GT.M1.AND.IT2.EQ.BOLDCH.AND.IT1.EQ.ULCH)NR=2 ELSE IF(IT1.EQ.ULCH)NR=1 ENDIF NC=NC-NR IF(.NOT.IFSING.AND.M2.EQ.IMAX)JT=JT+NR J1=JT+1 J2=JT+NC JT=JT+NC JTEXT(J1:J2)=ITEXT(M1:M2-NR) DO 170 J=J1,J2 IF(JTEXT(J:J).EQ.ULCH)JTEXT(J:J)=ISP IF(.NOT.BO)GO TO 170 IF(JTEXT(J:J).EQ.BOLDCH)JTEXT(J:J)=ISP 170 CONTINUE IF(U)UTEXT(J1:J2)=ULDAT IF(B)BTEXT(J1:J2)=JTEXT(J1:J2) IF(.NOT.IFSING.AND.M2.NE.IMAX)JT=JT+NR GO TO 150 C C CURRENT FIELD NOT BOLD OR UNDERLINED, ADD TO JTEXT C 180 JTEXT(JT+1:JT+NC)=ITEXT(M1:M2) JT=JT+NC GO TO 150 200 IF(.NOT.PR)GO TO 290 IF(MARGIN.LE.0)GO TO 250 CALL OUTLIN (MARG,JTEXT,.TRUE.,.FALSE.,.FALSE.) IF(.NOT.OV)GO TO 290 IF(ULIN)CALL OUTLIN(MARG,UTEXT,.TRUE.,.FALSE.,.TRUE.) IF(.NOT.BOLD)GO TO 290 CALL OUTLIN(MARG,BTEXT,.TRUE.,.TRUE.,.FALSE.) IF(.NOT.ULIN)GO TO 290 IFIELD=0 215 IFIELD=IFIELD+1 CALL GTFLD(IFIELD,UTEXT,IMAX,K1,K2,0,*220) IF(BTEXT(K1:K2).NE.' ')BTEXT(K1:K2)=ULDAT GO TO 215 220 IF(INDEX(BTEXT,'_').EQ.0)GO TO 290 CALL OUTLIN(MARG,BTEXT,.TRUE.,.TRUE.,.TRUE.) GO TO 290 250 CALL OUTLIN(' ',JTEXT,.FALSE.,.FALSE.,.FALSE.) IF(.NOT.OV)GO TO 290 IF(ULIN)CALL OUTLIN(' ',UTEXT,.FALSE.,.FALSE.,.TRUE.) IF(.NOT.BOLD)GO TO 290 CALL OUTLIN(' ',BTEXT,.FALSE.,.TRUE.,.FALSE.) IF(.NOT.ULIN)GO TO 290 IFIELD=0 265 IFIELD=IFIELD+1 CALL GTFLD(IFIELD,UTEXT,IMAX,K1,K2,0,*270) IF(BTEXT(K1:K2).NE.' ')BTEXT(K1:K2)=ULDAT GO TO 265 270 IF(INDEX(BTEXT,'_').EQ.0)GO TO 290 CALL OUTLIN(' ',BTEXT,.FALSE.,.TRUE.,.TRUE.) GO TO 290 C C MONITOR LISTING ON TERMINAL IF REQUIRED C 290 IF(.NOT.LI)GO TO 400 WRITE(ILIST,1003)JTEXT IF(ULIN)WRITE(ILIST,1003)UTEXT GO TO 400 C C NORMAL LINE OF OUTPUT C 300 IF(.NOT.PR)GO TO 310 IF(MARGIN.LE.0)CALL OUTLIN(' ',ITEXT,.FALSE.,.FALSE.,.FALSE.) IF(MARGIN.GT.0)CALL OUTLIN(MARG,ITEXT,.TRUE.,.FALSE.,.FALSE.) 310 IF(LI)WRITE(ILIST,1003)ITEXT C C EXTRA LINE SPACING IF REQUIRED C 400 LBLANK=.FALSE. IF(.NOT.DS)RETURN IF(IFSING)RETURN ILINE=ILINE+1 IF(ILINE.LE.MAXLIN)CALL OUTLIN(' ',' ',.FALSE.,.FALSE.,.FALSE.) RETURN C C BLANK LINE C 500 CALL OUTLIN(' ',' ',.FALSE.,.FALSE.,.FALSE.) LBLANK=.TRUE. RETURN C C KEYNAME LINE (HELP ONLY) C 600 CALL KEYPRT(ITEXT,MARG) RETURN C C FORMAT STATEMENTS C ----------------- C 1001 FORMAT(A) 1003 FORMAT(' ',A,A) 1004 FORMAT('+',A,A) END C C SUBROUTINE 'NEWPAG' C ==================== C C OUTPUT OF NEW PAGE HEADINGS C SUBROUTINE NEWPAG(JTEXT,MARG) C C PARAMETERS C C JTEXT (I/O) BUFFER FOR PAGE NUMBER HEADING C MARG (I/O) CHARACTER VARIABLE HOLDING MARGIN C C C SPECIFICATION STATEMENTS C ------------------------ C CHARACTER*(*) JTEXT,MARG LOGICAL WF,PR,LI,OV,DS,BO,HP,PS COMMON /TIDY/WF,PR,LI,OV,DS,BO,HP,PS CHARACTER*1 NUM(10) COMMON /PAGE/MINCOL,MAXCOL,MINLIN,MAXLIN,NLINES,LREC1,LREC2, *ICUT1,ICUT2,NBLANK,ILINE,IPAGE,NCOL COMMON /UNITS/INDATA,IFLIN,IFLOUT,MSG,IPRINT,ILIST COMMON /PSDAT/XORIG,YORIG,XP,YP,HT,NPAGES CHARACTER*1 ISP,ICH1,ICH DATA ISP/' '/,ICH1/'1'/ DATA NUM/'0','1','2','3','4','5','6','7','8','9'/ C C START NEW PAGE C -------------- C C COUNT LINE IS NLINES>0, USE FORM-FEED IF NLINES=0 C MARGIN=MINCOL-1 ICH=ISP IF(NLINES.EQ.0)GO TO 20 IF(ILINE.GE.NLINES)GO TO 50 NL=NLINES-ILINE+1 IF(NL.LE.0)GO TO 50 DO 10 I=1,NL IF(PR)CALL OUTLIN(' ',' ',.FALSE.,.FALSE.,.FALSE.) 10 CONTINUE GO TO 50 20 ICH=ICH1 C C OUTPUT PAGE NUMBER HEADING C 50 JTEXT=' ' IF(IPAGE.LT.0)GO TO 75 IPAGE=IPAGE+1 N=NDIGIT(IPAGE) DO 70 I=1,N J=ITHDIG(IPAGE,I)+1 M=NCOL+1-I JTEXT(M:M)=NUM(J) 70 CONTINUE 75 IF(.NOT.PR)GO TO 80 IF(PS)THEN IF(ILINE.LT.100000)WRITE(IPRINT,1003) NPAGES = NPAGES + 1 WRITE(IPRINT,1004) NPAGES, NPAGES WRITE(IPRINT,1005) XORIG, YORIG XP=XORIG YP=YORIG IF(MARGIN.LE.0)CALL OUTLIN(' ',JTEXT,.FALSE.,.FALSE.,.FALSE.) IF(MARGIN.GT.0)CALL OUTLIN(MARG,JTEXT,.TRUE.,.FALSE.,.FALSE.) ELSE IF(MARGIN.LE.0)WRITE(IPRINT,1002)ICH,JTEXT IF(MARGIN.GT.0)WRITE(IPRINT,1002)ICH,MARG,JTEXT ENDIF 80 IF(LI)WRITE(ILIST,1002)ISP,JTEXT NL=MINLIN-2 IF(NL.LE.0)GO TO 100 DO 90 I=1,NL IF(PR)CALL OUTLIN(' ',' ',.FALSE.,.FALSE.,.FALSE.) IF(LI)WRITE(ILIST,1001) 90 CONTINUE 100 ILINE=MINLIN RETURN C C FORMAT STATEMENTS C ----------------- C 1001 FORMAT(' ') 1002 FORMAT(A1,A,A) 1003 FORMAT('showpage') 1004 FORMAT('%%Page: ',I6,I6) 1005 FORMAT(F7.1,F7.1,' m') END C C SUBROUTINE 'KEYPRT' C =================== C C LIST/PRINT KEYNAME LINE C SUBROUTINE KEYPRT(ITEXT,MARG) C C PARAMETERS C C ITEXT (I) CHARACTER VARIABLE HOLDING THE KEYNAME LINE C MARG (I) CHARACTER VARIABLE HOLDING THE O/P MARGIN C C SPECIFICATION STATEMENTS C ------------------------ C CHARACTER*(*) ITEXT,MARG CHARACTER*50 SECSTR CHARACTER*200 TMPSTR CHARACTER*150 KTEXT,ULDAT CHARACTER*1 ULD1(150),CC CHARACTER*10 DIG LOGICAL BOPR LOGICAL START,WF,PR,LI,OV,DS,BO,HP,PS COMMON /PAGE/MINCOL,MAXCOL,MINLIN,MAXLIN,NLINES,LREC1,LREC2, *ICUT1,ICUT2,NBLANK,ILINE,IPAGE,NCOL COMMON /TIDY/WF,PR,LI,OV,DS,BO,HP,PS CHARACTER*1 TABLE,CH0,BOLDCH,ULCH COMMON /TRANS/CH0,BOLDCH,ULCH,TABLE(256) COMMON /TRANS1/MAXTAB COMMON /UNITS/INDATA,IFLIN,IFLOUT,MSG,IPRINT,ILIST COMMON /SECNO/ISECT(9) LOGICAL LBLANK,KEY COMMON /KEYL/LBLANK,KEY EQUIVALENCE (ULDAT,ULD1) DATA ULD1/150*'_'/ DATA DIG/'0123456789'/ C C GET KEYNAME LEVEL AND SET SECTION NUMBERING PARTS C ------------------------------------------------- C MARGIN=MINCOL-1 IL=INDEX(DIG,ITEXT(1:1))-1 IF(ISECT(IL).GE.0)ISECT(IL)=ISECT(IL)+1 IF(IL.LE.8)THEN DO 20 I=IL+1,9 ISECT(I)=0 20 CONTINUE ENDIF LL=LEN(ITEXT) DO 24 I=1,LL J=LL+1-I IF(ITEXT(J:J).NE.' ')GO TO 25 24 CONTINUE 25 NCMAX=J IF(NCMAX.LT.3)NCMAX=3 C C SET UP SECTION NUMBERING STRING C ------------------------------- C START=.TRUE. N=0 SECSTR=' ' DO 50 I=1,9 IF(ISECT(I).LT.0)GO TO 50 IF(ISECT(I).EQ.0)GO TO 60 IF(.NOT.START)THEN N=N+1 IF(N.LE.50)SECSTR(N:N)='.' ENDIF ND=NDIGIT(ISECT(I)) DO 30 NN=ND,1,-1 K=ITHDIG(ISECT(I),NN) N=N+1 IF(N.LE.50)SECSTR(N:N)=DIG(K+1:K+1) 30 CONTINUE START=.FALSE. 50 CONTINUE 60 IF(N.GT.50)THEN SECSTR(48:50)='...' N=50 ENDIF C C LIST/PRINT KEYNAME LINE C ----------------------- C MARGIN=NCOL-1 IF(PR)THEN IF(IL.EQ.1)THEN IF(ILINE.GT.MINLIN)CALL NEWPAG(KTEXT(1:NCOL),MARG) ELSE IF(.NOT.LBLANK.AND.(ILINE.GT.MAXLIN))THEN ILINE=ILINE+1 CALL OUTLIN(' ',' ',.FALSE.,.FALSE.,.FALSE.) ENDIF ENDIF ENDIF DO 70 I=2,NCMAX IF(ITEXT(I:I).EQ.ULCH)ITEXT(I:I)=' ' IF(BO.AND.ITEXT(I:I).EQ.BOLDCH)ITEXT(I:I)=' ' 70 CONTINUE IF(N.EQ.0)THEN IF(NCMAX-2.GT.NCOL)NCMAX=NCOL+2 ELSE IF(N+NCMAX-1.GT.NCOL)NCMAX=NCOL-N+1 ENDIF KTEXT=' ' IF(N.EQ.0)THEN KTEXT(1:NCMAX-2)=ULDAT KTMAX=NCMAX-2 ELSE KTEXT(N+2:N+NCMAX-1)=ULDAT KTMAX=N+NCMAX-1 ENDIF IF(PR)THEN KK=2 IF(.NOT.OV.OR.IL.GT.2)KK=1 BOPR=.FALSE. DO 120 K=1,KK IF(N.EQ.0)THEN IF(MARGIN.LE.0)THEN CALL OUTLIN(' ',ITEXT(3:NCMAX),.FALSE.,BOPR,.FALSE.) ELSE CALL OUTLIN(MARG,ITEXT(3:NCMAX),.TRUE.,BOPR,.FALSE.) ENDIF ELSE TMPSTR=SECSTR(1:N)//' '//ITEXT(3:NCMAX) IF(MARGIN.LE.0)THEN CALL OUTLIN(' ',TMPSTR,.FALSE.,BOPR,.FALSE.) ELSE CALL OUTLIN(MARG,TMPSTR,.TRUE.,BOPR,.FALSE.) ENDIF ENDIF BOPR=.TRUE. 120 CONTINUE IF(OV)THEN IF(MARGIN.LE.0)THEN CALL OUTLIN(' ',KTEXT(1:KTMAX),.FALSE.,.TRUE.,.TRUE.) ELSE CALL OUTLIN(MARG,KTEXT(1:KTMAX),.TRUE.,.TRUE.,.TRUE.) ENDIF ENDIF ENDIF IF(LI)THEN IF(N.EQ.0)THEN WRITE(ILIST,1004)ITEXT(3:NCMAX) ELSE WRITE(ILIST,1004)SECSTR,ITEXT(3:NCMAX) ENDIF WRITE(ILIST,1004)KTEXT(1:KTMAX) ENDIF RETURN C C FORMAT STATEMENTS C ----------------- C 1001 FORMAT(' ') 1002 FORMAT(A,A,A,1X,A) 1003 FORMAT(A,A,1X,A) 1004 FORMAT(' ',A,1X,A) END C C C SUBROUTINE 'GTFLD' C ================== C C THIS SUBROUTINE FINDS THE MINIMUM AND MAXIMUM CHARACTER NUMBERS C IN A TEXT STRING FOR A GIVEN FIELD NUMBER. FIELDS MAY BE SEPARATED C BY SPACES OR SPACES AND/OR COMMAS. C C SUBROUTINE CALL CALL GTFLD(NFIELD,ITEXT,NCHAR,MIN,MAX,IFCOMM,*) C C PARAMETERS C NFIELD (I) THE NUMBER OF THE FIELD TO BE RETRIEVED C ITEXT (I) CHARACTER*1 ARRAY CONTAINING THE C TEXT STRING TO BE INTERPRETED C NCHAR (I) THE MAX NO. OF CHARACTERS IN THE TEXT STRING C MIN (0) THE NUMBER OF THE FIRST CHARACTER IN THE FIELD C (OR -1 IF ABSENT OR BLANK FIELD) C MAX (O) THE NUMBER OF THE LAST CHARACTER IN THE FIELD C IFCOMM (I) FLAG =0, FIELD SEPARATORS ARE SPACES C =1, FIELD SEPARATORS ARE SPACES AND/OR C COMMAS C * RETURN IF A BLANK FIELD IS FOUND C C SUBROUTINE GTFLD(NFIELD,ITEXT,NCHAR,MIN,MAX,IFCOMM,*) C C DECLARATIONS C CHARACTER*1 ITEXT(NCHAR),IBL,ICM C C DATA STATEMENTS C DATA IBL/' '/ DATA ICM/','/ C C INITIALISATION STATEMENTS C IFIELD=0 I=0 MIN=-1 MAX=NCHAR ICOM=1 C C SKIP SPACES AND COUNT DELIMITING COMMAS UP TO NEXT OCCUPIED FIELD C 10 I=I+1 IF(I.GT.NCHAR)RETURN 1 IF(ITEXT(I).EQ.IBL)GO TO 10 IF(IFCOMM.EQ.0.OR.ITEXT(I).NE.ICM)GO TO 20 ICOM=ICOM+1 GO TO 10 C C AN OCCUPIED FIELD HAS BEEN FOUND, CALCULATE THE FIELD NUMBER C AND COMPARE IT WITH THE ONE REQUIRED C 20 IF(ICOM.EQ.0)ICOM=1 IFIELD=IFIELD+ICOM IF(IFIELD.GT.NFIELD)RETURN IF(IFIELD.EQ.NFIELD)GO TO 100 C C REQUIRED FIELD NOT YET REACHED SKIP OVER CURRENT FIELD C 25 I=I+1 IF(I.GT.NCHAR)RETURN 1 IF(ITEXT(I).EQ.IBL)GO TO 30 IF(IFCOMM.EQ.1.AND.ITEXT(I).EQ.ICM)GO TO 35 GO TO 25 30 ICOM=0 GO TO 10 35 ICOM=1 GO TO 10 C C REQUIRED FIELD FOUND FIND THE END OF THE FIELD C 100 MIN=I 110 I=I+1 IF(I.GT.NCHAR)RETURN IF(ITEXT(I).EQ.IBL)GO TO 120 IF(IFCOMM.EQ.1.AND.ITEXT(I).EQ.ICM)GO TO 120 GO TO 110 120 MAX=I-1 RETURN END C C C C SUBROUTINE 'DECNUM' C =================== C C THIS SUBROUTINE INTERPRETS A NUMERICAL FIELD WITHIN A TEXT STRING C C C C SUBROUTINE CALL CALL DECNUM(ITEXT,MIN,MAX,ITYPE,X,IERR) C C PARAMETERS C ITEXT (I) CHARACTER ARRAY CONTAINING THE INPUT LINE C OF TEXT C MIN (I) THE FIRST CHARACTER OF THE FIELD TO BE DECODED C MAX (I) THE FINAL CHARACTER OF THE FIELD TO BE DECODED C ITYPE (I) FLAG =1 INTEGER NUMBER TO BE INTERPRETED C =2 REAL NUMBER TO BE INTERPRETED C X (O) THE VALUE FOUND FOR THE NUMBER (=0.0 IF ABSENT) C IERR (O) FLAG =0 VALID SYNTAX C =1 ERROR IN SYNTAX C C SUBROUTINE DECNUM(ITEXT,MIN,MAX,ITYPE,X,IERR) C C DECLARATIONS C CHARACTER*1 INUM(10),ITEXT(MAX),IPOINT,IPLUS,IMINUS C C DATA STATEMENTS C DATA INUM/'1','2','3','4','5','6','7','8','9','0'/ DATA IPOINT/'.'/ DATA IPLUS/'+'/ DATA IMINUS/'-'/ C C INITIALISATION STATEMENTS C X=0.0 A=0.0 IP=0 NP=0 S=1.0 C C CHECK VALIDITY OF MIN AND MAX C IF(MIN.LT.1)GO TO 200 IF(MAX.LT.MIN)GO TO 200 C C INTERPRET NUMBER C DO 100 I=MIN,MAX IF(I.GT.MIN)GO TO 20 C FIRST CHARACTER MAY BE A SIGN IF(ITEXT(I).NE.IPLUS.AND.ITEXT(I).NE.IMINUS)GO TO 20 IF(ITEXT(I).EQ.IMINUS)S=-1.0 GO TO 100 C CHECK FOR DECIMAL POINT AND ALSO THAT ONLY ONE IS PRESENT 20 IF(ITEXT(I).NE.IPOINT)GO TO 30 IP=IP+1 IF(IP.GT.1)GO TO 200 GO TO 100 C CHECK THAT OTHER CHARACTERS ARE DIGITS 30 DO 35 K=1,10 IF(ITEXT(I).EQ.INUM(K))GO TO 40 35 CONTINUE GO TO 200 C VALID DIGIT FOUND ADD IT INTO NUMBER 40 IF(K.EQ.10)K=0 IF(IP.EQ.1)NP=NP+1 A=10.0*A + K 100 CONTINUE C EXTRA CHECK FOR INTEGER IF REQUIRED IF(ITYPE.NE.1)GO TO 120 IF(IP.EQ.1)GO TO 200 C FORM RESULT 120 IERR=0 AA=S*A IF(NP.EQ.0)GO TO 160 DO 150 I=1,NP AA=AA/10.0 150 CONTINUE 160 X=AA RETURN C C ERROR RETURN C 200 IERR=1 RETURN END C C FUNCTION 'NWORDS' C ================= C C RETURNS THE NUMBER OF CHARACTER FIELDS PRESENT IN A TEXT STRING C (CHARACTER STRINGS ARE ASSUMED TO BE SEPARATED BY ONE OR MORE SPACES) C FUNCTION NWORDS(ITEXT,IMAX,ILAST) C C PARAMETERS C C ITEXT (I) CHAR. ARRAY CONTAINING THE TEXT STRING C IMAX (I) THE NO. OF CHARACTERS IN THE TEXT STRING C ILAST (O) THE POSITION OF THE LAST NON-BLANK CHARACTER C C C SPECIFICATION STATEMENTS C CHARACTER*1 ITEXT(IMAX),ISP DATA ISP/' '/ C C CODE C NWORDS=0 ILAST=0 I=0 10 I=I+1 IF(I.GT.IMAX)RETURN IF(ITEXT(I).EQ.ISP)GO TO 10 NWORDS=NWORDS+1 20 ILAST=I I=I+1 IF(I.GT.IMAX)RETURN IF(ITEXT(I).EQ.ISP)GO TO 10 GO TO 20 END C C FUNCTION 'NDIGIT' C ================= C C FIND THE NUMBERR OF DECIMAL DIGITS IN AN INTEGER C FUNCTION NDIGIT(N) C C PARAMETERS C C N (I) THE INTEGER FOR WHICH THE NO. OF DIGITS IS TO BE FOUND C C C CODE C I=N NDIG=0 10 NDIG=NDIG+1 I=I/10 IF(I.NE.0)GO TO 10 NDIGIT=NDIG RETURN END C C FUNCTION 'ITHDIG' C ================= C C RETURNS THE VALUE, 0 - 9, OF THE 'I'TH DIGIT FROM THE RIGHT C OF AN INTEGER C FUNCTION ITHDIG(N,I) C C PARAMETERS C C N (I) THE INTEGER VALUE C I (I) THE NO. FROM THE RIGHT OF THE REQUIRED DIGIT C C CODE C K=I-1 ITHDIG=(N-(N/10**I)*(10**I))/(10**K) IF(ITHDIG.LT.0)ITHDIG=-ITHDIG RETURN END C C SUBROUTINE 'RDNVAL' C =================== C C READ 'N' INTEGER VALUES IN FREE FORMAT C SUBROUTINE RDNVAL(N,IARR,ITEXT,MAXNUM) C C PARAMETERS C C N (I) THE NO. OF VALUES TO BE READ C IARR (O) ARRAY TO RETURN THE VALUES C ITEXT (I/O) BUFFER TO READ DATA C MAXNUM (O) MAXIMUM NUMBER READ (>=0) C C SPECIFICATION STATEMENTS C ------------------------ C DIMENSION IARR(*) CHARACTER*72 ITEXT COMMON /UNITS/INDATA,IFLIN,IFLOUT,MSG,IPRINT,ILIST IF(N.EQ.0)RETURN NN=0 MAXNUM=0 10 READ(INDATA,1001,END=810)ITEXT IFIELD=0 20 IFIELD=IFIELD+1 CALL GTFLD(IFIELD,ITEXT,72,MIN,MAX,0,*10) NN=NN+1 CALL DECNUM(ITEXT,MIN,MAX,1,X,IERR) IF(IERR.EQ.1)GO TO 800 IARR(NN)=NINT(X) IF(IARR(NN).GT.MAXNUM)MAXNUM=IARR(NN) IF(NN.GE.N)RETURN GO TO 20 C C ERROR CONDITIONS C ---------------- C 800 WRITE(MSG,2001) call ccperr(1,'STOP 100-800') 810 WRITE(MSG,2002) call ccperr(1,' STOP 100-810') C C FORMAT STATEMENTS C ----------------- C 1001 FORMAT(A72) C 2001 FORMAT(' **SYNTAX ERROR IN TRANSLATION CODE TABLE**') 2002 FORMAT(' **INSUFFICIENT TRANSLATION CODES GIVEN**') END C C FUNCTION 'NCSTR' C ================ C C FIND THE NUMBER OF CHARACTERS IN A TEXT STRING UP TO THE LAST C NON-BLANK CHARACTER (RETURNS 1 FOR A BLANK STRING) C FUNCTION NCSTR(STRING) C C PARAMETERS C C STRING (I) STRING TO BE EXAMINED C C SPECIFICATION STATEMENTS AND CODE C --------------------------------- C CHARACTER*(*) STRING LL=LEN(STRING) DO 10 I=1,LL J=LL+1-I IF(STRING(J:J).NE.' ')GO TO 20 10 CONTINUE 20 NCSTR=J RETURN END C C SUBROUTINE PSHEAD C ================= C C OUTPUT HEADER FOR POSTSCRIPT FILE C SUBROUTINE PSHEAD C COMMON /UNITS/INDATA,IFLIN,IFLOUT,MSG,IPRINT,ILIST COMMON /PSDAT/XORIG,YORIG,XP,YP,HT,NPAGES C WRITE(IPRINT,1001)NPAGES WRITE(IPRINT,1002) WRITE(IPRINT,1003) WRITE(IPRINT,1004) WRITE(IPRINT,1005) WRITE(IPRINT,1006)XORIG,YORIG WRITE(IPRINT,1007) RETURN C C FORMAT STATEMENTS C ----------------- C 1001 FORMAT ('%!PS-Adobe-3.0',/, + '%%Pages:', I6, /, + '%%EndComments') 1002 FORMAT ('newpath') 1003 FORMAT ('/Normal {/Courier findfont',/, + '10 scalefont setfont} def') 1004 FORMAT ('/Bold {/Courier-Bold findfont',/, + '10 scalefont setfont} def') 1005 FORMAT ('/s {show} def /m {moveto} def') 1006 FORMAT (F7.1,F7.1,' m') 1007 FORMAT ('Normal') END C C SUBROUTINE 'OUTLIN' C =================== C C OUTPUT LINE FOR PRINT/POSTSCRIPT OPTIONS C SUBROUTINE OUTLIN(MARG,TEXT,PRMRG,PRBO,PRUL) C C PARAMETERS C C MARG (I) CHARACTER STRING FOR MARFGIN (IF REQUIRED) C TEXT (I) TEXT STRING TO BE OUTPUT C PRMRG (I) PRINT MARGIN FLAG C PRBO (I) PRINT BOLD FLAG C OVRP (I) PRINT UNDERLINE FLAG C CHARACTER*(*) MARG CHARACTER*(*) TEXT CHARACTER*2 BSL LOGICAL PRMRG,PRBO,PRUL CHARACTER*350 TMPLIN CHARACTER*1 CC LOGICAL WF,PR,LI,OV,DS,BO,HP,PS COMMON /TIDY/WF,PR,LI,OV,DS,BO,HP,PS COMMON /UNITS/INDATA,IFLIN,IFLOUT,MSG,IPRINT,ILIST COMMON /PSDAT/XORIG,YORIG,XP,YP,HT,NPAGES C C POSTSCRIPT C ---------- C IF(PS)THEN BSL='\\' TMPLIN=' ' J=0 IF(PRMRG)THEN TMPLIN=MARG J=LEN(MARG) END IF LL=NCSTR(TEXT) DO 100 I=1,LL IF(TEXT(I:I).EQ.'(' + .OR.TEXT(I:I).EQ.')' + .OR.TEXT(I:I).EQ.BSL(1:1))THEN J=J+1 TMPLIN(J:J)=BSL(1:1) END IF J=J+1 TMPLIN(J:J)=TEXT(I:I) 100 CONTINUE IF(PRBO.OR.PRUL)THEN YP=YP+HT ENDIF WRITE(IPRINT,1004)XP,YP IF(PRBO)WRITE(IPRINT,1001) WRITE(IPRINT,1002)TMPLIN(1:NCSTR(TMPLIN)) IF(PRBO)WRITE(IPRINT,1003) YP=YP-HT RETURN C C PRINTER FILE (WITH FORTRAN CARRIAGE CONROL CHARACTERS) C ------------------------------------------------------ C ELSE IF(PRMRG)THEN TMPLIN=MARG//TEXT ELSE TMPLIN=TEXT ENDIF CC=' ' IF(PRBO.OR.PRUL)CC='+' IF(PRBO)THEN DO 200 I=1,3 WRITE(IPRINT,1100)CC,(TMPLIN(J:J),J=1,NCSTR(TMPLIN)) 200 CONTINUE ELSE WRITE(IPRINT,1100)CC,(TMPLIN(J:J),J=1,NCSTR(TMPLIN)) END IF END IF RETURN C C FORMAT STATEMENTS C ----------------- C 1001 FORMAT('Bold') 1002 FORMAT('(',A,') s') 1003 FORMAT('Normal') 1004 FORMAT(F7.1,F7.1,' m') 1100 FORMAT(A,200A1) END C C SUBROUTINE 'PSREDO' C =================== C C REDO POSTSCRIPT FILE WITH HEADER AND NUMBER OF PAGES C SUBROUTINE PSREDO C COMMON /UNITS/INDATA,IFLIN,IFLOUT,MSG,IPRINT,ILIST CHARACTER*250 IREC ITEMP = 10 ENDFILE IPRINT REWIND IPRINT IFAIL=0 CALL CCPDPN(-ITEMP,'TTEMP','SCRATCH','F',0,IFAIL) 10 READ(IPRINT,1000,END=100)IREC WRITE(ITEMP,1000)IREC(1:LENSTR(IREC)) GO TO 10 100 ENDFILE ITEMP REWIND IPRINT REWIND ITEMP CALL PSHEAD 20 READ(ITEMP,1000,END=200)IREC WRITE(IPRINT,1000)IREC(1:LENSTR(IREC)) GO TO 20 200 CLOSE(ITEMP) WRITE(IPRINT,1001) RETURN C C FORMAT STATEMENTS C ----------------- 1000 FORMAT(A) 1001 FORMAT('showpage') END C C SUBROUTINE 'CCPOPN' C =================== C C THIS SUBROUTINE IS USED TO OPEN A FILE C C IF APPROPRIATE THE SUBROUTINE WILL USE THE STANDARD FORTRAN77 C OPEN STATEMENT. ON MACHINES WHERE THIS IS NOT ADEQUATE, MACHINE C SPECIFIC PARAMETERS MAY BE INCLUDED. IF NECESSARY EACH PROGRAM MAY C BE GIVEN ITS OWN VESRSION OF 'CCPOPN' IF A GENERAL VERSION CANNOT C MEET THE REQUIREMENTS. C C# SUBROUTINE CCPOPN(IUN,FILNAM,ISTAT,ITYPE,LREC,IFAIL) C C PARAMETERS C C IUN (I) UNIT NUMBER C FILNAM (I) LOGICAL FILE NAME (UP TO 8 CHARACTERS) C ISTAT (I) FILE STATUS FLAG =1, 'UNKNOWN' C =2, 'SCRATCH' C =3, 'OLD' C =4, 'NEW' C =5, 'READONLY' C =6, 'PRINTER' C ITYPE (I) FILE TYPE FLAG =1, 'SEQUENTIAL' 'FORMATTED' C =2, 'SEQUENTIAL' 'UNFORMATTED' C =3, 'DIRECT' 'FORMATTED' C =4, 'DIRECT' 'UNFORMATTED' C LREC (I) RECORD LENGTH FOR DIRECT ACCESS FILE (NO. OF C CHARACTERS FOR A FORMATTED FILE OR WORDS FOR C AN UNFORMATTED FILE). NOT RELEVANT FOR A SEQUENTIAL C FILE C IFAIL (I/O) ON INPUT: =0, STOP ON OPEN FAILURE C =1, CONTINUE AFTER OPEN FAILURE C ON OUTPUT: UNCHANGED IF FILE OPEN OK C =-1, ERROR IN OPENING FILE C C C I/O STATUS RETURNED IN 'IOS' IN COMMON 'CCPSTT' IF NEEDED C C ***THIS DEFAULT VERSION DOES NOT USE FILE NAMES (RECORD LENGTH FOR C UNFORMATTED DIRECT ACCESS FILES IS SET TO 4*LREC )*** C C SPECIFICATION STATEMENTS C C# CHARACTER*(*) FILNAM C# CHARACTER*7 STAT(6),ST C# CHARACTER*12 FRM C# COMMON/CCPSTT/IOS C# DATA STAT/'UNKNOWN','SCRATCH','OLD','NEW','OLD','UNKNOWN'/ C# SAVE /CCPSTT/ C C OPEN THE FILE C C# IF(ISTAT.LT.1.OR.ISTAT.GT.6)GO TO 800 C# IF(ITYPE.LT.1.OR.ITYPE.GT.4)GO TO 800 C# ST=STAT(ISTAT) C# FRM='FORMATTED' C# IF(ITYPE.EQ.2.OR.ITYPE.EQ.4)FRM='UNFORMATTED' C# IF(ITYPE.GT.2)GO TO 100 C# IF(IFAIL.EQ.0)THEN C# OPEN(UNIT=IUN,STATUS=ST,ACCESS='SEQUENTIAL', C# *FORM=FRM,IOSTAT=IOS) C# IF(IOS.GT.0)STOP '**CCPOPN ERROR**' C# ENDIF C# IF(IFAIL.EQ.1)THEN C# OPEN(UNIT=IUN,ERR=800,STATUS=ST,ACCESS='SEQUENTIAL', C# *FORM=FRM,IOSTAT=IOS) C# ENDIF C# RETURN C#100 LLREC=LREC C# IF(ITYPE.EQ.4)LLREC=4*LREC C# IF(IFAIL.EQ.0)THEN C# OPEN(UNIT=IUN,STATUS=ST,ACCESS='DIRECT',FORM=FRM, C# *RECL=LLREC,IOSTAT=IOS) C# IF(IOS.GT.0)STOP '**CCPOPN ERROR**' C# ENDIF C# IF(IFAIL.EQ.1)THEN C# OPEN(UNIT=IUN,ERR=800,STATUS=ST,ACCESS='DIRECT',FORM=FRM, C# *RECL=LLREC,IOSTAT=IOS) C# ENDIF C# RETURN C C ERROR RETURN C C#800 IF(IFAIL.EQ.0)STOP '**CCPOPN ERROR**' C# IFAIL=-1 C# RETURN C# END C C SUBROUTINE 'CCPRVR' C =================== C C READ A VARIABLE LENGTH CHARACTER RECORD OF UNKNOWN LENGTH FROM AN C UNFORMATTED SEQUENTIAL FILE C SUBROUTINE CCPRVR(IUN,ITEXT,NCHMAX,IMAX,*,*) C C PARAMETERS C C IUN (I) UNIT NUMBER FOR THE READ C ITEXT (O) CHARACTER ARRAY TO HOLD THE TEXT READ C NCHMAX (I) MAX. NO. OF CHARACTERS IN ITEXT C IMAX (O) NO. OF CHARACTERS READ C C RETURN 1 END OF FILE C RETURN 2 VARIABLE LENGTH READ OF UNKNOWN LENGTH NOT AVAILABLE C C ***DUMMY VERSION*** C CHARACTER*1 ITEXT(NCHMAX) RETURN 2 END