home *** CD-ROM | disk | FTP | other *** search
/ Columbia Kermit / kermit.zip / gould3 / kermit5 < prev    next >
Text File  |  2020-01-01  |  71KB  |  877 lines
  1. *     BASE -ULTLY-KERM -SFM-A2703 - 08/01/90  WJH     HEADER  SFMKERM   0001.000
  2.       BLOCK DATA BDFILECO                                               0001.100
  3.            IMPLICIT NONE                                                0002.000
  4. C                                                                       0003.000
  5. C= Initialize the filecom common                                        0004.000
  6. C                                                                       0005.000
  7.       INCLUDE      K.FILEC                                              0006.000
  8. C                                                                       0007.000
  9.       DATA FMODE/MAXFILE*CLOSED/   !close all units                     0008.000
  10.       DATA FCHPTR /MAXFILE*0/                                           0009.000
  11.       DATA FCHCNT /MAXFILE*0/                                           0010.000
  12.       DATA FEOF /MAXFILE*.FALSE./                                       0011.000
  13.       DATA CTDEV /MAXFILE*.FALSE./                                      0012.000
  14.       DATA FREQ /MAXFILE*0/                                             0013.000
  15.       DATA IOPEND /MAXFILE*NOIO/                                        0014.000
  16.       DATA NOWAIT /MAXFILE*.FALSE./                                     0015.000
  17.       DATA BINARY /MAXFILE*.FALSE./                                     0016.000
  18.       DATA FTIMOUT/MAXFILE* 0/                                          0017.000
  19.       END                                                               0018.000
  20.       INTEGER FUNCTION OPEN(FN, MODE)                                   0019.000
  21.            IMPLICIT NONE                                                0020.000
  22.            CHARACTER*(*) FN        !file name                           0021.000
  23.            CHARACTER*(*) MODE      !mode of file ('R','W')              0022.000
  24. C                                                                       0023.000
  25. C= o Opens a file as specified, returns file index                      0024.000
  26.       INCLUDE      K.FILEC                                              0025.000
  27. C                                                                       0026.000
  28.       INTEGER      I               !indexing                            0027.000
  29.       CHARACTER*8  FILESTAT        !file status for open                0028.000
  30.       INTEGER      IOS             !status of open                      0029.000
  31.       INTEGER      IMODE           !translated mode code                0030.000
  32.       INTEGER      ALTLFC          !altlfc to assign to                 0031.000
  33.       CHARACTER*4  CALTLFC         !character form of alt lfc           0032.000
  34.         EQUIVALENCE (CALTLFC, ALTLFC)                                   0033.000
  35.       LOGICAL      OPENMODE        !access mode                         0034.000
  36. C                                                                       0035.000
  37.       INTRINSIC    ICHAR                                                0036.100
  38. C     INTEGER      ICHAR           !character to integer                0036.200
  39. C                                                                       0037.000
  40. X      WRITE(19,1000)FN,MODE                                            0037.100
  41. X1000  FORMAT(' OPEN** ',(1X,A8,1X,1Z8))                                0037.200
  42.       IF (MODE .EQ. 'R') THEN                                           0038.000
  43.         IMODE = RD                                                      0039.000
  44.       ELSE IF (MODE .EQ. 'W' .OR. MODE .EQ. 'C') THEN                   0040.000
  45.         IMODE = WR                                                      0041.000
  46.       ELSE                                                              0042.000
  47.         CALL PRTMSG('OPEN - invalid mode',ICHAR(MODE))                  0043.000
  48.         OPEN = ERROR                                                    0044.000
  49.         RETURN                                                          0045.000
  50.       ENDIF                                                             0046.000
  51.       DO I=1, MAXFILE              !handle duplicates                   0047.000
  52. C                                                                       0048.000
  53. C handle duplicate entries                                              0049.000
  54. C                                                                       0050.000
  55.         IF (FMODE(I) .NE. CLOSED) THEN     !if open                     0051.000
  56.           IF (FNAME(I) .EQ. FN) THEN     !if duplicate                  0052.000
  57.             IF (FMODE(I) .EQ. IMODE) THEN   !if same mode, ignore       0053.000
  58.               IF (CTDEV(I)) THEN            !if device, flush, ready    0054.000
  59.                 CALL FLUSH(I)                                           0055.000
  60.                 OPEN = I                                                0056.000
  61.                 RETURN                                                  0057.000
  62.               ELSE                         !if file, rewind             0058.000
  63.                 CALL FLUSH(I)                                           0059.000
  64.                 CALL CLOSE(I)                                           0060.000
  65.               ENDIF                                                     0061.000
  66.             ELSE                       !if mode different, reopen       0062.000
  67.               IF (CTDEV(I)) THEN       !if device, not really dupl.     0063.000
  68.                 CONTINUE                                                0064.000
  69.               ELSE                     !if file, close so can reopen    0065.000
  70.                 CALL FLUSH(I)                                           0066.000
  71.                 CALL CLOSE(I)                                           0067.000
  72.               ENDIF                                                     0068.000
  73.             ENDIF                                                       0069.000
  74.           ENDIF                                                         0070.000
  75.         ENDIF                                                           0071.000
  76.       ENDDO                                                             0072.000
  77. C                                                                       0073.000
  78. C find slot                                                             0074.000
  79. C                                                                       0075.000
  80.       OPEN = 1                                                          0076.000
  81.       DO WHILE (OPEN .LT. MAXFILE .AND. FMODE(OPEN) .NE. CLOSED)        0077.000
  82.         OPEN = OPEN + 1                                                 0078.000
  83.       ENDDO                                                             0079.000
  84.       IF (FMODE(OPEN) .NE. CLOSED) THEN                                 0080.000
  85.         OPEN = ERROR                                                    0081.000
  86.         CALL PRTMSG('OPEN - Exceed allowed number of files',MAXFILE)    0082.000
  87.         RETURN                                                          0083.000
  88.       ENDIF                                                             0084.000
  89. C                                                                       0085.000
  90. C open                                                                  0086.000
  91. C                                                                       0087.000
  92.       FNAME(OPEN) = FN                                                  0088.000
  93.       FCHPTR(OPEN) = 1                                                  0089.000
  94.       FCHCNT(OPEN) = 0                                                  0090.000
  95.       FMODE(OPEN) = IMODE                                               0091.000
  96.       FEOF(OPEN) = .FALSE.                                              0092.000
  97.       CTDEV(OPEN) = .FALSE.                                             0093.000
  98.       FREQ(OPEN) = MAXCH                                                0094.000
  99.       IOPEND(OPEN) = NOIO                                               0095.000
  100.       NOWAIT(OPEN) = .FALSE.                                            0096.000
  101.       FTIMOUT(OPEN) = 0                                                 0097.000
  102.       BINARY(OPEN) = .FALSE.                                            0098.000
  103.       DO I=1, 4                                                         0099.000
  104.         FBLK(I, OPEN) = 0                                               0100.000
  105.       ENDDO                                                             0101.000
  106.       DO I=1, MAXCH                                                     0102.000
  107.         FCHBUF(I, OPEN) = 0                                             0103.000
  108.       ENDDO                                                             0104.000
  109. C                                                                       0105.000
  110. C if standard i/o, connect to user terminal                             0106.000
  111. C                                                                       0107.000
  112.       IF (FNAME(OPEN) .EQ. 'STDIN' .OR. FNAME(OPEN) .EQ. 'STDOUT') THEN 0108.000
  113.         OPEN (UNIT=OPEN, ALTUNIT='UT', IOSTAT=IOS, ERR=910)             0109.000
  114.         CTDEV(OPEN) = .TRUE.                                            0110.000
  115.         FREQ(OPEN) = 133                                                0111.000
  116. C                                                                       0112.000
  117. C if terminal - all terminals begin with @                              0113.000
  118. C                                                                       0114.000
  119.       ELSE IF (FNAME(OPEN)(1:1) .EQ. '@') THEN                          0115.000
  120.         FNAME(OPEN) = FNAME(OPEN)(2:)                                   0116.000
  121.         OPEN (UNIT=OPEN, DEVICE=FNAME(OPEN),                            0117.000
  122.      $        WAIT=.FALSE.,                                             0118.000
  123.      $        IOSTAT=IOS, ERR=910)                                      0119.000
  124.         CTDEV(OPEN) = .TRUE.                                            0120.000
  125.         FREQ(OPEN) = 133                                                0121.000
  126. C                                                                       0122.000
  127. C must be file                                                          0123.000
  128. C                                                                       0124.000
  129.       ELSE                                                              0125.000
  130. C       IF (FMODE(OPEN) .EQ. RD) THEN                                   0126.000
  131. C         FILESTAT='OLD'                                                0127.000
  132. C         OPENMODE = .TRUE.                                             0128.000
  133. C       ELSE                                                            0129.000
  134. C         FILESTAT='UNKNOWN'                                            0130.000
  135. C         OPENMODE = .FALSE.                                            0131.000
  136. C       ENDIF                                                           0132.000
  137. C       OPEN(UNIT=OPEN, FILE=FNAME(OPEN),                               0133.000
  138. C    $         BLOCKED=.FALSE., FORM='FORMATTED',                       0134.000
  139. C    $         WAIT=.FALSE.,STATUS=FILESTAT,                            0135.000
  140. C    $         READONLY = OPENMODE,                                     0136.000
  141. C    $         IOSTAT=IOS, ERR=910)                                     0137.000
  142.       CALL M:DALOC(OPEN)                                                0138.000
  143.       CALL M:ALOC1(OPEN,FNAME(OPEN),$910,,.TRUE.,,IOS)                  0139.000
  144.       CALL M:OPEN(OPEN)                                                 0140.000
  145.       ENDIF                                                             0141.000
  146.       CALL BLKINIT(OPEN)                                                0142.000
  147.       RETURN                                                            0143.000
  148. C                                                                       0144.000
  149. C open error                                                            0145.000
  150. C                                                                       0146.000
  151.  910  CONTINUE                                                          0147.000
  152.       FMODE(OPEN) = CLOSED                                              0148.000
  153.       OPEN = -IOS                                                       0149.000
  154. X     WRITE(19,1001)                                                    0149.100
  155. X1001 FORMAT (' OPEN ERROR ')                                           0149.200
  156.       RETURN                                                            0150.000
  157.       END                                                               0151.000
  158.       SUBROUTINE BLKINIT(FD)                                            0152.000
  159.            IMPLICIT NONE                                                0153.000
  160.            INTEGER    FD           !file descriptor                     0154.000
  161. C                                                                       0155.000
  162. C= Calls fcbinit with proper function code for current flags            0156.000
  163. C                                                                       0157.000
  164.       INCLUDE      K.FILEC                                              0158.000
  165. C                                                                       0159.000
  166.       INTEGER      FUNC            !function code                       0160.000
  167.       INTEGER      NOWAITW/X'80000000'/  !nowait operation              0161.000
  168.       INTEGER      DFI    /X'20000000'/  !use io spec we specify        0162.000
  169.       INTEGER      XXWORD /X'00100000'/  !xon/xoff protocol             0163.000
  170.       INTEGER      EXP    /X'02000000'/  !expanded fcb                  0164.000
  171.       INTEGER      NOERR  /X'40000000'/  !no error branch               0165.000
  172.       INTEGER      CONTROL/X'00800000'/  !control character detect      0166.000
  173.       INTEGER      NOECHO /X'00400000'/  !do not echo down port         0167.000
  174.       INTEGER      NOUPPER/X'00200000'/  !do not convert to upper case  0168.000
  175.       INTEGER      SPCHRW /X'00100000'/  !special character detect      0169.000
  176.       INTEGER      PURGEW /X'00080000'/  !purge type ahead buffer       0170.000
  177. C                                                                       0171.000
  178.       IF (CTDEV(FD)) THEN                                               0172.000
  179.         IF (FMODE(FD) .EQ. RD) THEN                                     0173.000
  180.           IF (BINARY(FD)) THEN                                          0174.000
  181.             FUNC = NOERR + EXP + DFI + CONTROL + NOECHO + NOUPPER       0175.000
  182.           ELSE                                                          0176.000
  183.             FUNC = NOERR + EXP                                          0177.000
  184.           ENDIF                                                         0178.000
  185.         ELSE       !write                                               0179.000
  186.           FUNC = NOERR + EXP + DFI                                      0180.000
  187.         ENDIF                                                           0181.000
  188.       ELSE         !disk read/write                                     0182.000
  189.         FUNC = NOERR + EXP                                              0183.000
  190.       ENDIF                                                             0184.000
  191.       IF (NOWAIT(FD)) FUNC = FUNC + NOWAITW                             0185.000
  192.       CALL FCBINIT(FD, FBLK(1, FD), FUNC, FREQ(FD))                     0186.000
  193.       RETURN                                                            0187.000
  194.       END                                                               0188.000
  195.       SUBROUTINE CLOSE(FD)                                              0189.000
  196.            IMPLICIT NONE                                                0190.000
  197.            INTEGER    FD           !file descriptor                     0191.000
  198. C                                                                       0192.000
  199. C= Closes an opened file.                                               0193.000
  200. C                                                                       0194.000
  201.       INCLUDE      K.FILEC                                              0195.000
  202. C                                                                       0196.000
  203.       IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN                          0197.000
  204.         CONTINUE                   !ignore errors                       0198.000
  205.       ELSE IF (FMODE(FD) .EQ. CLOSED) THEN                              0199.000
  206.         CONTINUE                   !already closed                      0200.000
  207.       ELSE                                                              0201.000
  208.         CALL FLUSH(FD)                                                  0202.000
  209.         CLOSE(UNIT=FD)                                                  0203.000
  210.         FMODE(FD) = CLOSED                                              0204.000
  211.       ENDIF                                                             0205.000
  212.       RETURN                                                            0206.000
  213.       END                                                               0207.000
  214.       SUBROUTINE FLUSH(FD)                                              0208.000
  215.            IMPLICIT NONE                                                0209.000
  216.            INTEGER   FD            !file descriptor                     0210.000
  217. C                                                                       0211.000
  218. C= forces output of buffer                                              0212.000
  219. C                                                                       0213.000
  220.       INCLUDE      K.FILEC                                              0214.000
  221. C                                                                       0215.000
  222.       INTEGER*1    LBUF(MAXCH,  MAXFILE)  !local buffers for nowait     0216.000
  223.       INTEGER      I                                                    0217.000
  224. C                                                                       0218.000
  225.       IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN                          0219.000
  226.         RETURN                                                          0220.000
  227.       ELSE IF (FMODE(FD) .EQ. CLOSED) THEN                              0221.000
  228.         RETURN                                                          0222.000
  229.       ELSE                                                              0223.000
  230.         IF (FMODE(FD) .EQ. WR .AND. FCHCNT(FD) .GT. 0) THEN             0224.000
  231.           IF (IOPEND(FD) .EQ. NOIO) THEN                                0225.000
  232.             IF (NOWAIT(FD)) THEN                                        0226.000
  233.               IOPEND(FD) = IOSTART                                      0227.000
  234.               DO I=1, FCHCNT(FD)                                        0228.000
  235.                 LBUF(I, FD) = FCHBUF(I, FD)                             0229.000
  236.               ENDDO                                                     0230.000
  237.               GOTO (10,20,30,40,50,60,70,80,90,100) FD                  0231.000
  238.  10           CONTINUE                                                  0232.000
  239.               CALL DPWRITE(FBLK(1, FD), LBUF(1,FD), FCHCNT(FD), 0,      0233.000
  240.      $           *801, *801)                                            0234.000
  241.               GOTO 150                                                  0235.000
  242.  20           CONTINUE                                                  0236.000
  243.               CALL DPWRITE(FBLK(1, FD), LBUF(1,FD), FCHCNT(FD), 0,      0237.000
  244.      $           *802, *802)                                            0238.000
  245.               GOTO 150                                                  0239.000
  246.  30           CONTINUE                                                  0240.000
  247.               CALL DPWRITE(FBLK(1, FD), LBUF(1,FD), FCHCNT(FD), 0,      0241.000
  248.      $           *803, *803)                                            0242.000
  249.               GOTO 150                                                  0243.000
  250.  40           CONTINUE                                                  0244.000
  251.               CALL DPWRITE(FBLK(1, FD), LBUF(1,FD), FCHCNT(FD), 0,      0245.000
  252.      $           *804, *804)                                            0246.000
  253.               GOTO 150                                                  0247.000
  254.  50           CONTINUE                                                  0248.000
  255.               CALL DPWRITE(FBLK(1, FD), LBUF(1,FD), FCHCNT(FD), 0,      0249.000
  256.      $           *805, *805)                                            0250.000
  257.               GOTO 150                                                  0251.000
  258.  60           CONTINUE                                                  0252.000
  259.               CALL DPWRITE(FBLK(1, FD), LBUF(1,FD), FCHCNT(FD), 0,      0253.000
  260.      $           *806, *806)                                            0254.000
  261.               GOTO 150                                                  0255.000
  262.  70           CONTINUE                                                  0256.000
  263.               CALL DPWRITE(FBLK(1, FD), LBUF(1,FD), FCHCNT(FD), 0,      0257.000
  264.      $           *807, *807)                                            0258.000
  265.               GOTO 150                                                  0259.000
  266.  80           CONTINUE                                                  0260.000
  267.               CALL DPWRITE(FBLK(1, FD), LBUF(1,FD), FCHCNT(FD), 0,      0261.000
  268.      $           *808, *808)                                            0262.000
  269.               GOTO 150                                                  0263.000
  270.  90           CONTINUE                                                  0264.000
  271.               CALL DPWRITE(FBLK(1, FD), LBUF(1,FD), FCHCNT(FD), 0,      0265.000
  272.      $           *809, *809)                                            0266.000
  273.               GOTO 150                                                  0267.000
  274.  100           CONTINUE                                                 0268.000
  275.               CALL DPWRITE(FBLK(1, FD), LBUF(1,FD), FCHCNT(FD), 0,      0269.000
  276.      $           *810, *810)                                            0270.000
  277.               GOTO 150                                                  0271.000
  278.  150          CONTINUE                                                  0272.000
  279.             ELSE                                                        0273.000
  280.               IOPEND(FD) = NOIO                                         0274.000
  281.               CALL DPWRITE(FBLK(1, FD), FCHBUF(1, FD), FCHCNT(FD), 0)   0275.000
  282.             ENDIF                                                       0276.000
  283.           ENDIF                                                         0277.000
  284.         ELSE IF (FMODE(FD) .EQ. RD .AND. IOPEND(FD) .EQ. IOSTART) THEN  0278.000
  285.           CALL HIO(FD)                                                  0279.000
  286. CLT       DO I=1, MAXFILE                                               0280.000
  287. CLT         IF (FMODE(I) .EQ. WR .AND. IOPEND(I) .EQ. IOSTART)          0281.000
  288. CLT  $        CALL X:EAWAIT(0,,)                                        0282.000
  289. CLT         IF (IOPEND(I) .EQ. IOSTART) IOPEND(I) = NOIO                0283.000
  290. CLT       ENDDO                                                         0284.000
  291. CLT       CALL HIOALL              !this is going to hurt somewhere     0285.000
  292.         ENDIF                                                           0286.000
  293.         FCHPTR(FD) = 1                                                  0287.000
  294.         FCHCNT(FD) = 0                                                  0288.000
  295.       ENDIF                                                             0289.000
  296.       RETURN                                                            0290.000
  297. C                                                                       0291.000
  298. C end action                                                            0292.000
  299. C                                                                       0293.000
  300.  801  IOPEND( 1) = NOIO; CALL X:XNWIO                                   0294.000
  301.  802  IOPEND( 2) = NOIO; CALL X:XNWIO                                   0295.000
  302.  803  IOPEND( 3) = NOIO; CALL X:XNWIO                                   0296.000
  303.  804  IOPEND( 4) = NOIO; CALL X:XNWIO                                   0297.000
  304.  805  IOPEND( 5) = NOIO; CALL X:XNWIO                                   0298.000
  305.  806  IOPEND( 6) = NOIO; CALL X:XNWIO                                   0299.000
  306.  807  IOPEND( 7) = NOIO; CALL X:XNWIO                                   0300.000
  307.  808  IOPEND( 8) = NOIO; CALL X:XNWIO                                   0301.000
  308.  809  IOPEND( 9) = NOIO; CALL X:XNWIO                                   0302.000
  309.  810  IOPEND(10) = NOIO; CALL X:XNWIO                                   0303.000
  310.       END                                                               0304.000
  311.       SUBROUTINE PUTC(FD, TCH)                                          0305.000
  312.            IMPLICIT NONE                                                0306.000
  313.            INTEGER    FD     !file descriptor                           0307.000
  314.            INTEGER    TCH    !character to output                       0308.000
  315. C                                                                       0309.000
  316. C= outputs a character                                                  0310.000
  317. C                                                                       0311.000
  318. C **** NOTE: tricky stuff, no difference between terminal               0312.000
  319. C      outputs in binary or ascii, but in binary NEL's are              0313.000
  320. C      not interpreted.  So don't put term in binary unless             0314.000
  321. C      you really mean it.                                              0315.000
  322. C                                                                       0316.000
  323. C                                                                       0317.000
  324.       INCLUDE      K.FILEC                                              0318.000
  325. C                                                                       0319.000
  326.       INTEGER      CH                                                   0320.000
  327.       INTEGER      I                                                    0321.000
  328. C                                                                       0322.000
  329.       IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN                          0323.000
  330.         CONTINUE                                                        0324.000
  331.       ELSE IF (FMODE(FD) .EQ. WR) THEN                                  0325.000
  332.         CH = TCH                                                        0326.000
  333.         IF (.NOT. BINARY(FD) .AND. TCH .EQ. NEL) THEN                   0327.000
  334.           CH = CR                                                       0328.000
  335.           IF (.NOT. CTDEV(FD)) GOTO 20                                  0329.000
  336.         ENDIF                                                           0330.000
  337.  10     CONTINUE                                                        0331.000
  338.         IF (FCHCNT(FD) .GE. FREQ(FD)) CALL FLUSH(FD)                    0332.000
  339.         IF (FCHCNT(FD) .LT. MAXCH) THEN                                 0333.000
  340.           FCHCNT(FD) = FCHCNT(FD) + 1                                   0334.000
  341.           FCHBUF(FCHCNT(FD), FD) = CH                                   0335.000
  342.         ENDIF                                                           0336.000
  343.         IF (FCHCNT(FD) .GE. FREQ(FD)) CALL FLUSH(FD)                    0337.000
  344.         IF (TCH .EQ. NEL .AND. CH .EQ. CR) THEN                         0338.000
  345.           CH = LF                                                       0339.000
  346.           GOTO 10                                                       0340.000
  347.         ENDIF                                                           0341.000
  348.  20     CONTINUE                                                        0342.000
  349. C                                                                       0343.000
  350. C end of line processing                                                0344.000
  351. C                                                                       0345.000
  352.         IF (.NOT. BINARY(FD) .AND. TCH .EQ. NEL) THEN                   0346.000
  353. C                                                                       0347.000
  354. C if text file, strip trailing blanks, cr, lf                           0348.000
  355. C                                                                       0349.000
  356.           IF (.NOT. CTDEV(FD)) THEN                                     0350.000
  357.             I = FCHCNT(FD)                                              0351.000
  358.             DO WHILE (I .GT. 0)                                         0352.000
  359.               IF (FCHBUF(I, FD) .EQ. BLANK .OR. FCHBUF(I, FD) .EQ.      0353.000
  360.      $            CR .OR. FCHBUF(I, FD) .EQ. LF) THEN                   0354.000
  361.                 I = I - 1                                               0355.000
  362.               ELSE                                                      0356.000
  363.                 LEAVE                                                   0357.000
  364.               ENDIF                                                     0358.000
  365.             ENDDO                                                       0359.000
  366.             IF (I .LE. 0) THEN                                          0360.000
  367.               I = I + 1                                                 0361.000
  368.               FCHBUF(I, FD) = BLANK                                     0362.000
  369.             ENDIF                                                       0363.000
  370.             FCHCNT(FD) = I                                              0364.000
  371.           ENDIF                                                         0365.000
  372.           CALL FLUSH(FD)                   !force out                   0366.000
  373.         ENDIF                                                           0367.000
  374.       ENDIF                                                             0368.000
  375.       RETURN                                                            0369.000
  376.       END                                                               0370.000
  377.       INTEGER FUNCTION GETC(FD, CH)                                     0371.000
  378.            IMPLICIT NONE                                                0372.000
  379.            INTEGER    FD           !file descriptor                     0373.000
  380.            INTEGER    CH           !character read in                   0374.000
  381. C                                                                       0375.000
  382. C= Reads a character from input buffer, reads if necessary              0376.000
  383. C                                                                       0377.000
  384.       INCLUDE      K.FILEC                                              0378.000
  385. C                                                                       0379.000
  386.       IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN                          0380.000
  387.         CH = ERROR                                                      0381.000
  388.       ELSE IF (FMODE(FD) .EQ. RD) THEN                                  0382.000
  389.         IF (FCHPTR(FD) .GT. FCHCNT(FD)) CALL FILL(FD)                   0383.000
  390.         IF (FEOF(FD)) THEN                                              0384.000
  391.           CH = EOF                                                      0385.000
  392.         ELSE IF (FCHPTR(FD) .GT. FCHCNT(FD)) THEN                       0386.000
  393.           CH = ERROR                                                    0387.000
  394.         ELSE                                                            0388.000
  395.           CH = FCHBUF(FCHPTR(FD), FD)                                   0389.000
  396.           FCHPTR(FD) = FCHPTR(FD) + 1                                   0390.000
  397.         ENDIF                                                           0391.000
  398.       ELSE                                                              0392.000
  399.         CH = ERROR                                                      0393.000
  400.       ENDIF                                                             0394.000
  401.       GETC = CH                                                         0395.000
  402.       RETURN                                                            0396.000
  403.       END                                                               0397.000
  404.       SUBROUTINE FILL(FD)                                               0398.000
  405.            IMPLICIT NONE                                                0399.000
  406.            INTEGER    FD   !file descriptor                             0400.000
  407. C                                                                       0401.000
  408. C= Fills the respective fd's buffer                                     0402.000
  409. C                                                                       0403.000
  410.       INCLUDE      K.FILEC                                              0404.000
  411. C                                                                       0405.000
  412.       INTEGER      STATUS          !status of io done                   0406.000
  413.       INTEGER      I               !temp count                          0407.000
  414. C                                                                       0408.000
  415.       INTEGER      DPCOUNT         !retreive count of transfer          0409.000
  416.       INTEGER      DERROR          !error code                          0410.000
  417. C                                                                       0411.000
  418.       IF (IOPEND(FD) .EQ. NOIO) THEN                                    0412.000
  419.         IF (NOWAIT(FD)) THEN                                            0413.000
  420.           IOPEND(FD) = IOSTART                                          0414.000
  421.           GOTO (10, 20, 30, 40, 50, 60, 70, 80, 90, 100) FD             0415.000
  422.  10       CONTINUE                                                      0416.000
  423.             CALL DPREAD(FBLK(1,FD),FCHBUF(1,FD),FREQ(FD), 0,*801,*801)  0417.000
  424.             GOTO 150                                                    0418.000
  425.  20      CONTINUE                                                       0419.000
  426.             CALL DPREAD(FBLK(1,FD),FCHBUF(1,FD),FREQ(FD), 0,*802,*802)  0420.000
  427.             GOTO 150                                                    0421.000
  428.  30       CONTINUE                                                      0422.000
  429.             CALL DPREAD(FBLK(1,FD),FCHBUF(1,FD),FREQ(FD), 0,*803,*803)  0423.000
  430.             GOTO 150                                                    0424.000
  431.  40      CONTINUE                                                       0425.000
  432.             CALL DPREAD(FBLK(1,FD),FCHBUF(1,FD),FREQ(FD), 0,*804,*804)  0426.000
  433.             GOTO 150                                                    0427.000
  434.  50      CONTINUE                                                       0428.000
  435.             CALL DPREAD(FBLK(1,FD),FCHBUF(1,FD),FREQ(FD), 0,*805,*805)  0429.000
  436.             GOTO 150                                                    0430.000
  437.  60       CONTINUE                                                      0431.000
  438.             CALL DPREAD(FBLK(1,FD),FCHBUF(1,FD),FREQ(FD), 0,*806,*806)  0432.000
  439.             GOTO 150                                                    0433.000
  440.  70      CONTINUE                                                       0434.000
  441.             CALL DPREAD(FBLK(1,FD),FCHBUF(1,FD),FREQ(FD), 0,*807,*807)  0435.000
  442.             GOTO 150                                                    0436.000
  443.  80      CONTINUE                                                       0437.000
  444.             CALL DPREAD(FBLK(1,FD),FCHBUF(1,FD),FREQ(FD), 0,*808,*808)  0438.000
  445.             GOTO 150                                                    0439.000
  446.  90       CONTINUE                                                      0440.000
  447.             CALL DPREAD(FBLK(1,FD),FCHBUF(1,FD),FREQ(FD), 0,*809,*809)  0441.000
  448.             GOTO 150                                                    0442.000
  449.  100     CONTINUE                                                       0443.000
  450.             CALL DPREAD(FBLK(1,FD),FCHBUF(1,FD),FREQ(FD), 0,*810,*810)  0444.000
  451.             GOTO 150                                                    0445.000
  452.  150      CONTINUE                                                      0446.000
  453.           IF (FTIMOUT(FD) .GT. 0) THEN                                  0447.000
  454.             CALL X:EAWAIT(-FTIMOUT(FD)*10,,)                            0448.000
  455.             IF (IOPEND(FD) .EQ. IOSTART) THEN                           0449.000
  456.               CALL HIO(FD)                                              0450.000
  457.               CALL X:EAWAIT(-FTIMOUT(FD)*10,,)                          0451.000
  458.             ENDIF                                                       0452.000
  459.           ENDIF                                                         0453.000
  460.         ELSE                                                            0454.000
  461.           CALL DPREAD(FBLK(1, FD), FCHBUF(1, FD), FREQ(FD), 0)          0455.000
  462.           IOPEND(FD) = IOCOMP                                           0456.000
  463.         ENDIF                                                           0457.000
  464.       ENDIF                                                             0458.000
  465.       IF (IOPEND(FD) .EQ. IOCOMP) THEN                                  0459.000
  466.         IOPEND(FD) = NOIO                                               0460.000
  467.         FCHPTR(FD) =1                                                   0461.000
  468.         FCHCNT(FD) = DPCOUNT(FBLK(1, FD))                               0462.000
  469.         IF (.NOT. BINARY(FD)) THEN                                      0463.000
  470.           IF (CTDEV(FD)) THEN                                           0464.000
  471.             FCHCNT(FD) = FCHCNT(FD) + 1                                 0465.000
  472.             FCHBUF(FCHCNT(FD), FD) = NEL                                0466.000
  473.           ELSE                                                          0467.000
  474.             I = FCHCNT(FD)                                              0468.000
  475.             DO WHILE (I .GT. 0)                                         0469.000
  476.               IF (FCHBUF(I,FD) .EQ. BLANK) THEN                         0470.000
  477.                 I = I - 1                                               0471.000
  478.               ELSE                                                      0472.000
  479.                 LEAVE                                                   0473.000
  480.               ENDIF                                                     0474.000
  481.             ENDDO                                                       0475.000
  482.             I = I + 1                                                   0476.000
  483.             FCHBUF(I, FD) = NEL                                         0477.000
  484.             FCHCNT(FD) = I                                              0478.000
  485.           ENDIF                                                         0479.000
  486.         ENDIF                                                           0480.000
  487.         STATUS = DERROR(FBLK(1, FD))                                    0481.000
  488.         IF (STATUS .EQ. 3 .OR. STATUS .EQ. 4) FEOF(FD) = .TRUE.         0482.000
  489.       ENDIF                                                             0483.000
  490.       RETURN                                                            0484.000
  491. C                                                                       0485.000
  492. C end action                                                            0486.000
  493. C                                                                       0487.000
  494.  801  IOPEND(1) = IOCOMP; CALL X:XNWIO                                  0488.000
  495.  802  IOPEND(2) = IOCOMP; CALL X:XNWIO                                  0489.000
  496.  803  IOPEND(3) = IOCOMP; CALL X:XNWIO                                  0490.000
  497.  804  IOPEND(4) = IOCOMP; CALL X:XNWIO                                  0491.000
  498.  805  IOPEND(5) = IOCOMP; CALL X:XNWIO                                  0492.000
  499.  806  IOPEND(6) = IOCOMP; CALL X:XNWIO                                  0493.000
  500.  807  IOPEND(7) = IOCOMP; CALL X:XNWIO                                  0494.000
  501.  808  IOPEND(8) = IOCOMP; CALL X:XNWIO                                  0495.000
  502.  809  IOPEND(9) = IOCOMP; CALL X:XNWIO                                  0496.000
  503.  810  IOPEND(10)= IOCOMP; CALL X:XNWIO                                  0497.000
  504.       END                                                               0498.000
  505.       SUBROUTINE STTY(FD, FIELD, VALUE)                                 0499.000
  506.            IMPLICIT NONE                                                0500.000
  507.            INTEGER    FD    !port to set                                0501.000
  508.            CHARACTER*(*) FIELD    !field to set                         0502.000
  509.            INTEGER       VALUE     !value to set to                     0503.000
  510. C                                                                       0504.000
  511. C= Sets the specified field to the value                                0505.000
  512. C                                                                       0506.000
  513.       INCLUDE      K.KERMV                                              0507.000
  514.       INCLUDE      K.FILEC                                              0508.000
  515.       LOGICAL*1    TTYECHO(MAXFILE)  !local memory for echo             0509.000
  516. C                                                                       0510.000
  517.       LOGICAL      TUDT            !test user device table              0511.000
  518. C                                                                       0512.000
  519. C                                                                       0513.000
  520. X     WRITE(19,1000)FIELD,VALUE,MAXCH                                   0513.100
  521. X1000 FORMAT(1X,1A8,2X,2(1X,1Z8))                                       0513.200
  522.       IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN                          0514.000
  523.         CONTINUE                                                        0515.000
  524.       ELSE IF (FMODE(FD)  .EQ. CLOSED) THEN                             0516.000
  525.         CONTINUE                                                        0517.000
  526. C                                                                       0518.000
  527. C binary mode                                                           0519.000
  528. C                                                                       0520.000
  529.       ELSE IF (FIELD .EQ. 'BINARY') THEN                                0521.000
  530.         BINARY(FD) = VALUE .EQ. 1                                       0522.000
  531.         CALL BLKINIT(FD)                                                0523.000
  532. C                                                                       0524.000
  533. C TIMEOUT                                                               0525.000
  534. C                                                                       0526.000
  535.       ELSE IF (FIELD .EQ. 'TIMEOUT') THEN                               0527.000
  536.         FTIMOUT(FD) = VALUE                                             0528.000
  537. C                                                                       0529.000
  538. C nowait                                                                0530.000
  539. C                                                                       0531.000
  540.       ELSE IF (FIELD .EQ. 'NOWAIT') THEN                                0532.000
  541.         NOWAIT(FD) = VALUE .EQ. 1                                       0533.000
  542.         CALL BLKINIT(FD)                                                0534.000
  543.         IF (FMODE(FD) .EQ. RD) THEN                                     0535.000
  544. C                                                                       0536.000
  545. C This section is used to enable timeouts since                         0537.000
  546. C gould doesn't support a timeout on a normal read.                     0538.000
  547. C You must be privileged to do this stuff                               0539.000
  548. C                                                                       0540.000
  549.           IF (LOCALON) THEN                                             0541.000
  550.             IF (NOWAIT(FD)) THEN                                        0542.000
  551. C                                                                       0543.000
  552. CLT 2.3 CORRECTED TURNING ECHO ON AND OFF                               0544.000
  553. C In this section (which incidentially must be called first) we         0545.000
  554. C memorize the previous condition of the udt so we can restore          0546.000
  555. C it to correct mode.  This is part of rev. 2.3.  This feature          0547.000
  556. C is particularly important for those using a network for file          0548.000
  557. C transmittal since they don't have echo on any way.                    0549.000
  558. C                                                                       0550.000
  559.               TTYECHO(FD) = TUDT(FBLK(1, FD), 'ECHO')                   0551.000
  560.               IF (TTYECHO(FD)) THEN                                     0552.000
  561.                 CALL SUDT(FBLK(1, FD), 'NOEC')    !make sure            0553.000
  562.               ENDIF                                                     0554.000
  563.               CALL SUDT(FBLK(1, FD), 'DUAL')                            0555.000
  564.             ELSE                                                        0556.000
  565.               CALL SUDT(FBLK(1, FD), 'SING')                            0557.000
  566.               IF (TTYECHO(FD)) THEN                                     0558.000
  567.                 CALL SUDT(FBLK(1, FD), 'ECHO')    !may be right         0559.000
  568.               ENDIF                                                     0560.000
  569.             ENDIF                                                       0561.000
  570.           ENDIF                                                         0562.000
  571.         ENDIF                                                           0563.000
  572. C                                                                       0564.000
  573. C readsize                                                              0565.000
  574. C                                                                       0566.000
  575.       ELSE IF (FIELD .EQ. 'SIZE') THEN                                  0567.000
  576.         IF (VALUE .GT. 0) THEN                                          0568.000
  577.           FREQ(FD) = VALUE                                              0569.000
  578.         ELSE                                                            0570.000
  579.           FREQ(FD) = MAXCH                                              0571.000
  580.         ENDIF                                                           0572.000
  581.         IF (FREQ(FD) .GT. MAXCH) FREQ(FD) = MAXCH                       0573.000
  582.         CALL BLKINIT(FD)                                                0574.000
  583. C                                                                       0575.000
  584. C unrecognized field                                                    0576.000
  585. C                                                                       0577.000
  586.       ELSE                                                              0578.000
  587.         CONTINUE                                                        0579.000
  588.       ENDIF                                                             0580.000
  589.       RETURN                                                            0581.000
  590.       END                                                               0582.000
  591.       SUBROUTINE UNGETC(FD, CH)                                         0583.000
  592.            IMPLICIT NONE                                                0584.000
  593.            INTEGER   FD            !file descriptor                     0585.000
  594.            INTEGER   CH            !character put back                  0586.000
  595. C                                                                       0587.000
  596. C= Try to put a character back into the input stream                    0588.000
  597. C                                                                       0589.000
  598. C  Ungetc can only put back characters as far as the beginning          0590.000
  599. C  of the buffer.  Hopefully, this is ok, since only getword            0591.000
  600. C  does this with an nel which should be well into the buffer.          0592.000
  601. C                                                                       0593.000
  602.       INCLUDE      K.FILEC                                              0594.000
  603. C                                                                       0595.000
  604.       IF (FCHPTR(FD) .GT. 1) THEN                                       0596.000
  605.         FCHPTR(FD) = FCHPTR(FD) - 1                                     0597.000
  606.         FCHBUF(FCHPTR(FD), FD) = CH                                     0598.000
  607.       ENDIF                                                             0599.000
  608.       RETURN                                                            0600.000
  609.       END                                                               0601.000
  610.       INTEGER FUNCTION GETWORD(FD, STR, MAXLEN)                         0602.000
  611.            IMPLICIT NONE                                                0603.000
  612.            INTEGER    FD   !file descriptor                             0604.000
  613.            INTEGER    STR(*)  !string to read to                        0605.000
  614.            INTEGER    MAXLEN !max size of string                        0606.000
  615. C                                                                       0607.000
  616. C= get a word from an input stream                                      0608.000
  617. C                                                                       0609.000
  618. C  Getword considers a word to be delimited by blanks.                  0610.000
  619. C  It will return the length of the word as its value.                  0611.000
  620. C                                                                       0612.000
  621.       INCLUDE      K.FILEC                                              0613.000
  622. C                                                                       0614.000
  623.       INTEGER      LEN             !length of string                    0615.000
  624.       INTEGER      CH              !character                           0616.000
  625. C                                                                       0617.000
  626.       INTEGER      GETC            !get character                       0618.000
  627. C                                                                       0619.000
  628.       LEN = 0                                                           0620.000
  629. C                                                                       0621.000
  630. C skip leading white space                                              0622.000
  631. C                                                                       0623.000
  632.  10   CONTINUE                                                          0624.000
  633.       IF (GETC(FD, CH) .EQ. EOF) THEN                                   0625.000
  634.         GETWORD = EOF                                                   0626.000
  635.         RETURN                                                          0627.000
  636.       ELSE IF (CH .EQ. NEL) THEN                                        0628.000
  637.         GETWORD = 0                                                     0629.000
  638.         RETURN                                                          0630.000
  639.       ENDIF                                                             0631.000
  640.       IF (CH .EQ. BLANK .OR. CH .EQ. TAB) GOTO 10                       0632.000
  641. C                                                                       0633.000
  642. C found first character, so keep going                                  0634.000
  643. C                                                                       0635.000
  644.       DO WHILE (.NOT. (CH .EQ. EOF .OR. CH .EQ. BLANK .OR.              0636.000
  645.      $                 CH .EQ. TAB .OR. CH .EQ. NEL) .AND.              0637.000
  646.      $                 LEN .LT. MAXLEN)                                 0638.000
  647.         LEN = LEN + 1                                                   0639.000
  648.         STR(LEN) = CH                                                   0640.000
  649.         CH = GETC(FD, CH)                                               0641.000
  650.       ENDDO                                                             0642.000
  651. C                                                                       0643.000
  652. C save eols for next getword                                            0644.000
  653. C                                                                       0645.000
  654.       IF (CH .EQ. NEL) CALL UNGETC(FD, CH)                              0646.000
  655.       STR(LEN+1) = 0                                                    0647.000
  656.       GETWORD = LEN                                                     0648.000
  657.       RETURN                                                            0649.000
  658.       END                                                               0650.000
  659.       SUBROUTINE PUTSTR(FD, STR)                                        0651.000
  660.            IMPLICIT NONE                                                0652.000
  661.            INTEGER   FD                                                 0653.000
  662.            INTEGER  STR(*)   !string to read                            0654.000
  663. C                                                                       0655.000
  664. C= Output a string to an output stream                                  0656.000
  665. C                                                                       0657.000
  666.       INCLUDE      K.FILEC                                              0658.000
  667. C                                                                       0659.000
  668.       INTEGER      I                                                    0660.000
  669. C                                                                       0661.000
  670.       IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN                          0662.000
  671.       ELSE IF (FMODE(FD) .EQ. WR) THEN                                  0663.000
  672.         I = 1                                                           0664.000
  673.         DO WHILE (STR(I) .NE. 0)                                        0665.000
  674.           CALL PUTC(FD, STR(I))                                         0666.000
  675.           I = I + 1                                                     0667.000
  676.         ENDDO                                                           0668.000
  677.       ENDIF                                                             0669.000
  678.       RETURN                                                            0670.000
  679.       END                                                               0671.000
  680.       SUBROUTINE PUTINT (FD, INT, MINWID)                               0672.000
  681.            IMPLICIT NONE                                                0673.000
  682.            INTEGER    FD                                                0674.000
  683.            INTEGER    INT                                               0675.000
  684.            INTEGER    MINWID       !minimum width                       0676.000
  685. C                                                                       0677.000
  686. C= Output an integer                                                    0678.000
  687. C                                                                       0679.000
  688.       INCLUDE      K.KERMD                                              0680.000
  689. C                                                                       0681.000
  690.       INTEGER      WIDTH                                                0682.000
  691.       INTEGER      VAL                                                  0683.000
  692.       INTEGER      ASCIIO                                               0684.000
  693.       INTEGER      NCH             !number of characters                0685.000
  694.       INTEGER      STRING(21)                                           0686.000
  695. C                                                                       0687.000
  696.       INTRINSIC    ICHAR                                                0688.100
  697. C     INTEGER      ICHAR                                                0688.200
  698.       INTEGER      IABS                                                 0689.000
  699.       INTEGER      MOD                                                  0690.000
  700. C                                                                       0691.000
  701.       WIDTH = 0                                                         0692.000
  702.       IF (INT .LT. 0) THEN                                              0693.000
  703.         CALL PUTC(FD, ICHAR('-'))                                       0694.000
  704.         WIDTH = 1                                                       0695.000
  705.       ENDIF                                                             0696.000
  706.       VAL = IABS(INT)                                                   0697.000
  707.       ASCIIO = ICHAR('0')                                               0698.000
  708.       NCH = 0                                                           0699.000
  709.       DO UNTIL (VAL .EQ. 0 .OR. NCH .GE. 20)                            0700.000
  710.         NCH = NCH + 1                                                   0701.000
  711.         STRING(NCH) = MOD(VAL, 10) + ASCIIO                             0702.000
  712.         VAL = VAL/10                                                    0703.000
  713.       ENDDO                                                             0704.000
  714.       WIDTH = WIDTH + NCH                                               0705.000
  715. C                                                                       0706.000
  716. C now output the digits                                                 0707.000
  717. C                                                                       0708.000
  718.       DO UNTIL (NCH .LE. 0)                                             0709.000
  719.         CALL PUTC(FD, STRING(NCH))                                      0710.000
  720.         NCH = NCH - 1                                                   0711.000
  721.       ENDDO                                                             0712.000
  722.       DO WHILE (WIDTH .LT. MINWID)                                      0713.000
  723.         CALL PUTC(FD, BLANK)                                            0714.000
  724.         WIDTH = WIDTH + 1                                               0715.000
  725.       ENDDO                                                             0716.000
  726.       RETURN                                                            0717.000
  727.       END                                                               0718.000
  728.       SUBROUTINE PUTDAY(FD, MM, DD, YY)                                 0719.000
  729.            IMPLICIT NONE                                                0720.000
  730.            INTEGER   FD                                                 0721.000
  731.            INTEGER   MM, DD, YY                                         0722.000
  732. C                                                                       0723.000
  733. C= Output day of week                                                   0724.000
  734. C                                                                       0725.000
  735.       INTEGER      IZLR                                                 0726.000
  736.       INTEGER      IMN                                                  0727.000
  737.       INTEGER      IYR                                                  0728.000
  738.       INTEGER      IDY                                                  0729.000
  739.       INTEGER      WKDAY                                                0730.000
  740. C                                                                       0731.000
  741. C day of week function!                                                 0732.000
  742. C                                                                       0733.000
  743.       IZLR (IYR, IMN, IDY) = MOD((13*(IMN+10-(IMN+10)/13*12)-1)/5+      0734.000
  744.      $    IDY+77+5*(IYR+(IMN-14)/12-(IYR+(IMN-14)/12)/100*100)/4+       0735.000
  745.      $    (IYR+(IMN-14)/12)/400-(IYR+(IMN-14)/12)/100*2,7)+1            0736.000
  746. C                                                                       0737.000
  747.       WKDAY = IZLR(YY, MM, DD)                                          0738.000
  748.       IF (WKDAY .EQ. 1) THEN                                            0739.000
  749.         CALL PRINT(FD, 'Sunday')                                        0740.000
  750.       ELSE IF (WKDAY .EQ. 2) THEN                                       0741.000
  751.         CALL PRINT(FD, 'Monday')                                        0742.000
  752.       ELSE IF (WKDAY .EQ. 3) THEN                                       0743.000
  753.         CALL PRINT(FD, 'Tuesday')                                       0744.000
  754.       ELSE IF (WKDAY .EQ. 4) THEN                                       0745.000
  755.         CALL PRINT(FD, 'Wednesday')                                     0746.000
  756.       ELSE IF (WKDAY .EQ. 5) THEN                                       0747.000
  757.         CALL PRINT(FD, 'Thursday')                                      0748.000
  758.       ELSE IF (WKDAY .EQ. 6) THEN                                       0749.000
  759.         CALL PRINT(FD, 'Friday')                                        0750.000
  760.       ELSE                                                              0751.000
  761.         CALL PRINT(FD, 'Saturday')                                      0752.000
  762.       ENDIF                                                             0753.000
  763.       RETURN                                                            0754.000
  764.       END                                                               0755.000
  765.       SUBROUTINE PUTMNTH(FD, MM)                                        0756.000
  766.            IMPLICIT NONE                                                0757.000
  767.            INTEGER   FD                                                 0758.000
  768.            INTEGER   MM                                                 0759.000
  769. C                                                                       0760.000
  770. C= Output the month name.                                               0761.000
  771. C                                                                       0762.000
  772.       IF (MM .EQ. 1) THEN                                               0763.000
  773.         CALL PRINT(FD, 'January')                                       0764.000
  774.       ELSE IF (MM .EQ. 2) THEN                                          0765.000
  775.         CALL PRINT(FD, 'Feburary')                                      0766.000
  776.       ELSE IF (MM .EQ. 3) THEN                                          0767.000
  777.         CALL PRINT(FD, 'March')                                         0768.000
  778.       ELSE IF (MM .EQ. 4) THEN                                          0769.000
  779.         CALL PRINT(FD, 'April')                                         0770.000
  780.       ELSE IF (MM .EQ. 5) THEN                                          0771.000
  781.         CALL PRINT(FD, 'May')                                           0772.000
  782.       ELSE IF (MM .EQ. 6) THEN                                          0773.000
  783.         CALL PRINT(FD, 'June')                                          0774.000
  784.       ELSE IF (MM .EQ. 7) THEN                                          0775.000
  785.         CALL PRINT(FD, 'July')                                          0776.000
  786.       ELSE IF (MM .EQ. 8) THEN                                          0777.000
  787.         CALL PRINT(FD, 'August')                                        0778.000
  788.       ELSE IF (MM .EQ. 9) THEN                                          0779.000
  789.         CALL PRINT(FD, 'September')                                     0780.000
  790.       ELSE IF (MM .EQ. 10) THEN                                         0781.000
  791.         CALL PRINT(FD, 'October')                                       0782.000
  792.       ELSE IF (MM .EQ. 11) THEN                                         0783.000
  793.         CALL PRINT(FD, 'November')                                      0784.000
  794.       ELSE IF (MM .EQ. 12) THEN                                         0785.000
  795.         CALL PRINT(FD, 'December')                                      0786.000
  796.       ELSE                                                              0787.000
  797.         CALL PRINT(FD, 'No such month')                                 0788.000
  798.       ENDIF                                                             0789.000
  799.       RETURN                                                            0790.000
  800.       END                                                               0791.000
  801.       SUBROUTINE PRINT (FD, STR)                                        0792.000
  802.            IMPLICIT NONE                                                0793.000
  803.            INTEGER   FD                                                 0794.000
  804.            CHARACTER*(*)  STR                                           0795.000
  805. C                                                                       0796.000
  806. C= Output character string                                              0797.000
  807. C                                                                       0798.000
  808.       INTEGER      I                                                    0799.000
  809. C                                                                       0800.000
  810.       INTRINSIC    LEN                                                  0801.000
  811.       INTRINSIC    ICHAR                                                0802.100
  812. C     INTEGER      ICHAR                                                0802.200
  813. C                                                                       0803.000
  814.       DO I=1, LEN(STR)                                                  0804.000
  815.         CALL PUTC(FD, ICHAR(STR(I:I)))                                  0805.000
  816.       ENDDO                                                             0806.000
  817.       RETURN                                                            0807.000
  818.       END                                                               0808.000
  819.       SUBROUTINE PRINTL(FD, STR)                                        0809.000
  820.            IMPLICIT NONE                                                0810.000
  821.            INTEGER    FD                                                0811.000
  822.            CHARACTER*(*) STR                                            0812.000
  823. C                                                                       0813.000
  824. C= Output a string with cr/lf at end                                    0814.000
  825. C                                                                       0815.000
  826.       INCLUDE      K.KERMD                                              0816.000
  827. C                                                                       0817.000
  828.       CALL PUTC(FD, NEL)                                                0818.000
  829.       CALL PRINT(FD, STR)                                               0819.000
  830.       CALL FLUSH(FD)                                                    0820.000
  831.       RETURN                                                            0821.000
  832.       END                                                               0822.000
  833.       SUBROUTINE SENDBRK(FD)                                            0823.000
  834.            IMPLICIT NONE                                                0824.000
  835.            INTEGER  FD             !file to break                       0825.000
  836. C                                                                       0826.000
  837. C Sends break to attached port                                          0827.000
  838. C                                                                       0828.000
  839.       INCLUDE      K.FILEC                                              0829.000
  840. C                                                                       0830.000
  841.       INTEGER      BLK(4)          !local block                         0831.000
  842.       INTEGER      BRK             !function that turns on break        0832.000
  843.      $       /X'62800000'/                                              0833.000
  844.       INTEGER      NOBRK           !turn off break                      0834.000
  845.      $       /X'62000000'/         !break turned off                    0835.000
  846. C                                                                       0836.000
  847.       IF (FD .LE. 0 .AND. FD .GE. MAXFILE) THEN                         0837.000
  848.       ELSE IF (.NOT. CTDEV(FD)) THEN                                    0838.000
  849.       ELSE IF (FMODE(FD) .NE. WR) THEN                                  0839.000
  850.       ELSE                                                              0840.000
  851.         CALL FLUSH(FD)                                                  0841.000
  852.         CALL FCBINIT(FD, BLK, BRK, 0)                                   0842.000
  853.         CALL DPWRITE(BLK, 0, 0)                                         0843.000
  854.                                                                         0844.000
  855.         CALL DELAY(60)                                                  0845.000
  856.         CALL FCBINIT(FD, BLK, NOBRK, 0)                                 0846.000
  857.         CALL DPWRITE(BLK, 0, 0)                                         0847.000
  858.         CALL BLKINIT(FD)                                                0848.000
  859.       ENDIF                                                             0849.000
  860.       RETURN                                                            0850.000
  861.       END                                                               0851.000
  862.       SUBROUTINE IOWAIT (MSEC)                                          0852.000
  863.            IMPLICIT NONE                                                0853.000
  864.            INTEGER  MSEC           !msec to wait for io to complete     0854.000
  865. C                                                                       0855.000
  866. C= Delays the specified time if io is pending                           0856.000
  867. C                                                                       0857.000
  868.       INTEGER      IOS                                                  0858.000
  869. C                                                                       0859.000
  870.       INTEGER      MIN                                                  0860.000
  871. C                                                                       0861.000
  872. C                                                                       0862.000
  873.       CALL X:EAWAIT(MIN(-1,-MSEC/50), IOS, *10)                         0863.000
  874.  10   CONTINUE                                                          0864.000
  875.       RETURN                                                            0865.000
  876.       END                                                               0866.000
  877.