C C INPUT-OUTPUT ROUTINES USING QIO'S. C C BY BOB STODOLA, SEPTEMBER 1980 C MODIFIED FOR VAXEN BY WILLIAM WOOD NOV. 1980 C SUBROUTINE IOINIT IMPLICIT INTEGER(A - Z) BYTE BUF COMMON/IOBUFR/ICHNL, BUFSIZ, NBUF, BUF(1) CHARACTER*63 PNAM CALL SYS$TRNLOG('SYS$INPUT', ILEN, PNAM, , , ) CALL SYS$ASSIGN(PNAM(5:ILEN), ICHNL, , ) C$TYPE *,' ICHNL = ',ICHNL RETURN END 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 ICHNL, BUFSIZ C BYTE BUF C COMMON/IOBUFR/ ICHNL, 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/ICHNL, 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) BYTE BUF COMMON/IOBUFR/ICHNL, BUFSIZ, NBUF, BUF(1) EXTERNAL IO$_WRITEVBLK, IO$M_NOFORMAT 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 IWRITE = %LOC(IO$_WRITEVBLK) .OR. %LOC(IO$M_NOFORMAT) CALL SYS$QIOW(, %VAL(ICHNL), %VAL(IWRITE), , , , BUF, %VAL(NBUF) *, , %VAL(0), , ) NBUF = 0 2060 CONTINUE RETURN END SUBROUTINE INCHAR(INPUT, SIZE, ECHO, TIMOUT, COUNT, IERR) IMPLICIT INTEGER(A - Z) BYTE INPUT(1) LOGICAL ECHO C C CALL INCHAR(INPUT,SIZE,ECHO,TIMOUT,COUNT,IERR) C INPUT <== 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 SECONDS C TIMEOUT ON INPUT. C COUNT <== NUMBER OF CHARACTERS READ. C IERR <== IERROR CODE RETURNED: C >= 0 : TERMINATING CHARACTER FOR LINE ORIENTED INPUT C -1 : END OF FILE READ C -2 : TIMED OUT C -3 : OTHER IERROR C BYTE BUF COMMON/IOBUFR/ICHNL, BUFSIZ, NBUF, BUF(1) INTEGER*2IOSB(4) INTEGER*2IOER BYTE TC EXTERNAL IO$_READVBLK, IO$M_NOECHO, IO$M_TIMED, IO$M_TRMNOECHO, * SS$_TIMEOUT, SS$_NORMAL EQUIVALENCE(IOER, IOSB(1)) EQUIVALENCE(TC, IOSB(3)) CALL FLUSH(0) IOFC = %LOC(IO$_READVBLK) .OR. %LOC(IO$M_TRMNOECHO) IF (.NOT.(.NOT.ECHO)) GOTO 2100 IOFC = IOFC .OR. %LOC(IO$M_NOECHO) 2100 CONTINUE IF (.NOT.(TIMOUT .GE. 0)) GOTO 2120 P3 = TIMOUT IOFC = IOFC .OR. %LOC(IO$M_TIMED) GOTO 2130 2120 CONTINUE P3 = 0 2130 CONTINUE ISW = SYS$QIOW(, %VAL(ICHNL), %VAL(IOFC), IOSB, , , INPUT, %VAL(SI *ZE), %VAL(P3), , , ) COUNT = IOSB(2) IF (.NOT.(ISW .NE. %LOC(SS$_NORMAL))) GOTO 2140 IERR = - 3 GOTO 2150 2140 CONTINUE IF (.NOT.(IOER .EQ. %LOC(SS$_NORMAL))) GOTO 2160 IF (.NOT.(TC .EQ. 26)) GOTO 2180 C EOF? (^Z) IERR = - 1 GOTO 2190 2180 CONTINUE IERR = TC 2190 CONTINUE GOTO 2170 2160 CONTINUE IF (.NOT.(IOER .EQ. %LOC(SS$_TIMEOUT))) GOTO 2200 IERR = - 2 GOTO 2210 2200 CONTINUE IERR = - 3 C$TYPE *,' IERR=',IERR 2210 CONTINUE 2170 CONTINUE 2150 CONTINUE RETURN END