C C INPUT-OUTPUT ROUTINES USING QIO'S. C C BY BOB STODOLA, SEPTEMBER 1980 C SUBROUTINE OUTCH(OUTPUT, COUNT) IMPLICIT INTEGER(A - Z) BYTE OUTPUT(1) C C THE USER MUST SET UP AN INTERNAL BUFFER BY DEFINING A COMMON C AREA IOBUFR. TO ALLOCATE 2000 BYTES TO THESE ROUTINES, TYPE: C INTEGER BUFSIZ C BYTE BUF C COMMON/IOBUFR/ BUFSIZ, NBUF, BUF(2000) C BUFSIZ = 2000 C THE DEFAULT SIZE IS 1000 BYTES. C C CALL OUTCH(BUF,COUNT) C BUF ==> CHARACTER(S) TO OUTPUT C COUNT ==> NUMBER OF CHARACTERS TO OUTPUT. IF ZERO, THE C INTERNAL BUFFER IS FLUSHED. IF -1, THE INTERNAL C BUFFER IS FLUSHED WITH A TRAILING CARRIAGERETURN. C C NOTE: A CALL TO INCHAR WILL ALSO FLUSH THE BUFFER! C PARAMETER DEFSIZ = 3000 BYTE BUF COMMON/IOBUFR/BUFSIZ, NBUF, BUF(DEFSIZ) DATA BUFSIZ, NBUF/DEFSIZ, 0/ IF (.NOT.(COUNT .LE. 0)) GOTO 2000 CALL FLUSH(COUNT) GOTO 2010 2000 CONTINUE DO 2020 IP = 1, COUNT IF (.NOT.(NBUF .GE. BUFSIZ-1)) GOTO 2040 CALL FLUSH(0) 2040 CONTINUE NBUF = NBUF + 1 BUF(NBUF) = OUTPUT(IP) 2020 CONTINUE 2030 CONTINUE 2010 CONTINUE RETURN END SUBROUTINE FLUSH(CRFLAG) IMPLICIT INTEGER(A - Z) PARAMETER IOWAL = "410 BYTE BUF COMMON/IOBUFR/BUFSIZ, NBUF, BUF(1) DIMENSION DPB(6) DATA DPB/6*0/ IF (.NOT.(NBUF .GT. 0)) GOTO 2060 IF (.NOT.(CRFLAG .EQ. -1)) GOTO 2080 C DO A AT END OF LINE NBUF = NBUF + 1 BUF(NBUF) = 13 2080 CONTINUE CALL GETADR(DPB, BUF) DPB(2) = NBUF CALL WTQIO(IOWAL, 5, 5, , , DPB) NBUF = 0 2060 CONTINUE RETURN END SUBROUTINE INCHAR(INPUT, SIZE, ECHO, TIMOUT, COUNT, ERR) IMPLICIT INTEGER(A - Z) BYTE INPUT(1) LOGICAL ECHO, LINE C C CALL INCHAR(INPUT,SIZE,ECHO,TIMOUT,COUNT,ERR) C BUF <== BUFFER TO ACCEPT INPUT C SIZE ==> LENGTH OF THIS BUFFER C ECHO ==> .TRUE. FOR ECHO, .FALSE. FOR NO ECHO. C TIMOUT ==> -1 FOR NO TIMEOUT, ELSE 0-? FOR TIMOUT*10 SECOND C TIMEOUT ON INPUT. C COUNT <== NUMBER OF CHARACTERS READ. C ERR <== ERROR CODE RETURNED: C >0 = TERMINATING CHARACTER FOR LINE ORIENTED INPUT C -1 = END OF FILE READ C -2 = TIMED OUT C -3 = OTHER ERROR C BYTE BUF COMMON/IOBUFR/BUFSIZ, NBUF, BUF(1) DIMENSION DPB(6), IOSB(2) BYTE IOER, SB(2), TC EQUIVALENCE(IOER, SB, IOSB), (SB(2), TC) PARAMETER IORVB = "10400 PARAMETER TFRNE = "20 PARAMETER TFTMO = "200 PARAMETER IEEOF = -10, ISTMO = 2 CALL FLUSH(0) IOFC = IORVB IF (.NOT.(.NOT.ECHO)) GOTO 2100 IOFC = IOFC .OR.TFRNE 2100 CONTINUE IF (.NOT.(TIMOUT .GE. 0)) GOTO 2120 DPB(3) = TIMOUT IOFC = IOFC .OR.TFTMO GOTO 2130 2120 CONTINUE DPB(3) = 0 2130 CONTINUE CALL GETADR(DPB, INPUT) DPB(2) = SIZE CALL WTQIO(IOFC, 5, 5, , IOSB, DPB, ISW) COUNT = IOSB(2) IF (.NOT.(ISW .GE. 0)) GOTO 2140 IF (.NOT.(IOER .EQ. IEEOF)) GOTO 2160 ERR = - 1 GOTO 2170 2160 CONTINUE IF (.NOT.(IOER .EQ. ISTMO)) GOTO 2180 ERR = - 2 GOTO 2190 2180 CONTINUE IF (.NOT.(IOER .GT. 0)) GOTO 2200 ERR = TC GOTO 2210 2200 CONTINUE ERR = - 3 2210 CONTINUE 2190 CONTINUE 2170 CONTINUE GOTO 2150 2140 CONTINUE ERR = - 3 2150 CONTINUE RETURN END