* BASE -ULTLY-KERM -SFM-A2703 - 08/01/90 WJH HEADER SFMKERM 0001.000 BLOCK DATA BDFILECO 0001.100 IMPLICIT NONE 0002.000 C 0003.000 C= Initialize the filecom common 0004.000 C 0005.000 INCLUDE K.FILEC 0006.000 C 0007.000 DATA FMODE/MAXFILE*CLOSED/ !close all units 0008.000 DATA FCHPTR /MAXFILE*0/ 0009.000 DATA FCHCNT /MAXFILE*0/ 0010.000 DATA FEOF /MAXFILE*.FALSE./ 0011.000 DATA CTDEV /MAXFILE*.FALSE./ 0012.000 DATA FREQ /MAXFILE*0/ 0013.000 DATA IOPEND /MAXFILE*NOIO/ 0014.000 DATA NOWAIT /MAXFILE*.FALSE./ 0015.000 DATA BINARY /MAXFILE*.FALSE./ 0016.000 DATA FTIMOUT/MAXFILE* 0/ 0017.000 END 0018.000 INTEGER FUNCTION OPEN(FN, MODE) 0019.000 IMPLICIT NONE 0020.000 CHARACTER*(*) FN !file name 0021.000 CHARACTER*(*) MODE !mode of file ('R','W') 0022.000 C 0023.000 C= o Opens a file as specified, returns file index 0024.000 INCLUDE K.FILEC 0025.000 C 0026.000 INTEGER I !indexing 0027.000 CHARACTER*8 FILESTAT !file status for open 0028.000 INTEGER IOS !status of open 0029.000 INTEGER IMODE !translated mode code 0030.000 INTEGER ALTLFC !altlfc to assign to 0031.000 CHARACTER*4 CALTLFC !character form of alt lfc 0032.000 EQUIVALENCE (CALTLFC, ALTLFC) 0033.000 LOGICAL OPENMODE !access mode 0034.000 C 0035.000 INTRINSIC ICHAR 0036.100 C INTEGER ICHAR !character to integer 0036.200 C 0037.000 X WRITE(19,1000)FN,MODE 0037.100 X1000 FORMAT(' OPEN** ',(1X,A8,1X,1Z8)) 0037.200 IF (MODE .EQ. 'R') THEN 0038.000 IMODE = RD 0039.000 ELSE IF (MODE .EQ. 'W' .OR. MODE .EQ. 'C') THEN 0040.000 IMODE = WR 0041.000 ELSE 0042.000 CALL PRTMSG('OPEN - invalid mode',ICHAR(MODE)) 0043.000 OPEN = ERROR 0044.000 RETURN 0045.000 ENDIF 0046.000 DO I=1, MAXFILE !handle duplicates 0047.000 C 0048.000 C handle duplicate entries 0049.000 C 0050.000 IF (FMODE(I) .NE. CLOSED) THEN !if open 0051.000 IF (FNAME(I) .EQ. FN) THEN !if duplicate 0052.000 IF (FMODE(I) .EQ. IMODE) THEN !if same mode, ignore 0053.000 IF (CTDEV(I)) THEN !if device, flush, ready 0054.000 CALL FLUSH(I) 0055.000 OPEN = I 0056.000 RETURN 0057.000 ELSE !if file, rewind 0058.000 CALL FLUSH(I) 0059.000 CALL CLOSE(I) 0060.000 ENDIF 0061.000 ELSE !if mode different, reopen 0062.000 IF (CTDEV(I)) THEN !if device, not really dupl. 0063.000 CONTINUE 0064.000 ELSE !if file, close so can reopen 0065.000 CALL FLUSH(I) 0066.000 CALL CLOSE(I) 0067.000 ENDIF 0068.000 ENDIF 0069.000 ENDIF 0070.000 ENDIF 0071.000 ENDDO 0072.000 C 0073.000 C find slot 0074.000 C 0075.000 OPEN = 1 0076.000 DO WHILE (OPEN .LT. MAXFILE .AND. FMODE(OPEN) .NE. CLOSED) 0077.000 OPEN = OPEN + 1 0078.000 ENDDO 0079.000 IF (FMODE(OPEN) .NE. CLOSED) THEN 0080.000 OPEN = ERROR 0081.000 CALL PRTMSG('OPEN - Exceed allowed number of files',MAXFILE) 0082.000 RETURN 0083.000 ENDIF 0084.000 C 0085.000 C open 0086.000 C 0087.000 FNAME(OPEN) = FN 0088.000 FCHPTR(OPEN) = 1 0089.000 FCHCNT(OPEN) = 0 0090.000 FMODE(OPEN) = IMODE 0091.000 FEOF(OPEN) = .FALSE. 0092.000 CTDEV(OPEN) = .FALSE. 0093.000 FREQ(OPEN) = MAXCH 0094.000 IOPEND(OPEN) = NOIO 0095.000 NOWAIT(OPEN) = .FALSE. 0096.000 FTIMOUT(OPEN) = 0 0097.000 BINARY(OPEN) = .FALSE. 0098.000 DO I=1, 4 0099.000 FBLK(I, OPEN) = 0 0100.000 ENDDO 0101.000 DO I=1, MAXCH 0102.000 FCHBUF(I, OPEN) = 0 0103.000 ENDDO 0104.000 C 0105.000 C if standard i/o, connect to user terminal 0106.000 C 0107.000 IF (FNAME(OPEN) .EQ. 'STDIN' .OR. FNAME(OPEN) .EQ. 'STDOUT') THEN 0108.000 OPEN (UNIT=OPEN, ALTUNIT='UT', IOSTAT=IOS, ERR=910) 0109.000 CTDEV(OPEN) = .TRUE. 0110.000 FREQ(OPEN) = 133 0111.000 C 0112.000 C if terminal - all terminals begin with @ 0113.000 C 0114.000 ELSE IF (FNAME(OPEN)(1:1) .EQ. '@') THEN 0115.000 FNAME(OPEN) = FNAME(OPEN)(2:) 0116.000 OPEN (UNIT=OPEN, DEVICE=FNAME(OPEN), 0117.000 $ WAIT=.FALSE., 0118.000 $ IOSTAT=IOS, ERR=910) 0119.000 CTDEV(OPEN) = .TRUE. 0120.000 FREQ(OPEN) = 133 0121.000 C 0122.000 C must be file 0123.000 C 0124.000 ELSE 0125.000 C IF (FMODE(OPEN) .EQ. RD) THEN 0126.000 C FILESTAT='OLD' 0127.000 C OPENMODE = .TRUE. 0128.000 C ELSE 0129.000 C FILESTAT='UNKNOWN' 0130.000 C OPENMODE = .FALSE. 0131.000 C ENDIF 0132.000 C OPEN(UNIT=OPEN, FILE=FNAME(OPEN), 0133.000 C $ BLOCKED=.FALSE., FORM='FORMATTED', 0134.000 C $ WAIT=.FALSE.,STATUS=FILESTAT, 0135.000 C $ READONLY = OPENMODE, 0136.000 C $ IOSTAT=IOS, ERR=910) 0137.000 CALL M:DALOC(OPEN) 0138.000 CALL M:ALOC1(OPEN,FNAME(OPEN),$910,,.TRUE.,,IOS) 0139.000 CALL M:OPEN(OPEN) 0140.000 ENDIF 0141.000 CALL BLKINIT(OPEN) 0142.000 RETURN 0143.000 C 0144.000 C open error 0145.000 C 0146.000 910 CONTINUE 0147.000 FMODE(OPEN) = CLOSED 0148.000 OPEN = -IOS 0149.000 X WRITE(19,1001) 0149.100 X1001 FORMAT (' OPEN ERROR ') 0149.200 RETURN 0150.000 END 0151.000 SUBROUTINE BLKINIT(FD) 0152.000 IMPLICIT NONE 0153.000 INTEGER FD !file descriptor 0154.000 C 0155.000 C= Calls fcbinit with proper function code for current flags 0156.000 C 0157.000 INCLUDE K.FILEC 0158.000 C 0159.000 INTEGER FUNC !function code 0160.000 INTEGER NOWAITW/X'80000000'/ !nowait operation 0161.000 INTEGER DFI /X'20000000'/ !use io spec we specify 0162.000 INTEGER XXWORD /X'00100000'/ !xon/xoff protocol 0163.000 INTEGER EXP /X'02000000'/ !expanded fcb 0164.000 INTEGER NOERR /X'40000000'/ !no error branch 0165.000 INTEGER CONTROL/X'00800000'/ !control character detect 0166.000 INTEGER NOECHO /X'00400000'/ !do not echo down port 0167.000 INTEGER NOUPPER/X'00200000'/ !do not convert to upper case 0168.000 INTEGER SPCHRW /X'00100000'/ !special character detect 0169.000 INTEGER PURGEW /X'00080000'/ !purge type ahead buffer 0170.000 C 0171.000 IF (CTDEV(FD)) THEN 0172.000 IF (FMODE(FD) .EQ. RD) THEN 0173.000 IF (BINARY(FD)) THEN 0174.000 FUNC = NOERR + EXP + DFI + CONTROL + NOECHO + NOUPPER 0175.000 ELSE 0176.000 FUNC = NOERR + EXP 0177.000 ENDIF 0178.000 ELSE !write 0179.000 FUNC = NOERR + EXP + DFI 0180.000 ENDIF 0181.000 ELSE !disk read/write 0182.000 FUNC = NOERR + EXP 0183.000 ENDIF 0184.000 IF (NOWAIT(FD)) FUNC = FUNC + NOWAITW 0185.000 CALL FCBINIT(FD, FBLK(1, FD), FUNC, FREQ(FD)) 0186.000 RETURN 0187.000 END 0188.000 SUBROUTINE CLOSE(FD) 0189.000 IMPLICIT NONE 0190.000 INTEGER FD !file descriptor 0191.000 C 0192.000 C= Closes an opened file. 0193.000 C 0194.000 INCLUDE K.FILEC 0195.000 C 0196.000 IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN 0197.000 CONTINUE !ignore errors 0198.000 ELSE IF (FMODE(FD) .EQ. CLOSED) THEN 0199.000 CONTINUE !already closed 0200.000 ELSE 0201.000 CALL FLUSH(FD) 0202.000 CLOSE(UNIT=FD) 0203.000 FMODE(FD) = CLOSED 0204.000 ENDIF 0205.000 RETURN 0206.000 END 0207.000 SUBROUTINE FLUSH(FD) 0208.000 IMPLICIT NONE 0209.000 INTEGER FD !file descriptor 0210.000 C 0211.000 C= forces output of buffer 0212.000 C 0213.000 INCLUDE K.FILEC 0214.000 C 0215.000 INTEGER*1 LBUF(MAXCH, MAXFILE) !local buffers for nowait 0216.000 INTEGER I 0217.000 C 0218.000 IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN 0219.000 RETURN 0220.000 ELSE IF (FMODE(FD) .EQ. CLOSED) THEN 0221.000 RETURN 0222.000 ELSE 0223.000 IF (FMODE(FD) .EQ. WR .AND. FCHCNT(FD) .GT. 0) THEN 0224.000 IF (IOPEND(FD) .EQ. NOIO) THEN 0225.000 IF (NOWAIT(FD)) THEN 0226.000 IOPEND(FD) = IOSTART 0227.000 DO I=1, FCHCNT(FD) 0228.000 LBUF(I, FD) = FCHBUF(I, FD) 0229.000 ENDDO 0230.000 GOTO (10,20,30,40,50,60,70,80,90,100) FD 0231.000 10 CONTINUE 0232.000 CALL DPWRITE(FBLK(1, FD), LBUF(1,FD), FCHCNT(FD), 0, 0233.000 $ *801, *801) 0234.000 GOTO 150 0235.000 20 CONTINUE 0236.000 CALL DPWRITE(FBLK(1, FD), LBUF(1,FD), FCHCNT(FD), 0, 0237.000 $ *802, *802) 0238.000 GOTO 150 0239.000 30 CONTINUE 0240.000 CALL DPWRITE(FBLK(1, FD), LBUF(1,FD), FCHCNT(FD), 0, 0241.000 $ *803, *803) 0242.000 GOTO 150 0243.000 40 CONTINUE 0244.000 CALL DPWRITE(FBLK(1, FD), LBUF(1,FD), FCHCNT(FD), 0, 0245.000 $ *804, *804) 0246.000 GOTO 150 0247.000 50 CONTINUE 0248.000 CALL DPWRITE(FBLK(1, FD), LBUF(1,FD), FCHCNT(FD), 0, 0249.000 $ *805, *805) 0250.000 GOTO 150 0251.000 60 CONTINUE 0252.000 CALL DPWRITE(FBLK(1, FD), LBUF(1,FD), FCHCNT(FD), 0, 0253.000 $ *806, *806) 0254.000 GOTO 150 0255.000 70 CONTINUE 0256.000 CALL DPWRITE(FBLK(1, FD), LBUF(1,FD), FCHCNT(FD), 0, 0257.000 $ *807, *807) 0258.000 GOTO 150 0259.000 80 CONTINUE 0260.000 CALL DPWRITE(FBLK(1, FD), LBUF(1,FD), FCHCNT(FD), 0, 0261.000 $ *808, *808) 0262.000 GOTO 150 0263.000 90 CONTINUE 0264.000 CALL DPWRITE(FBLK(1, FD), LBUF(1,FD), FCHCNT(FD), 0, 0265.000 $ *809, *809) 0266.000 GOTO 150 0267.000 100 CONTINUE 0268.000 CALL DPWRITE(FBLK(1, FD), LBUF(1,FD), FCHCNT(FD), 0, 0269.000 $ *810, *810) 0270.000 GOTO 150 0271.000 150 CONTINUE 0272.000 ELSE 0273.000 IOPEND(FD) = NOIO 0274.000 CALL DPWRITE(FBLK(1, FD), FCHBUF(1, FD), FCHCNT(FD), 0) 0275.000 ENDIF 0276.000 ENDIF 0277.000 ELSE IF (FMODE(FD) .EQ. RD .AND. IOPEND(FD) .EQ. IOSTART) THEN 0278.000 CALL HIO(FD) 0279.000 CLT DO I=1, MAXFILE 0280.000 CLT IF (FMODE(I) .EQ. WR .AND. IOPEND(I) .EQ. IOSTART) 0281.000 CLT $ CALL X:EAWAIT(0,,) 0282.000 CLT IF (IOPEND(I) .EQ. IOSTART) IOPEND(I) = NOIO 0283.000 CLT ENDDO 0284.000 CLT CALL HIOALL !this is going to hurt somewhere 0285.000 ENDIF 0286.000 FCHPTR(FD) = 1 0287.000 FCHCNT(FD) = 0 0288.000 ENDIF 0289.000 RETURN 0290.000 C 0291.000 C end action 0292.000 C 0293.000 801 IOPEND( 1) = NOIO; CALL X:XNWIO 0294.000 802 IOPEND( 2) = NOIO; CALL X:XNWIO 0295.000 803 IOPEND( 3) = NOIO; CALL X:XNWIO 0296.000 804 IOPEND( 4) = NOIO; CALL X:XNWIO 0297.000 805 IOPEND( 5) = NOIO; CALL X:XNWIO 0298.000 806 IOPEND( 6) = NOIO; CALL X:XNWIO 0299.000 807 IOPEND( 7) = NOIO; CALL X:XNWIO 0300.000 808 IOPEND( 8) = NOIO; CALL X:XNWIO 0301.000 809 IOPEND( 9) = NOIO; CALL X:XNWIO 0302.000 810 IOPEND(10) = NOIO; CALL X:XNWIO 0303.000 END 0304.000 SUBROUTINE PUTC(FD, TCH) 0305.000 IMPLICIT NONE 0306.000 INTEGER FD !file descriptor 0307.000 INTEGER TCH !character to output 0308.000 C 0309.000 C= outputs a character 0310.000 C 0311.000 C **** NOTE: tricky stuff, no difference between terminal 0312.000 C outputs in binary or ascii, but in binary NEL's are 0313.000 C not interpreted. So don't put term in binary unless 0314.000 C you really mean it. 0315.000 C 0316.000 C 0317.000 INCLUDE K.FILEC 0318.000 C 0319.000 INTEGER CH 0320.000 INTEGER I 0321.000 C 0322.000 IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN 0323.000 CONTINUE 0324.000 ELSE IF (FMODE(FD) .EQ. WR) THEN 0325.000 CH = TCH 0326.000 IF (.NOT. BINARY(FD) .AND. TCH .EQ. NEL) THEN 0327.000 CH = CR 0328.000 IF (.NOT. CTDEV(FD)) GOTO 20 0329.000 ENDIF 0330.000 10 CONTINUE 0331.000 IF (FCHCNT(FD) .GE. FREQ(FD)) CALL FLUSH(FD) 0332.000 IF (FCHCNT(FD) .LT. MAXCH) THEN 0333.000 FCHCNT(FD) = FCHCNT(FD) + 1 0334.000 FCHBUF(FCHCNT(FD), FD) = CH 0335.000 ENDIF 0336.000 IF (FCHCNT(FD) .GE. FREQ(FD)) CALL FLUSH(FD) 0337.000 IF (TCH .EQ. NEL .AND. CH .EQ. CR) THEN 0338.000 CH = LF 0339.000 GOTO 10 0340.000 ENDIF 0341.000 20 CONTINUE 0342.000 C 0343.000 C end of line processing 0344.000 C 0345.000 IF (.NOT. BINARY(FD) .AND. TCH .EQ. NEL) THEN 0346.000 C 0347.000 C if text file, strip trailing blanks, cr, lf 0348.000 C 0349.000 IF (.NOT. CTDEV(FD)) THEN 0350.000 I = FCHCNT(FD) 0351.000 DO WHILE (I .GT. 0) 0352.000 IF (FCHBUF(I, FD) .EQ. BLANK .OR. FCHBUF(I, FD) .EQ. 0353.000 $ CR .OR. FCHBUF(I, FD) .EQ. LF) THEN 0354.000 I = I - 1 0355.000 ELSE 0356.000 LEAVE 0357.000 ENDIF 0358.000 ENDDO 0359.000 IF (I .LE. 0) THEN 0360.000 I = I + 1 0361.000 FCHBUF(I, FD) = BLANK 0362.000 ENDIF 0363.000 FCHCNT(FD) = I 0364.000 ENDIF 0365.000 CALL FLUSH(FD) !force out 0366.000 ENDIF 0367.000 ENDIF 0368.000 RETURN 0369.000 END 0370.000 INTEGER FUNCTION GETC(FD, CH) 0371.000 IMPLICIT NONE 0372.000 INTEGER FD !file descriptor 0373.000 INTEGER CH !character read in 0374.000 C 0375.000 C= Reads a character from input buffer, reads if necessary 0376.000 C 0377.000 INCLUDE K.FILEC 0378.000 C 0379.000 IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN 0380.000 CH = ERROR 0381.000 ELSE IF (FMODE(FD) .EQ. RD) THEN 0382.000 IF (FCHPTR(FD) .GT. FCHCNT(FD)) CALL FILL(FD) 0383.000 IF (FEOF(FD)) THEN 0384.000 CH = EOF 0385.000 ELSE IF (FCHPTR(FD) .GT. FCHCNT(FD)) THEN 0386.000 CH = ERROR 0387.000 ELSE 0388.000 CH = FCHBUF(FCHPTR(FD), FD) 0389.000 FCHPTR(FD) = FCHPTR(FD) + 1 0390.000 ENDIF 0391.000 ELSE 0392.000 CH = ERROR 0393.000 ENDIF 0394.000 GETC = CH 0395.000 RETURN 0396.000 END 0397.000 SUBROUTINE FILL(FD) 0398.000 IMPLICIT NONE 0399.000 INTEGER FD !file descriptor 0400.000 C 0401.000 C= Fills the respective fd's buffer 0402.000 C 0403.000 INCLUDE K.FILEC 0404.000 C 0405.000 INTEGER STATUS !status of io done 0406.000 INTEGER I !temp count 0407.000 C 0408.000 INTEGER DPCOUNT !retreive count of transfer 0409.000 INTEGER DERROR !error code 0410.000 C 0411.000 IF (IOPEND(FD) .EQ. NOIO) THEN 0412.000 IF (NOWAIT(FD)) THEN 0413.000 IOPEND(FD) = IOSTART 0414.000 GOTO (10, 20, 30, 40, 50, 60, 70, 80, 90, 100) FD 0415.000 10 CONTINUE 0416.000 CALL DPREAD(FBLK(1,FD),FCHBUF(1,FD),FREQ(FD), 0,*801,*801) 0417.000 GOTO 150 0418.000 20 CONTINUE 0419.000 CALL DPREAD(FBLK(1,FD),FCHBUF(1,FD),FREQ(FD), 0,*802,*802) 0420.000 GOTO 150 0421.000 30 CONTINUE 0422.000 CALL DPREAD(FBLK(1,FD),FCHBUF(1,FD),FREQ(FD), 0,*803,*803) 0423.000 GOTO 150 0424.000 40 CONTINUE 0425.000 CALL DPREAD(FBLK(1,FD),FCHBUF(1,FD),FREQ(FD), 0,*804,*804) 0426.000 GOTO 150 0427.000 50 CONTINUE 0428.000 CALL DPREAD(FBLK(1,FD),FCHBUF(1,FD),FREQ(FD), 0,*805,*805) 0429.000 GOTO 150 0430.000 60 CONTINUE 0431.000 CALL DPREAD(FBLK(1,FD),FCHBUF(1,FD),FREQ(FD), 0,*806,*806) 0432.000 GOTO 150 0433.000 70 CONTINUE 0434.000 CALL DPREAD(FBLK(1,FD),FCHBUF(1,FD),FREQ(FD), 0,*807,*807) 0435.000 GOTO 150 0436.000 80 CONTINUE 0437.000 CALL DPREAD(FBLK(1,FD),FCHBUF(1,FD),FREQ(FD), 0,*808,*808) 0438.000 GOTO 150 0439.000 90 CONTINUE 0440.000 CALL DPREAD(FBLK(1,FD),FCHBUF(1,FD),FREQ(FD), 0,*809,*809) 0441.000 GOTO 150 0442.000 100 CONTINUE 0443.000 CALL DPREAD(FBLK(1,FD),FCHBUF(1,FD),FREQ(FD), 0,*810,*810) 0444.000 GOTO 150 0445.000 150 CONTINUE 0446.000 IF (FTIMOUT(FD) .GT. 0) THEN 0447.000 CALL X:EAWAIT(-FTIMOUT(FD)*10,,) 0448.000 IF (IOPEND(FD) .EQ. IOSTART) THEN 0449.000 CALL HIO(FD) 0450.000 CALL X:EAWAIT(-FTIMOUT(FD)*10,,) 0451.000 ENDIF 0452.000 ENDIF 0453.000 ELSE 0454.000 CALL DPREAD(FBLK(1, FD), FCHBUF(1, FD), FREQ(FD), 0) 0455.000 IOPEND(FD) = IOCOMP 0456.000 ENDIF 0457.000 ENDIF 0458.000 IF (IOPEND(FD) .EQ. IOCOMP) THEN 0459.000 IOPEND(FD) = NOIO 0460.000 FCHPTR(FD) =1 0461.000 FCHCNT(FD) = DPCOUNT(FBLK(1, FD)) 0462.000 IF (.NOT. BINARY(FD)) THEN 0463.000 IF (CTDEV(FD)) THEN 0464.000 FCHCNT(FD) = FCHCNT(FD) + 1 0465.000 FCHBUF(FCHCNT(FD), FD) = NEL 0466.000 ELSE 0467.000 I = FCHCNT(FD) 0468.000 DO WHILE (I .GT. 0) 0469.000 IF (FCHBUF(I,FD) .EQ. BLANK) THEN 0470.000 I = I - 1 0471.000 ELSE 0472.000 LEAVE 0473.000 ENDIF 0474.000 ENDDO 0475.000 I = I + 1 0476.000 FCHBUF(I, FD) = NEL 0477.000 FCHCNT(FD) = I 0478.000 ENDIF 0479.000 ENDIF 0480.000 STATUS = DERROR(FBLK(1, FD)) 0481.000 IF (STATUS .EQ. 3 .OR. STATUS .EQ. 4) FEOF(FD) = .TRUE. 0482.000 ENDIF 0483.000 RETURN 0484.000 C 0485.000 C end action 0486.000 C 0487.000 801 IOPEND(1) = IOCOMP; CALL X:XNWIO 0488.000 802 IOPEND(2) = IOCOMP; CALL X:XNWIO 0489.000 803 IOPEND(3) = IOCOMP; CALL X:XNWIO 0490.000 804 IOPEND(4) = IOCOMP; CALL X:XNWIO 0491.000 805 IOPEND(5) = IOCOMP; CALL X:XNWIO 0492.000 806 IOPEND(6) = IOCOMP; CALL X:XNWIO 0493.000 807 IOPEND(7) = IOCOMP; CALL X:XNWIO 0494.000 808 IOPEND(8) = IOCOMP; CALL X:XNWIO 0495.000 809 IOPEND(9) = IOCOMP; CALL X:XNWIO 0496.000 810 IOPEND(10)= IOCOMP; CALL X:XNWIO 0497.000 END 0498.000 SUBROUTINE STTY(FD, FIELD, VALUE) 0499.000 IMPLICIT NONE 0500.000 INTEGER FD !port to set 0501.000 CHARACTER*(*) FIELD !field to set 0502.000 INTEGER VALUE !value to set to 0503.000 C 0504.000 C= Sets the specified field to the value 0505.000 C 0506.000 INCLUDE K.KERMV 0507.000 INCLUDE K.FILEC 0508.000 LOGICAL*1 TTYECHO(MAXFILE) !local memory for echo 0509.000 C 0510.000 LOGICAL TUDT !test user device table 0511.000 C 0512.000 C 0513.000 X WRITE(19,1000)FIELD,VALUE,MAXCH 0513.100 X1000 FORMAT(1X,1A8,2X,2(1X,1Z8)) 0513.200 IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN 0514.000 CONTINUE 0515.000 ELSE IF (FMODE(FD) .EQ. CLOSED) THEN 0516.000 CONTINUE 0517.000 C 0518.000 C binary mode 0519.000 C 0520.000 ELSE IF (FIELD .EQ. 'BINARY') THEN 0521.000 BINARY(FD) = VALUE .EQ. 1 0522.000 CALL BLKINIT(FD) 0523.000 C 0524.000 C TIMEOUT 0525.000 C 0526.000 ELSE IF (FIELD .EQ. 'TIMEOUT') THEN 0527.000 FTIMOUT(FD) = VALUE 0528.000 C 0529.000 C nowait 0530.000 C 0531.000 ELSE IF (FIELD .EQ. 'NOWAIT') THEN 0532.000 NOWAIT(FD) = VALUE .EQ. 1 0533.000 CALL BLKINIT(FD) 0534.000 IF (FMODE(FD) .EQ. RD) THEN 0535.000 C 0536.000 C This section is used to enable timeouts since 0537.000 C gould doesn't support a timeout on a normal read. 0538.000 C You must be privileged to do this stuff 0539.000 C 0540.000 IF (LOCALON) THEN 0541.000 IF (NOWAIT(FD)) THEN 0542.000 C 0543.000 CLT 2.3 CORRECTED TURNING ECHO ON AND OFF 0544.000 C In this section (which incidentially must be called first) we 0545.000 C memorize the previous condition of the udt so we can restore 0546.000 C it to correct mode. This is part of rev. 2.3. This feature 0547.000 C is particularly important for those using a network for file 0548.000 C transmittal since they don't have echo on any way. 0549.000 C 0550.000 TTYECHO(FD) = TUDT(FBLK(1, FD), 'ECHO') 0551.000 IF (TTYECHO(FD)) THEN 0552.000 CALL SUDT(FBLK(1, FD), 'NOEC') !make sure 0553.000 ENDIF 0554.000 CALL SUDT(FBLK(1, FD), 'DUAL') 0555.000 ELSE 0556.000 CALL SUDT(FBLK(1, FD), 'SING') 0557.000 IF (TTYECHO(FD)) THEN 0558.000 CALL SUDT(FBLK(1, FD), 'ECHO') !may be right 0559.000 ENDIF 0560.000 ENDIF 0561.000 ENDIF 0562.000 ENDIF 0563.000 C 0564.000 C readsize 0565.000 C 0566.000 ELSE IF (FIELD .EQ. 'SIZE') THEN 0567.000 IF (VALUE .GT. 0) THEN 0568.000 FREQ(FD) = VALUE 0569.000 ELSE 0570.000 FREQ(FD) = MAXCH 0571.000 ENDIF 0572.000 IF (FREQ(FD) .GT. MAXCH) FREQ(FD) = MAXCH 0573.000 CALL BLKINIT(FD) 0574.000 C 0575.000 C unrecognized field 0576.000 C 0577.000 ELSE 0578.000 CONTINUE 0579.000 ENDIF 0580.000 RETURN 0581.000 END 0582.000 SUBROUTINE UNGETC(FD, CH) 0583.000 IMPLICIT NONE 0584.000 INTEGER FD !file descriptor 0585.000 INTEGER CH !character put back 0586.000 C 0587.000 C= Try to put a character back into the input stream 0588.000 C 0589.000 C Ungetc can only put back characters as far as the beginning 0590.000 C of the buffer. Hopefully, this is ok, since only getword 0591.000 C does this with an nel which should be well into the buffer. 0592.000 C 0593.000 INCLUDE K.FILEC 0594.000 C 0595.000 IF (FCHPTR(FD) .GT. 1) THEN 0596.000 FCHPTR(FD) = FCHPTR(FD) - 1 0597.000 FCHBUF(FCHPTR(FD), FD) = CH 0598.000 ENDIF 0599.000 RETURN 0600.000 END 0601.000 INTEGER FUNCTION GETWORD(FD, STR, MAXLEN) 0602.000 IMPLICIT NONE 0603.000 INTEGER FD !file descriptor 0604.000 INTEGER STR(*) !string to read to 0605.000 INTEGER MAXLEN !max size of string 0606.000 C 0607.000 C= get a word from an input stream 0608.000 C 0609.000 C Getword considers a word to be delimited by blanks. 0610.000 C It will return the length of the word as its value. 0611.000 C 0612.000 INCLUDE K.FILEC 0613.000 C 0614.000 INTEGER LEN !length of string 0615.000 INTEGER CH !character 0616.000 C 0617.000 INTEGER GETC !get character 0618.000 C 0619.000 LEN = 0 0620.000 C 0621.000 C skip leading white space 0622.000 C 0623.000 10 CONTINUE 0624.000 IF (GETC(FD, CH) .EQ. EOF) THEN 0625.000 GETWORD = EOF 0626.000 RETURN 0627.000 ELSE IF (CH .EQ. NEL) THEN 0628.000 GETWORD = 0 0629.000 RETURN 0630.000 ENDIF 0631.000 IF (CH .EQ. BLANK .OR. CH .EQ. TAB) GOTO 10 0632.000 C 0633.000 C found first character, so keep going 0634.000 C 0635.000 DO WHILE (.NOT. (CH .EQ. EOF .OR. CH .EQ. BLANK .OR. 0636.000 $ CH .EQ. TAB .OR. CH .EQ. NEL) .AND. 0637.000 $ LEN .LT. MAXLEN) 0638.000 LEN = LEN + 1 0639.000 STR(LEN) = CH 0640.000 CH = GETC(FD, CH) 0641.000 ENDDO 0642.000 C 0643.000 C save eols for next getword 0644.000 C 0645.000 IF (CH .EQ. NEL) CALL UNGETC(FD, CH) 0646.000 STR(LEN+1) = 0 0647.000 GETWORD = LEN 0648.000 RETURN 0649.000 END 0650.000 SUBROUTINE PUTSTR(FD, STR) 0651.000 IMPLICIT NONE 0652.000 INTEGER FD 0653.000 INTEGER STR(*) !string to read 0654.000 C 0655.000 C= Output a string to an output stream 0656.000 C 0657.000 INCLUDE K.FILEC 0658.000 C 0659.000 INTEGER I 0660.000 C 0661.000 IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN 0662.000 ELSE IF (FMODE(FD) .EQ. WR) THEN 0663.000 I = 1 0664.000 DO WHILE (STR(I) .NE. 0) 0665.000 CALL PUTC(FD, STR(I)) 0666.000 I = I + 1 0667.000 ENDDO 0668.000 ENDIF 0669.000 RETURN 0670.000 END 0671.000 SUBROUTINE PUTINT (FD, INT, MINWID) 0672.000 IMPLICIT NONE 0673.000 INTEGER FD 0674.000 INTEGER INT 0675.000 INTEGER MINWID !minimum width 0676.000 C 0677.000 C= Output an integer 0678.000 C 0679.000 INCLUDE K.KERMD 0680.000 C 0681.000 INTEGER WIDTH 0682.000 INTEGER VAL 0683.000 INTEGER ASCIIO 0684.000 INTEGER NCH !number of characters 0685.000 INTEGER STRING(21) 0686.000 C 0687.000 INTRINSIC ICHAR 0688.100 C INTEGER ICHAR 0688.200 INTEGER IABS 0689.000 INTEGER MOD 0690.000 C 0691.000 WIDTH = 0 0692.000 IF (INT .LT. 0) THEN 0693.000 CALL PUTC(FD, ICHAR('-')) 0694.000 WIDTH = 1 0695.000 ENDIF 0696.000 VAL = IABS(INT) 0697.000 ASCIIO = ICHAR('0') 0698.000 NCH = 0 0699.000 DO UNTIL (VAL .EQ. 0 .OR. NCH .GE. 20) 0700.000 NCH = NCH + 1 0701.000 STRING(NCH) = MOD(VAL, 10) + ASCIIO 0702.000 VAL = VAL/10 0703.000 ENDDO 0704.000 WIDTH = WIDTH + NCH 0705.000 C 0706.000 C now output the digits 0707.000 C 0708.000 DO UNTIL (NCH .LE. 0) 0709.000 CALL PUTC(FD, STRING(NCH)) 0710.000 NCH = NCH - 1 0711.000 ENDDO 0712.000 DO WHILE (WIDTH .LT. MINWID) 0713.000 CALL PUTC(FD, BLANK) 0714.000 WIDTH = WIDTH + 1 0715.000 ENDDO 0716.000 RETURN 0717.000 END 0718.000 SUBROUTINE PUTDAY(FD, MM, DD, YY) 0719.000 IMPLICIT NONE 0720.000 INTEGER FD 0721.000 INTEGER MM, DD, YY 0722.000 C 0723.000 C= Output day of week 0724.000 C 0725.000 INTEGER IZLR 0726.000 INTEGER IMN 0727.000 INTEGER IYR 0728.000 INTEGER IDY 0729.000 INTEGER WKDAY 0730.000 C 0731.000 C day of week function! 0732.000 C 0733.000 IZLR (IYR, IMN, IDY) = MOD((13*(IMN+10-(IMN+10)/13*12)-1)/5+ 0734.000 $ IDY+77+5*(IYR+(IMN-14)/12-(IYR+(IMN-14)/12)/100*100)/4+ 0735.000 $ (IYR+(IMN-14)/12)/400-(IYR+(IMN-14)/12)/100*2,7)+1 0736.000 C 0737.000 WKDAY = IZLR(YY, MM, DD) 0738.000 IF (WKDAY .EQ. 1) THEN 0739.000 CALL PRINT(FD, 'Sunday') 0740.000 ELSE IF (WKDAY .EQ. 2) THEN 0741.000 CALL PRINT(FD, 'Monday') 0742.000 ELSE IF (WKDAY .EQ. 3) THEN 0743.000 CALL PRINT(FD, 'Tuesday') 0744.000 ELSE IF (WKDAY .EQ. 4) THEN 0745.000 CALL PRINT(FD, 'Wednesday') 0746.000 ELSE IF (WKDAY .EQ. 5) THEN 0747.000 CALL PRINT(FD, 'Thursday') 0748.000 ELSE IF (WKDAY .EQ. 6) THEN 0749.000 CALL PRINT(FD, 'Friday') 0750.000 ELSE 0751.000 CALL PRINT(FD, 'Saturday') 0752.000 ENDIF 0753.000 RETURN 0754.000 END 0755.000 SUBROUTINE PUTMNTH(FD, MM) 0756.000 IMPLICIT NONE 0757.000 INTEGER FD 0758.000 INTEGER MM 0759.000 C 0760.000 C= Output the month name. 0761.000 C 0762.000 IF (MM .EQ. 1) THEN 0763.000 CALL PRINT(FD, 'January') 0764.000 ELSE IF (MM .EQ. 2) THEN 0765.000 CALL PRINT(FD, 'Feburary') 0766.000 ELSE IF (MM .EQ. 3) THEN 0767.000 CALL PRINT(FD, 'March') 0768.000 ELSE IF (MM .EQ. 4) THEN 0769.000 CALL PRINT(FD, 'April') 0770.000 ELSE IF (MM .EQ. 5) THEN 0771.000 CALL PRINT(FD, 'May') 0772.000 ELSE IF (MM .EQ. 6) THEN 0773.000 CALL PRINT(FD, 'June') 0774.000 ELSE IF (MM .EQ. 7) THEN 0775.000 CALL PRINT(FD, 'July') 0776.000 ELSE IF (MM .EQ. 8) THEN 0777.000 CALL PRINT(FD, 'August') 0778.000 ELSE IF (MM .EQ. 9) THEN 0779.000 CALL PRINT(FD, 'September') 0780.000 ELSE IF (MM .EQ. 10) THEN 0781.000 CALL PRINT(FD, 'October') 0782.000 ELSE IF (MM .EQ. 11) THEN 0783.000 CALL PRINT(FD, 'November') 0784.000 ELSE IF (MM .EQ. 12) THEN 0785.000 CALL PRINT(FD, 'December') 0786.000 ELSE 0787.000 CALL PRINT(FD, 'No such month') 0788.000 ENDIF 0789.000 RETURN 0790.000 END 0791.000 SUBROUTINE PRINT (FD, STR) 0792.000 IMPLICIT NONE 0793.000 INTEGER FD 0794.000 CHARACTER*(*) STR 0795.000 C 0796.000 C= Output character string 0797.000 C 0798.000 INTEGER I 0799.000 C 0800.000 INTRINSIC LEN 0801.000 INTRINSIC ICHAR 0802.100 C INTEGER ICHAR 0802.200 C 0803.000 DO I=1, LEN(STR) 0804.000 CALL PUTC(FD, ICHAR(STR(I:I))) 0805.000 ENDDO 0806.000 RETURN 0807.000 END 0808.000 SUBROUTINE PRINTL(FD, STR) 0809.000 IMPLICIT NONE 0810.000 INTEGER FD 0811.000 CHARACTER*(*) STR 0812.000 C 0813.000 C= Output a string with cr/lf at end 0814.000 C 0815.000 INCLUDE K.KERMD 0816.000 C 0817.000 CALL PUTC(FD, NEL) 0818.000 CALL PRINT(FD, STR) 0819.000 CALL FLUSH(FD) 0820.000 RETURN 0821.000 END 0822.000 SUBROUTINE SENDBRK(FD) 0823.000 IMPLICIT NONE 0824.000 INTEGER FD !file to break 0825.000 C 0826.000 C Sends break to attached port 0827.000 C 0828.000 INCLUDE K.FILEC 0829.000 C 0830.000 INTEGER BLK(4) !local block 0831.000 INTEGER BRK !function that turns on break 0832.000 $ /X'62800000'/ 0833.000 INTEGER NOBRK !turn off break 0834.000 $ /X'62000000'/ !break turned off 0835.000 C 0836.000 IF (FD .LE. 0 .AND. FD .GE. MAXFILE) THEN 0837.000 ELSE IF (.NOT. CTDEV(FD)) THEN 0838.000 ELSE IF (FMODE(FD) .NE. WR) THEN 0839.000 ELSE 0840.000 CALL FLUSH(FD) 0841.000 CALL FCBINIT(FD, BLK, BRK, 0) 0842.000 CALL DPWRITE(BLK, 0, 0) 0843.000 0844.000 CALL DELAY(60) 0845.000 CALL FCBINIT(FD, BLK, NOBRK, 0) 0846.000 CALL DPWRITE(BLK, 0, 0) 0847.000 CALL BLKINIT(FD) 0848.000 ENDIF 0849.000 RETURN 0850.000 END 0851.000 SUBROUTINE IOWAIT (MSEC) 0852.000 IMPLICIT NONE 0853.000 INTEGER MSEC !msec to wait for io to complete 0854.000 C 0855.000 C= Delays the specified time if io is pending 0856.000 C 0857.000 INTEGER IOS 0858.000 C 0859.000 INTEGER MIN 0860.000 C 0861.000 C 0862.000 CALL X:EAWAIT(MIN(-1,-MSEC/50), IOS, *10) 0863.000 10 CONTINUE 0864.000 RETURN 0865.000 END 0866.000