home *** CD-ROM | disk | FTP | other *** search
/ Oakland CPM Archive / oakcpm.iso / cpmug / cpmug091.ark / PRINT81.FOR < prev    next >
Text File  |  1984-04-29  |  6KB  |  255 lines
  1. C PROGRAM TO PRINT FORTRAN, ASM AND PRN SOURCE FILES WITH
  2. C IMBEDDED PAGE EJECTIONS - THUS SUBROUTINES CAN BE
  3. C PRINTED ON SEPARATE PAGES FOR CLARITY.
  4. C EJECTIONS ARE INSERTED IN COL 1-6 AND ARE C$ FOR
  5. C FORTRAN FILES AND ;$ FOR ASM FILES. EJECTION FLAGS
  6. C ARE NON-PRINTING
  7. C.
  8. C TABS EXPANDED,  FORM FEEDS RETAINED ON ONE OPTION
  9. C.
  10. C FOR PRN FILES WE LOOK THRU COLS 15-20 FOR THE ;$ COM-
  11. C BINATION. THUS .PRN LISTINGS PAGE ALSO.
  12. C.
  13. C WE ATTEMP TO REMOVE SOME CLUTTER BY MAKING THE FORTRAN
  14. C COMBINATION (COLS 1-2) OF 'C.' A LINE FEED ONLY.
  15. C.
  16. C PARAMETERS:
  17. C    NCNT = COUNT OF LINES PRINTED THIS PAGE
  18. C    IFEED = FORM FEED FLAG, 1=YES
  19. C    ILINES = TOTAL LINES ON PAGE, DEFAULT=66
  20. C    NLINES = NO OF PRINTED LINES PER PAGE, DEFAULT=56
  21. C    ITAB = EXPANSION OF TABS FLAG, 1=YES
  22. C    NFLG = END OF FILE FLAG
  23. C.
  24. C MENU FORMAT 600 SENDS A FORM FEED TO CONSOLE TO CLEAR
  25. C SCREEN. IF BOTHERSOME CHANGE TO 1H0..
  26. C IF YOUR PRINTER GIVES AN AUTOMATIC LF WITH CR YOU MUST
  27. C DELETE 2 WRITE STATEMENTS. IN PRINT8..WRITE (2,38) D
  28. C AND IN DOLLAR..WRITE (2,602)D,IPAGE..THESE CAUSE OVER-
  29. C STRIKES.
  30. C FOR A DEMO, DO A TYPE ON THIS FORTRAN LISTING AND THEN
  31. C PRINT81  IT.
  32. C.
  33. C TO CONTROL LEFT MARGIN YOU MAY WISH TO CHANGE THE 6X
  34. C IN STATEMENT 35
  35. C.
  36. C IF YOU USE THIS PROGRAMS, SEND ME A CARD. IF I GET
  37. C ENOUGH INTEREST, I WILL MAINTAIN THE PROGRAM..
  38. C AUTHOR:
  39. C    LAWSON PIERCE
  40. C    2516 SUNNYBROOK DR
  41. C    KALAMAZOO MI  49008
  42. C$
  43.     PROGRAM PRINT8
  44.     EXTERNAL OPEN
  45.     LOGICAL A(128),D(25)
  46.     COMMON NFLAG,NFLG,NCNT,ITAB,IFEED,ILINES,IBEG,A,D
  47.     DATA NCNT,IFLAG,NFLG/3*0/
  48.     DATA ITAB,IFEED,ILINES,NLINES,IBEG/1,1,66,56,1/
  49.     CALL MENU (IDRIVE,NFLAG,ITAB,IFEED,ILINES,NLINES)
  50.     CALL PNAME(D,NFLAG,IDRIVE,IBEG)
  51.     IF (NFLAG.EQ.0) GOTO 6
  52.         WRITE (2,37) D
  53.         WRITE (2,38) D
  54.         NCNT=3
  55. 6    CONTINUE
  56. C
  57. 200    READ(6,30,END=1000)A
  58.     IF (ITAB.EQ.1) CALL TABS(A)
  59. C
  60.     CALL DOLLAR
  61.     IF (NFLG.EQ.1) GOTO 1000
  62. C
  63. C FIND ACTUAL LINE LENGTH & CALL IT L
  64. 45    L=128
  65.     DO 50 I=0,127
  66. C        IF A(I) IS NOT A CR OR BLANK, GET OUT OF LOOP
  67.     IF (A(-1*I+128).NE.13.AND.A(-1*I+128).NE.32) GO TO 60
  68. C        ELSE DECR END OF LINE COUNT
  69.     L=L-1
  70. 50    CONTINUE
  71. C
  72. C INCR L TO PICKUP CR AT END OF LINE
  73. 60    IF (L.LT.128) L=L+1
  74.     WRITE(2,35)(A(I),I=1,L)
  75.     NCNT=NCNT+1
  76.     IF (NCNT.LT.NLINES.OR.IFEED.EQ.1) GOTO 200
  77.     DO 199  KK=NCNT,ILINES
  78.     WRITE (2,603)
  79. 199    CONTINUE
  80.     NCNT=0
  81.     GO TO 200
  82. 1000    ENDFILE 6
  83. C
  84. 30    FORMAT(128A1)
  85. 35    FORMAT('+',6X,128A1)
  86. 37    FORMAT (1H ,20X,80A1)
  87. 38    FORMAT('+',20X,25A1,///)
  88. 603    FORMAT (' ')
  89.     END
  90. C$
  91.     SUBROUTINE PNAME(D,NFLAG,IDRIVE,IBEG)
  92. C            SETUP FILE NAME
  93.     LOGICAL B(11),D(25),DUM(12)
  94.     DO 2 I=1,25
  95. 2    D(I)=' '
  96. C
  97. C INSERT DATE OF COMPILE OR PRINT
  98.     WRITE (1,5)
  99.     READ (1,20) (D(I),I=17,25)
  100. 5    FORMAT(1H0,'COMPILE OR PRINT DATE ? .. 01 JAN 82 ..')
  101.     WRITE(1,10)
  102. 10    FORMAT(' FILE NAME: ')
  103.     READ(1,20)DUM
  104. 20    FORMAT(12A1)
  105.     IFLAG=0
  106.     B(1)=DUM(1)
  107.     J=9
  108.     DO 25 I=2,8
  109.         B(I)=DUM(I)
  110.         IF (B(I).EQ.46) J=I
  111.         IF (B(I).EQ.46) IFLAG=1
  112.         IF (IFLAG.EQ.1) B(I)=32
  113. 25        IF (B(I).EQ.13) B(I)=32
  114.     I=8
  115.     DO 26 K=1,3
  116.         I=I+1
  117.         J=J+1
  118.         B(I)=DUM(J)
  119. 26        CONTINUE
  120.     J=3
  121. C IS IT A PRN FILE ?
  122.     IF(B(11).EQ.78.AND.B(10).EQ.82.AND.B(9).EQ.80)IBEG=15
  123. C.
  124.     CALL OPEN(6,B,IDRIVE)
  125. C.
  126. C MAKEUP NAME AND DATE LABEL
  127.         DO 200 I=1,8
  128.         IF (B(I).EQ.32) GOTO 200
  129.         J=J+1
  130.         D(J)=B(I)
  131. 200        CONTINUE
  132.         J=J+1
  133.         D(J)=46
  134.         DO 210 I=9,11
  135.         J=J+1
  136.         D(J)=B(I)
  137. 210        CONTINUE
  138. C.
  139.     RETURN
  140.     END
  141. C$
  142.     SUBROUTINE MENU(IDRIVE,NFLAG,ITAB,IFEED
  143.      1        ,ILINES,NLINES)
  144.     WRITE (1,600)
  145.     WRITE (1,601)
  146.     READ (1,502) IDRIVE
  147.     WRITE (1,602)
  148.     READ (1,502) NFLAG
  149.     WRITE (1,603)
  150.     READ (1,502) IDUM
  151.     IF (IDUM.EQ.1) RETURN
  152.     WRITE (1,604)
  153.     READ (1,502) ITAB
  154.     WRITE (1,605)
  155.     READ (1,502) IFEED
  156.     IF (IFEED.EQ.1) RETURN
  157.     WRITE (1,606)
  158.     READ (1,502) IDUM
  159.     IF (IDUM.EQ.1) RETURN
  160.     WRITE (1,607)
  161.     READ (1,502) ILINES
  162.     WRITE (1,608)
  163.     READ (1,502) NLINES
  164.     RETURN
  165. 502    FORMAT (15I5)
  166. 600    FORMAT (1H1,'POSITION PAPER IN PRINTER')
  167. 601    FORMAT (1H0,'DRIVE SOURCE FILE IS ON ? A=1, B=2 ...')
  168. 602    FORMAT (1H ,'PAGING OPTION, 0=NONE, 1=HEADINGS...')
  169. 603    FORMAT (1H ,'DEFAULTS ARE, EXPAND TABS & SEND '
  170.      1    ,'FORM FEEDS.',/,'.WANT DEFAULTS 1=YES 2=NO..')
  171. 604    FORMAT (1H ,'WANT TO EXPAND TABS ?..')
  172. 605    FORMAT (1H ,'OUTPUT FORM FEEDS ? 1=YES  2=NO..')
  173. 606    FORMAT (1H ,'DEFAULT PAGING IS 66 LINES PER PAGE',
  174.      1  ' AND 56 PRINTED LINES ',/,'  WANT STANDARD'
  175.      2  ' DEFAULTS 1=YES 2=NO...')
  176. 607    FORMAT (1H ,'INPUT NO OF LINES PER PAGE ..')
  177. 608    FORMAT (1H ,'INPUT NO OF PRINTED LINES PER PAGE..')
  178.     END
  179. C$
  180.     SUBROUTINE TABS(A)
  181. C            SUBROUTINE TO EXPAND TABS
  182.     LOGICAL A(128),E(128)
  183.         DO 50 I=1,128
  184.         E(I)=32
  185. 50        CONTINUE
  186.     N=0
  187.     DO 100 K=1,80,8
  188.     IK=0
  189.     DO 200 I=1,8
  190.     IK=IK+1
  191.     N=N+1
  192.     M=K+I-1
  193.     IF (A(M).EQ.9) GOTO 105
  194.     E(N)=A(M)
  195.     GOTO 200
  196. 105    CONTINUE
  197.         N=N-1
  198.         DO 110 J=IK,8
  199.         N=N+1
  200.         E(N)=32
  201. 110        CONTINUE
  202.     IK=0
  203. 200    CONTINUE
  204. 100    CONTINUE
  205.         DO 300 I=1,128
  206.         A(I)=E(I)
  207. 300        CONTINUE
  208.     RETURN
  209.     END
  210. C$
  211.     SUBROUTINE DOLLAR
  212. C            SUBROUTINE FOR PAGING CONTROL
  213.     LOGICAL A(128),D(25)
  214.     COMMON NFLAG,NFLG,NCNT,ITAB,IFEED,ILINES,IBEG,A,D
  215.     DATA IPAGE/1/
  216.     IEND=IBEG+5
  217. C.
  218.     DO 40 I=IBEG,IEND
  219.     IF (A(I).EQ.67) GOTO 45
  220.     IF (A(I).EQ.59) GOTO 45
  221. 40    CONTINUE
  222. 45    CONTINUE
  223. C
  224. C        IF HERE READ C OR ; IN COLS IBEG TO IEND
  225.     J=I+1
  226.     IF (A(I).EQ.67.AND.A(J).EQ.46) GOTO 120
  227.     IF (A(J).NE.36) RETURN
  228.     IF (IFEED.EQ.1) WRITE (2,600)
  229.     IF (IFEED.EQ.1) GOTO 100
  230.     DO 50 K=NCNT,ILINES
  231.     WRITE (2,603)
  232. 50    CONTINUE
  233. 100    IPAGE=IPAGE+1
  234.     NCNT=0
  235.     IF (NFLAG.EQ.0) RETURN
  236.  
  237.     WRITE (2,601) D,IPAGE
  238.     WRITE (2,602) D,IPAGE
  239.     NCNT=3
  240. 110    READ (6,500,END=1000) A
  241.     IF (ITAB.EQ.1) CALL TABS(A)
  242.     RETURN
  243. C IF PERIOD FOLLOWS "C", PRINT LF ONLY
  244. 120    WRITE (2,603)
  245.     NCNT=NCNT+1
  246.     GOTO 110
  247. 1000    NFLG=1
  248.     RETURN
  249. 500    FORMAT (128A1)
  250. 600    FORMAT ('1')
  251. 601    FORMAT (1H ,20X,25A1,18X,'PAGE ',I4)
  252. 602    FORMAT ('+',20X,25A1,18X,'PAGE ',I4,//)
  253. 603    FORMAT (' ')
  254.     END
  255.