C C INPUT-OUTPUT ROUTINES USING QIO'S. C C BY BOB STODOLA, SEPTEMBER 1980 C SUBROUTINE OUTCH(OUTPUT, COUNT) IMPLICIT INTEGER*2(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*2(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) = "15 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, LINE, COUNT, ERR) IMPLICIT INTEGER*2(A - Z) BYTE INPUT(1) LOGICAL ECHO, LINE C C CALL INCHAR(BUF,SIZE,ECHO,TIMOUT,LINE,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 LINE ==> .TRUE. FOR LINE ORIENTED INPUT, .FALSE. FOR READ-PASS-ALL. C COUNT <== NUMBER OF CHARACTERS READ. C ERR <== ERROR CODE RETURNED: C >0 = TERMINATING CHARACTER FOR LINE ORIENTED INPUT C 0 = NO TERMINATION (TIMEOUT, LINE ORIENTED) OR C NOT LINE ORIENTED SUCCESS. 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 IORAL = "1000 PARAMETER TFRNE = "20 PARAMETER TFTMO = "200 PARAMETER IEEOF = - 10, ISTMO = 2 CALL FLUSH(0) IF (.NOT.(LINE)) GOTO 2100 IOFC = IORVB GOTO 2110 2100 CONTINUE IOFC = IORAL 2110 CONTINUE IF (.NOT.(.NOT.ECHO)) GOTO 2120 IOFC = IOFC.OR.TFRNE 2120 CONTINUE IF (.NOT.(TIMOUT .GE. 0)) GOTO 2140 DPB(3) = TIMOUT IOFC = IOFC.OR.TFTMO GOTO 2150 2140 CONTINUE DPB(3) = 0 2150 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 2160 IF (.NOT.(IOER .EQ. IEEOF)) GOTO 2180 ERR = - 1 GOTO 2190 2180 CONTINUE IF (.NOT.(IOER .EQ. ISTMO)) GOTO 2200 ERR = - 2 GOTO 2210 2200 CONTINUE IF (.NOT.(IOER .GT. 0)) GOTO 2220 ERR = TC GOTO 2230 2220 CONTINUE ERR = - 3 2230 CONTINUE 2210 CONTINUE 2190 CONTINUE GOTO 2170 2160 CONTINUE ERR = - 3 2170 CONTINUE RETURN END