158 lines
5.8 KiB
Fortran
158 lines
5.8 KiB
Fortran
C-----------------------------------------------------------------------
|
|
C Routines to perform consol I/O
|
|
C-----------------------------------------------------------------------
|
|
SUBROUTINE GWRITE (IDEV,DOLLAR)
|
|
CHARACTER DOLLAR*(*)
|
|
CHARACTER*132 COUT(20)
|
|
COMMON /IOUASC/ COUT
|
|
COMMON /IOUASS/ IOUNIT(10)
|
|
CHARACTER CR*1,LF*1,CRLF*2
|
|
CR = CHAR(13)
|
|
LF = CHAR(10)
|
|
CRLF(1:1) = CR
|
|
CRLF(2:2) = LF
|
|
ITP = IOUNIT(6)
|
|
C-----------------------------------------------------------------------
|
|
C First find out how many lines to output
|
|
C-----------------------------------------------------------------------
|
|
DO 10 I = 20,1,-1
|
|
IF (COUT(I) .NE. ' ') GO TO 20
|
|
10 CONTINUE
|
|
C-----------------------------------------------------------------------
|
|
C Nothing to print -- assume that we must want to output a blank line
|
|
C-----------------------------------------------------------------------
|
|
I = 1
|
|
20 NLINES = I
|
|
C-----------------------------------------------------------------------
|
|
C If the unit is not ITP then just do straight output to the device
|
|
C-----------------------------------------------------------------------
|
|
IF (IDEV .NE. ITP) THEN
|
|
IF (NLINES .GT. 1) THEN
|
|
DO 30 I = 1,NLINES-1
|
|
WRITE (IDEV,10000) COUT(I)(1:LINELN(COUT(I)))
|
|
30 CONTINUE
|
|
ENDIF
|
|
IF (DOLLAR .EQ. '$') THEN
|
|
WRITE (IDEV,10100) COUT(NLINES)(1:LINELN(COUT(I)))
|
|
ELSE
|
|
WRITE (IDEV,10000) COUT(NLINES)(1:LINELN(COUT(I)))
|
|
ENDIF
|
|
ELSE
|
|
DO 40 I = 1,NLINES-1
|
|
CALL WNTEXT (COUT(I)(1:LINELN(COUT(I))))
|
|
CALL SCROLL
|
|
40 CONTINUE
|
|
IF (COUT(NLINES)(1:1) .NE. '%')
|
|
$ CALL WNTEXT (COUT(NLINES)(1:LINELN(COUT(NLINES))))
|
|
IF (DOLLAR .EQ. '$') THEN
|
|
CALL WNTEXT (' ')
|
|
ELSE
|
|
CALL SCROLL
|
|
ENDIF
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C Just in case we will blank out COUT
|
|
C-----------------------------------------------------------------------
|
|
DO 50 I = 1,20
|
|
COUT(I) = ' '
|
|
50 CONTINUE
|
|
RETURN
|
|
10000 FORMAT (A)
|
|
10100 FORMAT (A,' ',$)
|
|
END
|
|
C-----------------------------------------------------------------------
|
|
C Function to return the length of a character string
|
|
C-----------------------------------------------------------------------
|
|
INTEGER FUNCTION LINELN (STRING)
|
|
CHARACTER STRING*(*)
|
|
DO 10 I = LEN(STRING),1,-1
|
|
IF (STRING(I:I) .NE. ' ') GO TO 20
|
|
10 CONTINUE
|
|
I = 1
|
|
20 LINELN = I
|
|
RETURN
|
|
END
|
|
C-----------------------------------------------------------------------
|
|
C GETLIN Read a line of input from the keyboard
|
|
C-----------------------------------------------------------------------
|
|
SUBROUTINE GETLIN (STRING)
|
|
CHARACTER STRING*(*)
|
|
INTEGER KEYGET
|
|
C-----------------------------------------------------------------------
|
|
C Do some housekeeping
|
|
C-----------------------------------------------------------------------
|
|
MAX = LEN(STRING)
|
|
STRING = ' '
|
|
INDEX = 0
|
|
C-----------------------------------------------------------------------
|
|
C Loop until we find either <cr> or control-C
|
|
C-----------------------------------------------------------------------
|
|
10 IC = KEYGET ()
|
|
C-----------------------------------------------------------------------
|
|
C Control C
|
|
C-----------------------------------------------------------------------
|
|
IF (IC .EQ. 3) THEN
|
|
STOP
|
|
C-----------------------------------------------------------------------
|
|
C Return -- line complete
|
|
C-----------------------------------------------------------------------
|
|
ELSE IF (IC .EQ. 13) THEN
|
|
CALL SCROLL
|
|
RETURN
|
|
C-----------------------------------------------------------------------
|
|
C Backspace or Delete
|
|
C-----------------------------------------------------------------------
|
|
ELSE IF (IC .EQ. 8 .OR. IC .EQ. 16) THEN
|
|
IF (INDEX .GE. 1) THEN
|
|
CALL WNCDEL
|
|
STRING(INDEX:INDEX) = ' '
|
|
INDEX = INDEX - 1
|
|
ENDIF
|
|
GO TO 10
|
|
C-----------------------------------------------------------------------
|
|
C Some other control character
|
|
C-----------------------------------------------------------------------
|
|
ELSE IF (IC .LE. 31) THEN
|
|
GO TO 10
|
|
C-----------------------------------------------------------------------
|
|
C Something we want!
|
|
C-----------------------------------------------------------------------
|
|
ELSE
|
|
INDEX = INDEX + 1
|
|
STRING(INDEX:INDEX) = CHAR(IC)
|
|
CALL WNTEXT (STRING(INDEX:INDEX))
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C Handle the case of more input than string length by eating characters
|
|
C while waiting for <return>. Backspace is handled correctly.
|
|
C-----------------------------------------------------------------------
|
|
IF (INDEX .GE. MAX) THEN
|
|
20 IC = KEYGET ()
|
|
IF (IC .EQ. 8 .OR. IC .EQ. 16) THEN
|
|
CALL WNCDEL
|
|
STRING(INDEX:INDEX) = ' '
|
|
INDEX = INDEX - 1
|
|
GO TO 10
|
|
ENDIF
|
|
IF (IC .NE. 13) GO TO 20
|
|
CALL SCROLL
|
|
RETURN
|
|
ENDIF
|
|
GO TO 10
|
|
END
|
|
C-----------------------------------------------------------------------
|
|
C Function KEYGET -- MS Fortran specific
|
|
C-----------------------------------------------------------------------
|
|
C INCLUDE 'FLIB.FI'
|
|
C FUNCTION KEYGET
|
|
C INCLUDE 'FLIB.FD'
|
|
C RECORD /REGS$INFO/ INREGS, OUTREGS
|
|
C INREGS.BREGS.AH = 8
|
|
C CALL INTDOSQQ (INREGS,OUTREGS)
|
|
C KEYGET = OUTREGS.BREGS.AL
|
|
C RETURN
|
|
C END
|
|
C-----------------------------------------------------------------------
|
|
C Function KEYSIN -- MS Fortran specific
|
|
C-----------------------------------------------------------------------
|