116 lines
4.1 KiB
Fortran
116 lines
4.1 KiB
Fortran
C-----------------------------------------------------------------------
|
|
C Routines to perform consol I/O
|
|
C-----------------------------------------------------------------------
|
|
SUBROUTINE GWRITE (IDEV,DOLLAR)
|
|
CHARACTER DOLLAR*(*)
|
|
CHARACTER*132 COUT
|
|
COMMON /IOUASC/ COUT(20)
|
|
COMMON /IOUASS/ IOUNIT(10)
|
|
CHARACTER CR*1,LF*1,CRLF*2,STATUS*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 100 I = 20,1,-1
|
|
IF (COUT(I) .NE. ' ') GO TO 110
|
|
100 CONTINUE
|
|
C-----------------------------------------------------------------------
|
|
C Must be just a blank line. Only here for safety - should not happen.
|
|
C-----------------------------------------------------------------------
|
|
I = 1
|
|
110 NLINES = I
|
|
IF (COUT(NLINES)(1:1) .EQ. '%') COUT(NLINES)(1:1) = ' '
|
|
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 120 I = 1,NLINES-1
|
|
WRITE (IDEV,10200) COUT(I)(1:LINELN(COUT(I)))
|
|
120 CONTINUE
|
|
ENDIF
|
|
IF (DOLLAR .EQ. '$') THEN
|
|
WRITE (IDEV,10000) COUT(NLINES)(1:LINELN(COUT(I)))
|
|
ELSE IF (DOLLAR .EQ. '%') THEN
|
|
WRITE (IDEV,10100) COUT(NLINES)(1:LINELN(COUT(I)))
|
|
ELSE
|
|
WRITE (IDEV,10200) COUT(NLINES)(1:LINELN(COUT(I)))
|
|
ENDIF
|
|
ELSE
|
|
C-----------------------------------------------------------------------
|
|
C Unit is ITP. Output in Windows compatible form.
|
|
C-----------------------------------------------------------------------
|
|
IF (NLINES .GT. 1) THEN
|
|
DO 130 I = 1,NLINES-1
|
|
CALL WNTEXT (COUT(I)(1:LINELN(COUT(I))))
|
|
CALL SCROLL
|
|
130 CONTINUE
|
|
ENDIF
|
|
CALL WNTEXT (COUT(NLINES)(1:LINELN(COUT(NLINES))))
|
|
IF (DOLLAR .EQ. '$') THEN
|
|
CALL WNTEXT (' ')
|
|
ELSE
|
|
IF (DOLLAR .NE. '%') CALL SCROLL
|
|
ENDIF
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C Blank out COUT in case some compilers dont
|
|
C-----------------------------------------------------------------------
|
|
DO 140 I = 1,20
|
|
COUT(I) = ' '
|
|
140 CONTINUE
|
|
RETURN
|
|
10000 FORMAT (A,' ',$)
|
|
10100 FORMAT (A,$)
|
|
10200 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 = 0
|
|
20 LINELN = I
|
|
RETURN
|
|
END
|
|
C-----------------------------------------------------------------------
|
|
C GETLIN Read a line of input from the keyboard
|
|
C-----------------------------------------------------------------------
|
|
SUBROUTINE GETLIN (STRING)
|
|
COMMON /IOUASS/ IOUNIT(10)
|
|
CHARACTER STRING*(*)
|
|
ITR = IOUNIT(5)
|
|
READ (ITR,10000) STRING
|
|
10000 FORMAT (A)
|
|
RETURN
|
|
END
|
|
C-----------------------------------------------------------------------
|
|
C WNTEXT Output text to a window
|
|
C-----------------------------------------------------------------------
|
|
SUBROUTINE WNTEXT (STRING)
|
|
COMMON /IOUASS/ IOUNIT(10)
|
|
CHARACTER STRING*(*)
|
|
ITP = IOUNIT(6)
|
|
WRITE (ITP,10000) STRING
|
|
10000 FORMAT (A,$)
|
|
RETURN
|
|
END
|
|
C-----------------------------------------------------------------------
|
|
C SCROLL Output a new-line
|
|
C-----------------------------------------------------------------------
|
|
SUBROUTINE SCROLL
|
|
COMMON /IOUASS/ IOUNIT(10)
|
|
ITP = IOUNIT(6)
|
|
WRITE (ITP,10000)
|
|
10000 FORMAT (1X)
|
|
RETURN
|
|
END
|
|
|