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

PSI sics-cvs-psi_pre-ansto

Browse Source
This commit is contained in:
koennecke
2003-06-13 00:00:00 +00:00
committed by Douglas Clowes
parent 2e3ddfb6c6
commit 3ffd0d8af4
1099 changed files with 318432 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

157
difrac/prompt.f Normal file
View File

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