home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Oakland CPM Archive
/
oakcpm.iso
/
cpmug
/
cpmug091.ark
/
PRINT81.FOR
< prev
next >
Wrap
Text File
|
1984-04-29
|
6KB
|
255 lines
C PROGRAM TO PRINT FORTRAN, ASM AND PRN SOURCE FILES WITH
C IMBEDDED PAGE EJECTIONS - THUS SUBROUTINES CAN BE
C PRINTED ON SEPARATE PAGES FOR CLARITY.
C EJECTIONS ARE INSERTED IN COL 1-6 AND ARE C$ FOR
C FORTRAN FILES AND ;$ FOR ASM FILES. EJECTION FLAGS
C ARE NON-PRINTING
C.
C TABS EXPANDED, FORM FEEDS RETAINED ON ONE OPTION
C.
C FOR PRN FILES WE LOOK THRU COLS 15-20 FOR THE ;$ COM-
C BINATION. THUS .PRN LISTINGS PAGE ALSO.
C.
C WE ATTEMP TO REMOVE SOME CLUTTER BY MAKING THE FORTRAN
C COMBINATION (COLS 1-2) OF 'C.' A LINE FEED ONLY.
C.
C PARAMETERS:
C NCNT = COUNT OF LINES PRINTED THIS PAGE
C IFEED = FORM FEED FLAG, 1=YES
C ILINES = TOTAL LINES ON PAGE, DEFAULT=66
C NLINES = NO OF PRINTED LINES PER PAGE, DEFAULT=56
C ITAB = EXPANSION OF TABS FLAG, 1=YES
C NFLG = END OF FILE FLAG
C.
C MENU FORMAT 600 SENDS A FORM FEED TO CONSOLE TO CLEAR
C SCREEN. IF BOTHERSOME CHANGE TO 1H0..
C IF YOUR PRINTER GIVES AN AUTOMATIC LF WITH CR YOU MUST
C DELETE 2 WRITE STATEMENTS. IN PRINT8..WRITE (2,38) D
C AND IN DOLLAR..WRITE (2,602)D,IPAGE..THESE CAUSE OVER-
C STRIKES.
C FOR A DEMO, DO A TYPE ON THIS FORTRAN LISTING AND THEN
C PRINT81 IT.
C.
C TO CONTROL LEFT MARGIN YOU MAY WISH TO CHANGE THE 6X
C IN STATEMENT 35
C.
C IF YOU USE THIS PROGRAMS, SEND ME A CARD. IF I GET
C ENOUGH INTEREST, I WILL MAINTAIN THE PROGRAM..
C AUTHOR:
C LAWSON PIERCE
C 2516 SUNNYBROOK DR
C KALAMAZOO MI 49008
C$
PROGRAM PRINT8
EXTERNAL OPEN
LOGICAL A(128),D(25)
COMMON NFLAG,NFLG,NCNT,ITAB,IFEED,ILINES,IBEG,A,D
DATA NCNT,IFLAG,NFLG/3*0/
DATA ITAB,IFEED,ILINES,NLINES,IBEG/1,1,66,56,1/
CALL MENU (IDRIVE,NFLAG,ITAB,IFEED,ILINES,NLINES)
CALL PNAME(D,NFLAG,IDRIVE,IBEG)
IF (NFLAG.EQ.0) GOTO 6
WRITE (2,37) D
WRITE (2,38) D
NCNT=3
6 CONTINUE
C
200 READ(6,30,END=1000)A
IF (ITAB.EQ.1) CALL TABS(A)
C
CALL DOLLAR
IF (NFLG.EQ.1) GOTO 1000
C
C FIND ACTUAL LINE LENGTH & CALL IT L
45 L=128
DO 50 I=0,127
C IF A(I) IS NOT A CR OR BLANK, GET OUT OF LOOP
IF (A(-1*I+128).NE.13.AND.A(-1*I+128).NE.32) GO TO 60
C ELSE DECR END OF LINE COUNT
L=L-1
50 CONTINUE
C
C INCR L TO PICKUP CR AT END OF LINE
60 IF (L.LT.128) L=L+1
WRITE(2,35)(A(I),I=1,L)
NCNT=NCNT+1
IF (NCNT.LT.NLINES.OR.IFEED.EQ.1) GOTO 200
DO 199 KK=NCNT,ILINES
WRITE (2,603)
199 CONTINUE
NCNT=0
GO TO 200
1000 ENDFILE 6
C
30 FORMAT(128A1)
35 FORMAT('+',6X,128A1)
37 FORMAT (1H ,20X,80A1)
38 FORMAT('+',20X,25A1,///)
603 FORMAT (' ')
END
C$
SUBROUTINE PNAME(D,NFLAG,IDRIVE,IBEG)
C SETUP FILE NAME
LOGICAL B(11),D(25),DUM(12)
DO 2 I=1,25
2 D(I)=' '
C
C INSERT DATE OF COMPILE OR PRINT
WRITE (1,5)
READ (1,20) (D(I),I=17,25)
5 FORMAT(1H0,'COMPILE OR PRINT DATE ? .. 01 JAN 82 ..')
WRITE(1,10)
10 FORMAT(' FILE NAME: ')
READ(1,20)DUM
20 FORMAT(12A1)
IFLAG=0
B(1)=DUM(1)
J=9
DO 25 I=2,8
B(I)=DUM(I)
IF (B(I).EQ.46) J=I
IF (B(I).EQ.46) IFLAG=1
IF (IFLAG.EQ.1) B(I)=32
25 IF (B(I).EQ.13) B(I)=32
I=8
DO 26 K=1,3
I=I+1
J=J+1
B(I)=DUM(J)
26 CONTINUE
J=3
C IS IT A PRN FILE ?
IF(B(11).EQ.78.AND.B(10).EQ.82.AND.B(9).EQ.80)IBEG=15
C.
CALL OPEN(6,B,IDRIVE)
C.
C MAKEUP NAME AND DATE LABEL
DO 200 I=1,8
IF (B(I).EQ.32) GOTO 200
J=J+1
D(J)=B(I)
200 CONTINUE
J=J+1
D(J)=46
DO 210 I=9,11
J=J+1
D(J)=B(I)
210 CONTINUE
C.
RETURN
END
C$
SUBROUTINE MENU(IDRIVE,NFLAG,ITAB,IFEED
1 ,ILINES,NLINES)
WRITE (1,600)
WRITE (1,601)
READ (1,502) IDRIVE
WRITE (1,602)
READ (1,502) NFLAG
WRITE (1,603)
READ (1,502) IDUM
IF (IDUM.EQ.1) RETURN
WRITE (1,604)
READ (1,502) ITAB
WRITE (1,605)
READ (1,502) IFEED
IF (IFEED.EQ.1) RETURN
WRITE (1,606)
READ (1,502) IDUM
IF (IDUM.EQ.1) RETURN
WRITE (1,607)
READ (1,502) ILINES
WRITE (1,608)
READ (1,502) NLINES
RETURN
502 FORMAT (15I5)
600 FORMAT (1H1,'POSITION PAPER IN PRINTER')
601 FORMAT (1H0,'DRIVE SOURCE FILE IS ON ? A=1, B=2 ...')
602 FORMAT (1H ,'PAGING OPTION, 0=NONE, 1=HEADINGS...')
603 FORMAT (1H ,'DEFAULTS ARE, EXPAND TABS & SEND '
1 ,'FORM FEEDS.',/,'.WANT DEFAULTS 1=YES 2=NO..')
604 FORMAT (1H ,'WANT TO EXPAND TABS ?..')
605 FORMAT (1H ,'OUTPUT FORM FEEDS ? 1=YES 2=NO..')
606 FORMAT (1H ,'DEFAULT PAGING IS 66 LINES PER PAGE',
1 ' AND 56 PRINTED LINES ',/,' WANT STANDARD'
2 ' DEFAULTS 1=YES 2=NO...')
607 FORMAT (1H ,'INPUT NO OF LINES PER PAGE ..')
608 FORMAT (1H ,'INPUT NO OF PRINTED LINES PER PAGE..')
END
C$
SUBROUTINE TABS(A)
C SUBROUTINE TO EXPAND TABS
LOGICAL A(128),E(128)
DO 50 I=1,128
E(I)=32
50 CONTINUE
N=0
DO 100 K=1,80,8
IK=0
DO 200 I=1,8
IK=IK+1
N=N+1
M=K+I-1
IF (A(M).EQ.9) GOTO 105
E(N)=A(M)
GOTO 200
105 CONTINUE
N=N-1
DO 110 J=IK,8
N=N+1
E(N)=32
110 CONTINUE
IK=0
200 CONTINUE
100 CONTINUE
DO 300 I=1,128
A(I)=E(I)
300 CONTINUE
RETURN
END
C$
SUBROUTINE DOLLAR
C SUBROUTINE FOR PAGING CONTROL
LOGICAL A(128),D(25)
COMMON NFLAG,NFLG,NCNT,ITAB,IFEED,ILINES,IBEG,A,D
DATA IPAGE/1/
IEND=IBEG+5
C.
DO 40 I=IBEG,IEND
IF (A(I).EQ.67) GOTO 45
IF (A(I).EQ.59) GOTO 45
40 CONTINUE
45 CONTINUE
C
C IF HERE READ C OR ; IN COLS IBEG TO IEND
J=I+1
IF (A(I).EQ.67.AND.A(J).EQ.46) GOTO 120
IF (A(J).NE.36) RETURN
IF (IFEED.EQ.1) WRITE (2,600)
IF (IFEED.EQ.1) GOTO 100
DO 50 K=NCNT,ILINES
WRITE (2,603)
50 CONTINUE
100 IPAGE=IPAGE+1
NCNT=0
IF (NFLAG.EQ.0) RETURN
WRITE (2,601) D,IPAGE
WRITE (2,602) D,IPAGE
NCNT=3
110 READ (6,500,END=1000) A
IF (ITAB.EQ.1) CALL TABS(A)
RETURN
C IF PERIOD FOLLOWS "C", PRINT LF ONLY
120 WRITE (2,603)
NCNT=NCNT+1
GOTO 110
1000 NFLG=1
RETURN
500 FORMAT (128A1)
600 FORMAT ('1')
601 FORMAT (1H ,20X,25A1,18X,'PAGE ',I4)
602 FORMAT ('+',20X,25A1,18X,'PAGE ',I4,//)
603 FORMAT (' ')
END