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
