linse/sics
0
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Initial revision

Browse Source
This commit is contained in:
cvs
2000-02-07 10:38:55 +00:00
commit fdc6b051c9
846 changed files with 230218 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

115
difrac/gwrite.f Normal file
View File

@@ -0,0 +1,115 @@
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