0001    C*****************************************************************
0002    C
0003    C	DEMO PROGRAM FOR SCREEN ROUTINES
0004    C
0005    C		LINK DEMO,GEN:SCRLIB/LIB
0006    C
0007    C	OR MAKE THE FOLLOWING ASSIGNMENT FOR DEFAULT LIBRARYS
0008    C
0009    C		ASSIGN GEN:SCRLIB.OLB LNK$LIBRARY
0010    C		LINK DEMO		!LINKING WITH DEFAULT LIBRARIES
0011    C
0012    C******************************************************************
0013    	PROGRAM DEMO
0014    	LOGICAL*1 LOGMODE,LOGKEY,FLAG
0015    	CHARACTER*80 CVAL,LINE*10
0016    	COMMON /FSEC_SCREEN_VALUE/ IVAL(50),RVAL(50),CVAL(50)
0017    	EQUIVALENCE (RLARGE,RVAL(1))
0018    	EQUIVALENCE (RBIGGEST,RVAL(2))
0019    	EQUIVALENCE (RSMALL,RVAL(3))
0020    	EQUIVALENCE (IBIG,IVAL(1))
0021    	EQUIVALENCE (ISMALL,IVAL(2))
0022    	EQUIVALENCE (LINE,CVAL(1))
0023    	DATA RLARGE,RBIGGEST,RSMALL /100.23,1000.33, 43.7/
0024    	DATA IBIG, ISMALL /500, 100/
0025    	DATA LINE /'CHARACTER'/
0026     
0027    C	---- OPEN SCREEN DEFINITION DATA FILE
0028    	OPEN (UNIT=1,NAME='DEMO.DAT',TYPE='OLD')
0029    C
0030     
0031    C	--- DISPLAY THIS DATA ND GET ANY MODIFICATIONS
0032    1	LOGMODE = .TRUE. 	!ENABLE EXCHANGE MODE
0033    	LOGKEY = .TRUE.		!ENABLE APPLICATIONS KEYPAD
0034    	IF (ISEC .EQ. 0) THEN
0035    		ISEC = 1	!FIRST TIME, USE SCREEN SECTION 1
0036    	ELSE
0037    		ISEC = -1	!OTHER TIMES, USE THE CURRENT SECTION
0038    C				!THIS SAVES READING SCREEN DEFINITION FILE 
0039    	ENDIF
0040    	IUNIT = 1
0041    	CALL SCR_SCRIN(ISEC, IUNIT, FLAG, LOGMODE, LOGKEY)
0042    	IF (FLAG) THEN
0043    		TYPE *,'OOPS, FATAL ERROR'
0044    		CALL EXIT
0045    	ENDIF
0046     
0047    C	---- DO SOMETHING WITH THE DATA AND PROMPT FOR MORE DATA
0048    	TYPE 5, RLARGE,RBIGGEST,RSMALL, IBIG, ISMALL, LINE
0049    5	FORMAT(/////,1X'RLARGE: ',F12.3/
0050         &		1X,'RBIGGEST: ',F12.3/
0051         &		1X,'RSMALL: ',F12.3/
0052         &		1X,'IBIG: ',I8/
0053         &		1X,'ISMALL ',I8/
0054         &		1X,'LINE: ',A)
0055     
0056     
0057    	TYPE 10

0058    10	FORMAT(/1X,'*** SCREEN UTILITY DEMO PROGRAM ***',
0059         &		/1X,'INPUT REAL NUMBER (F10.3): ',$)
0060    	READ *, RLARGE
0061     
0062    	TYPE 20
0063    20	FORMAT(/1X,'INPUT REAL NUMBER (F10.0): ',$)
0064    	READ *, RBIGGEST
0065     
0066    	TYPE 30
0067    30	FORMAT(/1X,'INPUT REAL NUMBER (F8.2): ',$)
0068    	READ *, RSMALL
0069     
0070    	TYPE 40
0071    40	FORMAT(/1X,'INPUT INTEGER NUMBER (I5): ',$)
0072    	READ *, IBIG
0073     
0074    	TYPE 50
0075    50	FORMAT(/1X,'INPUT INTEGER NUMBER (I3): ',$)
0076    	READ *,ISMALL
0077     
0078    	TYPE 60
0079    60	FORMAT(/1X,'INPUT CHARACTER (A10): ',$)
0080    	READ 65,LINE
0081    65	FORMAT(A)
0082    	GOTO 1
0083    	END

0001    C*********************************************************************
0002    C
0003    C	INCLUDE BLOCK FOR SCREEN ROUTINES
0004    C
0005    C*********************************************************************
0006    	CHARACTER*80 CHRSCREEN(24),TYPE*50,CVAL(50)
0007    	LOGICAL*1 LOGSCREEN(24,80)
0008    	INTEGER*2 ICHAN
0009    	DIMENSION IFRACT(50),LENGTH(50),IVAL(50),RVAL(50),IXY(50,2)
0010    	COMMON /FSEC_SCREEN/ LOGSCREEN,CHRSCREEN,ILIN,ICOL,
0011         &		ICHAN, TYPE,IFRACT,LENGTH,IXY, INUM_FIELDS, INUM_LINES
0012    	COMMON /FSEC_SCREEN_VALUE/ IVAL,RVAL,CVAL

0001    	SUBROUTINE SCR_BOTTOM
0002    C	---- MOVE CURSOR TO THE BOTTOM OF LOGICAL SCREEN
0003    	INCLUDE 'SCREEN.FOR'
0016    C
0017    	DO I=50,1,-1
0018    		IF(IXY(I,1).NE.0)GOTO 10
0019    	ENDDO
0020    C
0021    10	ICOL=IXY(I,2)
0022    	ILIN=IXY(I,1)
0023    	ISTAT=LIB$SET_CURSOR(ILIN,ICOL)
0024    		IF(.NOT.ISTAT)CALL LIB$STOP(%VAL(ISTAT))
0025    	RETURN
0026    	END

0001    	SUBROUTINE SCR_DECVAL
0002    C	---- DECODE ARRAYS CVAL, IVAL, AND RVAL FROM THE CHARACTER SCREEN
0003    	INCLUDE 'SCREEN.FOR'
0016    	IC=1
0017    	II=1
0018    	IR=1
0019    C
0020    	DO 100 I=1,INUM_FIELDS
0021     
0022    10	IROW = IXY(I,1)
0023    	ISTART = IXY(I,2)
0024    	IEND = ISTART + LENGTH(I) - 1
0025     
0026    	IF(TYPE(I:I).EQ.'A')THEN
0027    		CVAL(IC)(1:LENGTH(I)-1)= CHRSCREEN(IROW)(ISTART:IEND)
0028    		IC=IC+1
0029     
0030    	ELSE IF(TYPE(I:I).EQ.'I')THEN
0031    C		---- FIND FIRST NON-BLANK
0032    		IFIRST = ISTART
0033    		ISECOND = IEND
0034    		DO J = ISTART,IEND
0035    			IF (CHRSCREEN(IROW)(J:J).NE.' ') THEN
0036    				IFIRST = J
0037    				GOTO 20
0038    			ENDIF
0039    		ENDDO
0040    		GOTO 30	!FIELD IS ALL BLANK, SKIP IT
0041     
0042    C		---- FIND LAST NON-BLANK
0043    20		DO J = IFIRST,IEND
0044    			IF (CHRSCREEN(IROW)(J:J).EQ.' ') THEN
0045    				ISECOND = J-1
0046    				GOTO 30
0047    			ENDIF
0048    		ENDDO
0049     
0050    C		---- DECODE THE INTEGER
0051    30		ILEN = ISECOND - IFIRST + 1
0052    		READ (CHRSCREEN(IROW)(IFIRST:ISECOND), 101, ERR=50) IVAL(II)
0053    		II=II+1
0054     
0055    	ELSE IF(TYPE(I:I).EQ.'F')THEN
0056    		READ (CHRSCREEN(IROW)(ISTART:IEND), 102, ERR=60) RVAL(IR)
0057    		IR=IR+1
0058    	ENDIF
0059    	GOTO 100
0060     
0061    C	---- INTEGER DECODE ERRORS
0062    50	LEN = 1
0063    	IF (LENGTH(I).GT.9) LEN = 2
0064    	ISTAT = LIB$SET_CURSOR(24,1)
0065    	TYPE *
0066    	TYPE 55, I, II, CHRSCREEN(IROW)(ISTART:IEND), LENGTH(I)
0067    55	FORMAT(1X,'ERROR DECODING FIELD # ',I2,' INTEGER FIELD # ',I2,
0068         &		 ' FROM ',A,' WITH FORMAT I',I<LEN>/
0069         &		 ' PLEASE INPUT PROPER INTEGER VALUE: ',$)

0070    	READ 105, CHRSCREEN(IROW)(ISTART:IEND)
0071    	CALL SCR_WRTSECT
0072    	GOTO 10
0073     
0074    C	---- REAL DECODE ERRORS
0075    60	LEN = 1
0076    	IF (LENGTH(I).GT.9) LEN = 2
0077    	ISTAT = LIB$SET_CURSOR(24,1)
0078    	TYPE *
0079    	TYPE 65, I,IR, CHRSCREEN(IROW)(ISTART:IEND), LENGTH(I), IFRACT(I)
0080    65	FORMAT(1X,'ERROR DECODING FIELD # ',I2,' REAL FIELD # ',I2,
0081         &		 ' FROM ',A,' WITH FORMAT F',I<LEN>,'.',I1,/
0082         &		 ' PLEASE INPUT PROPER REAL VALUE: ',$)
0083    	READ 105, CHRSCREEN(IROW)(ISTART:IEND)
0084    	CALL SCR_WRTSECT
0085    	GOTO 10
0086    C
0087    100	CONTINUE
0088    101	FORMAT(I<ILEN>)
0089    102	FORMAT(F<LENGTH(I)>.<IFRACT(I)>)
0090    105	FORMAT(A)
0091    	RETURN
0092    	END

0001    	SUBROUTINE SCR_DELC(D_CHR)
0002    C	---- DELETE A SINGLE CHARACTER
0003    C	---- D_CHR SAVES THE DELETED CHARACTER FOR A POSSIBLE UNDELETE
0004     
0005    	CHARACTER*1 D_CHR,DUMLIN*80
0006    	INCLUDE 'SCREEN.FOR'
0019    C
0020    	D_CHR(1:1)=CHRSCREEN(ILIN)(ICOL:ICOL)
0021    C
0022    	DO I=1,80
0023    		IF(ICOL+I.EQ.80)GOTO 10
0024    		IF( LOGSCREEN(ILIN,ICOL+I) )THEN
0025    		 DUMLIN(I:I)=CHRSCREEN(ILIN)(ICOL+I:ICOL+I)
0026    		ELSE
0027    		 GOTO 10
0028    		ENDIF
0029    	ENDDO
0030    C
0031    10	DUMLIN(I:I) = ' '
0032    	CHRSCREEN(ILIN)(ICOL:ICOL+I-1)=DUMLIN(1:I)
0033    	ISTAT=LIB$PUT_SCREEN(CHRSCREEN(ILIN)(ICOL:ICOL+I-1),ILIN,ICOL)
0034    		IF(.NOT.ISTAT)CALL LIB$STOP(%VAL(ISTAT))
0035    	ISTAT=LIB$SET_CURSOR(ILIN,ICOL)
0036    		IF(.NOT.ISTAT)CALL LIB$STOP(%VAL(ISTAT))
0037    	RETURN
0038    	END

0001    	SUBROUTINE SCR_DELL(D_LINE,DL_LEN)
0002    C	---- DELETE A LINE, D_LINE SAVES THE DELETED LINE FOR A 
0003    C	----	POSSIBLE UN-DELETE LINE
0004    	CHARACTER*80 D_LINE
0005    	INTEGER DL_LEN
0006    	INCLUDE 'SCREEN.FOR'
0019    C
0020    	DO I=0,79
0021    	  IF(ICOL+I.GT.80)GOTO 10
0022    		IF(LOGSCREEN(ILIN,ICOL+I))THEN
0023    		  D_LINE(I+1:I+1)=CHRSCREEN(ILIN)(ICOL+I:ICOL+I)
0024    		  CHRSCREEN(ILIN)(ICOL+I:ICOL+I)=' '
0025    		ELSE
0026    		  GOTO 10
0027    		ENDIF
0028    	ENDDO
0029    C
0030    10	DL_LEN=I+1
0031    	ISTAT=LIB$PUT_SCREEN(CHRSCREEN(ILIN)(ICOL:ICOL+I),ILIN,ICOL)
0032    		IF(.NOT.ISTAT)CALL LIB$STOP(%VAL(ISTAT))
0033    	ISTAT=LIB$SET_CURSOR(ILIN,ICOL)
0034    		IF(.NOT.ISTAT)CALL LIB$STOP(%VAL(ISTAT))
0035     
0036    	RETURN
0037    	END

0001    	SUBROUTINE SCR_DELW(D_WORD,DW_LEN)
0002    C	---- DELETE A WORD, D_WORD SAVES THE DELETED WORD FOR A 
0003    C	----	POSSIBLE UN-DELETE WORD
0004    	CHARACTER*80 D_WORD
0005    	INTEGER DW_LEN
0006    	INCLUDE 'SCREEN.FOR'
0019    	LOGICAL*1 FOUND_SPACE
0020    C
0021    	FOUND_SPACE = .FALSE.
0022    	DO I=0,79
0023    	  IF(ICOL+I.GT.80 .OR. .NOT.LOGSCREEN(ILIN,ICOL+I))GOTO 10
0024     
0025    	  IF (.NOT.FOUND_SPACE) THEN
0026    		IF (CHRSCREEN(ILIN)(ICOL+I:ICOL+I) .EQ. ' ') THEN
0027    			ISPACE = ICOL+I
0028    			FOUND_SPACE = .TRUE.
0029    		ENDIF
0030     
0031    	  ENDIF
0032     
0033    	  D_WORD(I+1:I+1)=CHRSCREEN(ILIN)(ICOL+I:ICOL+I)
0034    	ENDDO
0035     
0036    C	---- REMOVE CURRENT WORD FROM ICOL TO ISPACE, PAD WITH BLANKS
0037    10	IF (.NOT.FOUND_SPACE) THEN
0038    C		---- IF NO SPACE, DEL TO EOL
0039    		CHRSCREEN(ILIN)(ICOL:ICOL+I-1) = ' '
0040     
0041    	ELSE
0042    C		---- DEL CURRENT WORD, DEL THE SPACE IF WE CAN
0043    		IF (LOGSCREEN(ILIN,ISPACE+1)) ISPACE = ISPACE+1
0044    		CHRSCREEN(ILIN)(ICOL:ICOL+I-1)=
0045         &			  CHRSCREEN(ILIN)(ISPACE:ICOL+I-1)//' '
0046     
0047    	ENDIF
0048    C
0049    	DW_LEN=I+1
0050    	ISTAT=LIB$PUT_SCREEN(CHRSCREEN(ILIN)(ICOL:ICOL+I),ILIN,ICOL)
0051    		IF(.NOT.ISTAT)CALL LIB$STOP(%VAL(ISTAT))
0052    	ISTAT=LIB$SET_CURSOR(ILIN,ICOL)
0053    		IF(.NOT.ISTAT)CALL LIB$STOP(%VAL(ISTAT))
0054     
0055    	RETURN
0056    	END

0001    	SUBROUTINE SCR_ENCVAL
0002    C	---- ENCODE USER ARRAYS INTO CHARACTER SCREEN
0003     
0004    	INCLUDE 'SCREEN.FOR'
0017    	IC=1
0018    	II=1
0019    	IR=1
0020    C
0021    	DO 100 I=1,INUM_FIELDS
0022     
0023    10	IROW = IXY(I,1)
0024    	ISTART = IXY(I,2)
0025    	IEND = ISTART + LENGTH(I) - 1
0026     
0027    	IF(TYPE(I:I).EQ.'A')THEN
0028    		CHRSCREEN(IROW)(ISTART:IEND) = CVAL(IC)(1:LENGTH(I))
0029    		IF (INDEX(CHRSCREEN(IROW)(ISTART:IEND),CHAR(0)).NE.0)THEN
0030     
0031    			DO J=ISTART,IEND	!HANDLE BLANKS
0032    				IF (CHRSCREEN(IROW)(J:J).EQ.CHAR(0)) 
0033         &				    CHRSCREEN(IROW)(J:J)=' '
0034    			ENDDO
0035    		ENDIF
0036    		IC=IC+1
0037     
0038    	ELSE IF(TYPE(I:I).EQ.'I')THEN
0039    		WRITE (CHRSCREEN(IROW)(ISTART:IEND),101,ERR=50) IVAL(II)
0040    		II=II+1
0041     
0042    	ELSE IF(TYPE(I:I).EQ.'F')THEN
0043    		WRITE (CHRSCREEN(IROW)(ISTART:IEND),102,ERR=60) RVAL(IR)
0044    		IR=IR+1
0045    	ENDIF
0046    	GOTO 100
0047     
0048    C	---- ERROR ENCODING INTEGERS
0049    50	LEN = 1
0050    	IF (LENGTH(I).GT.9) LEN=2
0051    	ISTAT = LIB$SET_CURSOR(24,1)
0052    	TYPE *
0053    	TYPE 55,I,II,IVAL(II),LENGTH(I)
0054    55	FORMAT(1X,'ERROR ENCODING FIELD # ',I2,' INTEGER # ',I2,
0055         &		' WITH VALUE ',I10,' USING FORMAT I',I<LEN>/
0056         &		' PLEASE INPUT NEW INTEGER VALUE: ',$)
0057    	READ *,IVAL(II)
0058    	CALL SCR_WRTSECT
0059    	GOTO 10
0060     
0061    C	---- ERROR ENCODING REALS
0062    60	LEN = 1
0063    	IF (LENGTH(I).GT.9) LEN=2
0064    	ISTAT = LIB$SET_CURSOR(24,1)
0065    	TYPE *
0066    	TYPE 65,I,II,RVAL(II),LENGTH(I), IFRACT(I)
0067    65	FORMAT(1X,'ERROR ENCODING FIELD # ',I2,' REAL # ',I2,
0068         &		' WITH VALUE ',E12.4,' USING FORMAT R',I<LEN>,'.',I1/
0069         &		' PLEASE INPUT NEW REAL VALUE: ',$)

0070    	READ *,RVAL(IR)
0071    	CALL SCR_WRTSECT
0072    	GOTO 10
0073    C
0074    100	CONTINUE
0075    101	FORMAT(I<LENGTH(I)>)
0076    102	FORMAT(F<LENGTH(I)>.<IFRACT(I)>)
0077    	RETURN
0078    	END

0001    	SUBROUTINE SCR_EOL(DIRECT)
0002    C	---- MOVE THE CURSOR TO THE END OF THIS FIELD
0003    	INCLUDE 'SCREEN.FOR'
0016    	LOGICAL*1 DIRECT
0017    C
0018    C	---- IF DIRECTION IS FORWARDS
0019    	IF (DIRECT) THEN
0020    10		ILASTCOL = ICOL
0021    		DO I=ICOL,80		!FIND LAST NON-BLANK IN THIS FIELD
0022    			IF (.NOT.LOGSCREEN(ILIN,I)) GOTO 100
0023    			IF (CHRSCREEN(ILIN)(I:I).NE.' ') ILASTCOL = I
0024    		ENDDO
0025     
0026    C		---- CHECK TO SEE IF WE WERE AT THE END OF LINE TO START WITH
0027    C		---- AND WE NEED TO GO TO THE END OF THE NEXT FIELD
0028    100		IF (ICOL .EQ. ILASTCOL) THEN
0029    			ILASTLIN = ILIN
0030    			CALL SCR_NEXTFLD(DIRECT)
0031    C			---- SEE IF THERE IS A NEW FIELD, IF SO MOVE EOL
0032    			IF (ILIN .GT. ILASTLIN) GOTO 10
0033    			IF (ICOL .GT. ILASTCOL) GOTO 10
0034    C			---- WE MUST BE AT BOTTOM OF SCREEN
0035    		ENDIF
0036    		IF (LOGSCREEN(ILIN,ILASTCOL+1).AND. ILASTCOL.NE.80) THEN
0037    			ICOL = ILASTCOL+1	!MOVE TO NEXT AVAILABLE CHAR
0038    		ELSE
0039    			ICOL = ILASTCOL	!CANN'T OVERFLOW FIELD
0040    		ENDIF
0041     
0042    	ELSE
0043     
0044    C	---- MOVE BACKWARDS THRU SCREEN
0045    		ILASTCOL = ICOL
0046    		CALL SCR_NEXTFLD(DIRECT)	!GO TO BEGINNING OF CURRENT FIELD
0047    		CALL SCR_NEXTFLD(DIRECT)	!GO TO BEGINNING OF NEXT EARLIER FIELD
0048     
0049    C		---- NOW MOVE TO THE END OF THIS FIELD
0050    		DO I=ICOL,80		!FIND LAST NON-BLANK IN THIS FIELD
0051    			IF (.NOT.LOGSCREEN(ILIN,I)) GOTO 200
0052    			IF (CHRSCREEN(ILIN)(I:I).NE.' ') ILASTCOL = I
0053    		ENDDO
0054     
0055    200		IF (LOGSCREEN(ILIN,ILASTCOL+1).AND. ILASTCOL.NE.80) THEN
0056    			ICOL = ILASTCOL+1	!MOVE TO NEXT AVAILABLE CHAR
0057    		ELSE
0058    			ICOL = ILASTCOL	!CANN'T OVERFLOW FIELD
0059    		ENDIF
0060     
0061    	ENDIF
0062    	ISTAT=LIB$SET_CURSOR(ILIN,ICOL)
0063    		IF(.NOT.ISTAT)CALL LIB$STOP(%VAL(ISTAT))
0064    	RETURN
0065    	END

0001    	SUBROUTINE SCR_GETLOGSCR
0002    C	---- FILL LOGICAL SCREEN ARRAY WITH TRUE IF THERE ARE DATA
0003    C	----	VALUES AT THE SCREEN POSITION
0004    	INCLUDE 'SCREEN.FOR'
0017    	ICNT=0
0018    C
0019    	DO 30 I=1,24
0020    		IPOS=1
0021    10		J=INDEX(CHRSCREEN(I)(IPOS:80),'_')
0022    		IF(J.EQ.0)GOTO 30
0023    		J=J+IPOS-1
0024    		ICNT=ICNT+1
0025    		IXY(ICNT,1)=I	!SAVE SCREEN LINE NUMBER
0026    		IXY(ICNT,2)=J	!SAVE THIS FIELD'S STARTING POSITION
0027    		CALL SCR_ICLEN(J,I,LEN)
0028    		LENGTH(ICNT)=LEN	!SAVE THIS FIELD'S LENGTH
0029    		IPOS=J+LEN
0030    		GOTO 10
0031    30	CONTINUE
0032    	IF (ICNT .GT. INUM_FIELDS) THEN
0033    		TYPE 40, ICNT, INUM_FIELDS
0034    40		FORMAT(1X,'ERROR: ',I3,' FIELDS FOUND IN THIS SCREEN',
0035         &		' ONLY ',I3,' WERE DEFINED',
0036         &		/1X,'		PLEASE CHECK YOUR FIELD DEFINITIONS')
0037    		CALL EXIT
0038    	ENDIF
0039    	RETURN
0040    	END

0001    	SUBROUTINE SCR_GETMODE(IMODE)
0002    C********************************************************************
0003    C
0004    C	DETERMINE WHAT MODE USER IS IN
0005    C
0006    C	IMODE = 1 IS INTERACTIVE MODE OR COMMAND FILE WITH DEFINE/USER_MODE
0007    C		2 IS COMMAND FILE WITHOUT DEFINE/USER_MODE
0008    C		3 IS BATCH MODE
0009    C		4 IS UNKNOWN MODE
0010    C
0011    C********************************************************************
0012    	CHARACTER*80 SYS$INPUT,TT,SYS$COMMAND
0013     
0014    	ISTAT = LIB$SYS_TRNLOG('TT',ILEN_TT,TT)
0015    		IF(.NOT.ISTAT)CALL LIB$STOP(%VAL(ISTAT))
0016     
0017    	ISTAT = LIB$SYS_TRNLOG('SYS$INPUT',ILEN_INP,SYS$INPUT)
0018    		IF(.NOT.ISTAT)CALL LIB$STOP(%VAL(ISTAT))
0019    		SYS$INPUT(1:) = SYS$INPUT(5:)
0020    		ILEN_INP = ILEN_INP - 4
0021     
0022    	ISTAT = LIB$SYS_TRNLOG('SYS$COMMAND',ILEN_COM,SYS$COMMAND)
0023    		IF(.NOT.ISTAT)CALL LIB$STOP(%VAL(ISTAT))
0024    		SYS$COMMAND(1:) = SYS$COMMAND(5:)
0025    		ILEN_COM = ILEN_COM - 4
0026     
0027    	IF (ILEN_TT .LT. 6 .OR. ILEN_INP .LT. 6 .OR. ILEN_COM .LT. 6) THEN
0028    		IMODE = 4	!UNKNOWN LENGTHS
0029     
0030    	ELSE IF	((TT(:6).EQ. SYS$INPUT(:6)) .AND.
0031         &		(TT(:6).EQ. SYS$COMMAND(:6)) .AND.
0032         &		(SYS$INPUT(:6) .EQ. SYS$COMMAND(:6))) THEN
0033     
0034    C		---- ALL THREE THE SAME, MUST BE INTERACTIVE MODE
0035    		IMODE = 1
0036     
0037    	ELSE IF	((TT(:6) .EQ. SYS$COMMAND(:6)) .AND.
0038         &		(SYS$INPUT(:ILEN_INP) .EQ. 'COMMAND')) THEN
0039     
0040    C		---- MUST BE IN COMMAND FILE WITH DEFINE/USER_MODE
0041    		IMODE = 1
0042     
0043    	ELSE IF ((TT(:6) .EQ. SYS$COMMAND(:6)) .AND.
0044         &		(SYS$INPUT(:6) .NE. SYS$COMMAND(:6))) THEN
0045     
0046    C		---- MUST BE IN COMMAND FILE WITHOUT DEFINE/USER_MODE
0047    		IMODE = 2
0048     
0049    	ELSE IF ((TT(:6) .NE. SYS$COMMAND(:6))) THEN
0050     
0051     
0052    C		---- MUST BE IN BATCH MODE
0053    		IMODE = 3
0054     
0055    	ELSE
0056     
0057    C		---- UNKNOWN MODE
0058    		IMODE = 4
0059    	ENDIF
0060    	RETURN
0061    	END

0001    	SUBROUTINE SCR_GETSYMBOL(INSTRING,OUTSTRING)
0002    C	---- GET VALUE OF CLI SYMBOL
0003    	CHARACTER*(*) INSTRING,OUTSTRING
0004     
0005    	ISTAT = LIB$GET_SYMBOL(INSTRING,OUTSTRING)
0006    	IF (.NOT.ISTAT) THEN
0007    		OUTSTRING = 'NOT_DEFINED'
0008    	ENDIF
0009    	RETURN
0010    	END

0001    	SUBROUTINE SCR_ICLEN(J,I,LEN)
0002    C	---- COUNT THE "_" IN A FIELD AND RETURN FIELD'S LENGTH
0003    	INCLUDE 'SCREEN.FOR'
0016    	LEN=0
0017    C
0018    	DO 10 K=J,80
0019    		IF(CHRSCREEN(I)(K:K).NE.'_')GOTO 20
0020    		LOGSCREEN(I,K)=.TRUE.
0021    		LEN=LEN+1
0022    10	CONTINUE
0023    20	RETURN
0024    	END

0001    	SUBROUTINE SCR_IOCHAN(ICHAN)
0002    C	---- ESTABLISH IOCHANNEL TO TT:
0003    	INTEGER*4 SYS$ASSIGN
0004    	INTEGER*2 ICHAN
0005    	ISTAT=SYS$ASSIGN('TT:',ICHAN,,)
0006    		IF(.NOT.ISTAT)CALL LIB$STOP(%VAL(ISTAT))
0007    	RETURN
0008    	END

0001    	SUBROUTINE SCR_KEYHELP(LOGMODE,LOGKEY)
0002    C
0003    C	The variables passed to KEYHELP define how the keypad
0004    C	is to perform.  They can not be modified by this routine.
0005    C	This routine's sole purpose is to display in bold print
0006    C	how the keypad is defined.
0007    C
0008    C
0009    C	WRITTEN BY  G. LAND  APRIL 2, 1985
0010    C_________________________________________________________________
0011    	LOGICAL*1 LOGKEY,LOGMODE
0012    	INCLUDE 'SCREEN.FOR'
0025    	CHARACTER*1 IANS
0026    C
0027    C	CLEAR SCREEN
0028    C
0029    	CALL LIB$ERASE_PAGE(1,1)
0030    C
0031    C	DRAW OUTLINE OF KEYPAD
0032    C
0033    C	HORIZONTAL LINES
0034    C
0035    	DO 20 J=1,21,4
0036    	DO 10 I=2,58
0037    	IF(J.EQ.17.AND.I.EQ.44)GOTO 20
0038    	CALL LIB$PUT_SCREEN('-',J,I)
0039    10	CONTINUE
0040    20	CONTINUE
0041    C
0042    C	VERTICAL LINES
0043    C
0044    	DO 50 J=2,20
0045    	DO 40 I=2,58,14
0046    	IF(J.GT.16.AND.I.EQ.16)GOTO 40
0047    	CALL LIB$PUT_SCREEN('|',J,I)
0048    40	CONTINUE
0049    50	CONTINUE
0050    C
0051    C	PRINT FUNCTION KEYS 
0052    C
0053    	IFLAG=0
0054    	CALL LIB$PUT_SCREEN('PF1',2,4,IFLAG)
0055    	CALL LIB$PUT_SCREEN('PF2',2,18,IFLAG)
0056    	CALL LIB$PUT_SCREEN('PF3',2,32,IFLAG)
0057    	CALL LIB$PUT_SCREEN('PF4',2,46,IFLAG)
0058    C
0059    C	IF ALTERNATE KEYPAD WAS SELECTED PRINT NUMERIC KEY DESIGNATIONS
0060    C	NORMAL.  IF NUMERIC KEYPAD WAS SELECTED PRINT NUMERIC KEY
0061    C	DESIGNATIONS BOLD STYLE.
0062    C
0063    	IF(LOGKEY)THEN
0064    		IFLAG=0
0065    	ELSE
0066    		IFLAG=1
0067    	END IF
0068    	CALL LIB$PUT_SCREEN('7',6,4,IFLAG)
0069    	CALL LIB$PUT_SCREEN('8',6,18,IFLAG)

0070    	CALL LIB$PUT_SCREEN('9',6,32,IFLAG)
0071    	CALL LIB$PUT_SCREEN('-',6,46,IFLAG)
0072    	CALL LIB$PUT_SCREEN('4',10,4,IFLAG)
0073    	CALL LIB$PUT_SCREEN('5',10,18,IFLAG)
0074    	CALL LIB$PUT_SCREEN('6',10,32,IFLAG)
0075    	CALL LIB$PUT_SCREEN(',',10,46,IFLAG)
0076    	CALL LIB$PUT_SCREEN('1',14,4,IFLAG)
0077    	CALL LIB$PUT_SCREEN('2',14,18,IFLAG)
0078    	CALL LIB$PUT_SCREEN('3',14,32,IFLAG)
0079    	CALL LIB$PUT_SCREEN('ENTER',14,46,IFLAG)
0080    	CALL LIB$PUT_SCREEN('0',18,4,IFLAG)
0081    	CALL LIB$PUT_SCREEN('.',18,32,IFLAG)
0082    C
0083    C	IF ALTERNATE KEYPAD WAS SELECTED PRINT ALTERNATE KEY
0084    C	DESIGNATIONS BOLD STYLE.  IF NUMERIC KEYPAD WAS SELECTED
0085    C	PRINT ALTERNATE KEY DESIGNATIONS NORMAL STYLE.
0086    C
0087    	IF(LOGKEY)THEN
0088    		IFLAG=1
0089    	ELSE
0090    		IFLAG=0
0091    	END IF
0092    	CALL LIB$PUT_SCREEN('GOLD',3,7,IFLAG,2)
0093    	CALL LIB$PUT_SCREEN('HELP',3,21,IFLAG)
0094    	CALL LIB$PUT_SCREEN('TOGGLE',3,34,IFLAG)
0095    	CALL LIB$PUT_SCREEN('DEL L',3,49,IFLAG)
0096    	CALL LIB$PUT_SCREEN('KEYPAD',4,34,IFLAG)
0097    	CALL LIB$PUT_SCREEN('UND L',4,49,IFLAG,2)
0098    	CALL LIB$PUT_SCREEN('UNDEFINED',7,4,IFLAG)
0099    	CALL LIB$PUT_SCREEN('UNDEFINED',7,18,IFLAG)
0100    	CALL LIB$PUT_SCREEN('UNDEFINED',7,32,IFLAG)
0101    	CALL LIB$PUT_SCREEN('DEL W',7,49,IFLAG)
0102    	CALL LIB$PUT_SCREEN('UND W',8,49,IFLAG,2)
0103    	CALL LIB$PUT_SCREEN('ADVANCE',11,5,IFLAG)
0104    	CALL LIB$PUT_SCREEN('BACKUP',11,20,IFLAG)
0105    	CALL LIB$PUT_SCREEN('UNDEFINED',11,32,IFLAG)
0106    	CALL LIB$PUT_SCREEN('DEL C',11,49,IFLAG)
0107    	CALL LIB$PUT_SCREEN('BOTTOM',12,6,IFLAG,2)
0108    	CALL LIB$PUT_SCREEN('TOP',12,21,IFLAG,2)
0109    	CALL LIB$PUT_SCREEN('UND C',12,49,IFLAG,2)
0110    	CALL LIB$PUT_SCREEN('NEXT',15,7,IFLAG)
0111    	CALL LIB$PUT_SCREEN('EOL',15,21,IFLAG)
0112    	CALL LIB$PUT_SCREEN('UNDEFINED',15,32,IFLAG)
0113    	CALL LIB$PUT_SCREEN('WORD',16,7,IFLAG)
0114    	CALL LIB$PUT_SCREEN('DEL EOL',16,19,IFLAG,2)
0115    	CALL LIB$PUT_SCREEN('DONE',17,49,IFLAG)
0116    	CALL LIB$PUT_SCREEN('NEXT',19,14,IFLAG)
0117    	CALL LIB$PUT_SCREEN('TOGGLE',19,34,IFLAG)
0118    	CALL LIB$PUT_SCREEN('FIELD',20,14,IFLAG)
0119    	CALL LIB$PUT_SCREEN('EXC/INS',20,34,IFLAG)
0120    C
0121    C	PUT STATUS LINE AT BOTTOM
0122    C
0123    	CALL LIB$PUT_SCREEN('/',23,16)
0124    	CALL LIB$PUT_SCREEN('/',23,55)
0125    	IF(LOGMODE)THEN
0126    		CALL LIB$PUT_SCREEN('EXCHANGE MODE',23,2,1)

0127    		CALL LIB$PUT_SCREEN('INSERT MODE',23,18)
0128    	ELSE
0129    		CALL LIB$PUT_SCREEN('EXCHANGE MODE',23,2)
0130    		CALL LIB$PUT_SCREEN('INSERT MODE',23,18,1)
0131    	END IF
0132    C
0133    	IF(LOGKEY)THEN
0134    		CALL LIB$PUT_SCREEN('ALTERNATE KEYPAD',23,38,1)
0135    		CALL LIB$PUT_SCREEN('NUMERIC KEYPAD',23,57)
0136    	ELSE
0137    		CALL LIB$PUT_SCREEN('ALTERNATE KEYPAD',23,38)
0138    		CALL LIB$PUT_SCREEN('NUMERIC KEYPAD',23,57,1)
0139    	END IF
0140    	CALL LIB$PUT_SCREEN('^W := PAINT ^V := VALUE ^B := INVERSE',
0141         &		24,38)
0142    	CALL LIB$PUT_SCREEN('PRESS RETURN TO EXIT HELP',24,1)
0143    	ACCEPT 100,IANS(1:1)
0144    100	FORMAT(A)
0145    	CALL SCR_WRTSECT
0146    	CALL LIB$SET_CURSOR(ILIN,ICOL)
0147    	RETURN
0148    	END

0001    	SUBROUTINE SCR_KEYPAD(LOGKEY)
0002    C	---- TOGGLES THE KEYPAD BETWEEN APPLICATION MODE AND NUMERIC MODE
0003     
0004    	INCLUDE 'SCREEN.FOR'
0017    	LOGICAL*1 LOGKEY
0018    	IF(LOGKEY)THEN
0019    		WRITE(6,1)27,61
0020    	ELSE
0021    		WRITE(6,1)27,62
0022    	ENDIF
0023    1	FORMAT('+',2A1,$)
0024    	RETURN
0025    	END

0001    	SUBROUTINE SCR_NEXTFLD(DIRECT)
0002    C	---- MOVE THE CURSOR TO THE NEXT FIELD FORWARDS OR BACKWARDS
0003    C	----	DEPENDING ON THE DIRECTION FLAG (.TRUE. = FORWARDS)
0004    	LOGICAL*1 DIRECT
0005    	INCLUDE 'SCREEN.FOR'
0018    C
0019    	IF(DIRECT)THEN
0020    		DO I=1,50
0021    		  IF(IXY(I,1).EQ.ILIN.AND.IXY(I,2).GT.ICOL)GOTO 100
0022    		  IF(IXY(I,1).GT.ILIN)GOTO 100
0023    		ENDDO
0024    		GOTO 110
0025    	ENDIF
0026    C
0027    	DO I=50,1,-1
0028    	  IF(IXY(I,1).EQ.ILIN.AND.IXY(I,2).LT.ICOL)GOTO 100
0029    	  IF(IXY(I,1).LT.ILIN.AND.IXY(I,1).NE.0)GOTO 100
0030    	ENDDO
0031    C
0032    	GOTO 110
0033    C
0034    100	ILIN=IXY(I,1)
0035    	ICOL=IXY(I,2)
0036    	ISTAT=LIB$SET_CURSOR(ILIN,ICOL)
0037    		IF(.NOT.ISTAT)CALL LIB$STOP(%VAL(ISTAT))
0038    110	RETURN
0039    	END

0001    	SUBROUTINE SCR_NEXTWD(DIRECT)
0002    C	---- MOVE TO THE NEXT WORD DEPENDING ON LOGICAL DIRECTION
0003    C	----	(.TRUE. = FORWARDS)
0004    	LOGICAL*1 DIRECT, NONBLANK
0005    	INCLUDE 'SCREEN.FOR'
0018    C
0019    	NONBLANK = .FALSE.
0020    	IF(DIRECT)THEN
0021    	  DO I=ICOL+1,80
0022    		IF(.NOT.LOGSCREEN(ILIN,I))THEN
0023     
0024    C		  ---- NO SPACE FOUND, GO TO NEXT FIELD IF THERE IS ONE
0025    		  ILASTCOL = I-1
0026    		  ILASTLIN = ILIN
0027    		  CALL SCR_NEXTFLD(DIRECT)
0028    C		  --- SEE IF THERE IS A NEW FIELD, IS SO MOVE TO IT
0029    		  IF (ILIN .GT. ILASTLIN) THEN
0030    C			--- OKAY TO MOVE TO NEXT FIELD ON NEXT LINE
0031    		  ELSE IF (ICOL .GT. ILASTCOL) THEN
0032    C			--- OKAY TO MOVE TO NEXT FIELD ON SAME LINE
0033    		  ELSE
0034    			ICOL = ILASTCOL	!NO MORE FIELDS, STAY PUT
0035    			ILIN = ILASTLIN	
0036    		  ENDIF
0037    		  GOTO 110
0038    		ENDIF
0039    		IF(CHRSCREEN(ILIN)(I:I).NE.' ') NONBLANK = .TRUE.
0040    		IF(NONBLANK .AND. CHRSCREEN(ILIN)(I:I).EQ.' ')GOTO 100
0041    	  ENDDO
0042    	 GOTO 100
0043    	ENDIF
0044    C
0045    	DO I=ICOL-1,1,-1
0046    		IF(.NOT.LOGSCREEN(ILIN,I))THEN
0047     
0048    C		  ---- NO SPACE FOUND, GO TO NEXT FIELD IF THERE IS ONE
0049    		  ILASTCOL = I+1
0050    		  ILASTLIN = ILIN
0051    		  CALL SCR_EOL(DIRECT)
0052    		  IF (ILIN .EQ. ILASTLIN .AND. ILASTCOL.LE. ICOL) THEN
0053    			  ICOL = ILASTCOL
0054    			  ILIN = ILASTLIN
0055    			  GOTO 110	!NO MOVE FIELDS, MOVE TO BEGINNING 
0056    		  ELSE 
0057    			  RETURN	!STAY AT EOL OF EARLIER FIELD
0058    		  ENDIF
0059    		ENDIF
0060    		IF(CHRSCREEN(ILIN)(I:I).NE.' ') NONBLANK = .TRUE.
0061    		IF(NONBLANK .AND. CHRSCREEN(ILIN)(I:I).EQ.' ')GOTO 100
0062    	ENDDO
0063    C
0064    100	ICOL=I
0065    110	ISTAT=LIB$SET_CURSOR(ILIN,ICOL)
0066    		IF(.NOT.ISTAT)CALL LIB$STOP(%VAL(ISTAT))
0067    	RETURN
0068    	END

0001    	SUBROUTINE SCR_PUTCHR(LOGMODE,ICHR)
0002    C	---- PUTS CHARACTER ON THE SCREEN IN EITHER EXCHANGE MODE OR INSERT
0003    C	----	MODE DEPENDING ON THE VALUE OF LOGMODE
0004    C	----	(.TRUE. = EXCHANGE)
0005     
0006    	INCLUDE 'SCREEN.FOR'
0019    	CHARACTER*1 CHR,CHRLINE*80
0020    	CHR=CHAR(ICHR)
0021    C
0022    	IF(LOGMODE)THEN		!EXCHANGE MODE
0023    		ISTAT=LIB$PUT_SCREEN(CHR(1:),ILIN,ICOL)
0024    		IF(.NOT.ISTAT)CALL LIB$STOP(%VAL(ISTAT))
0025    		CHRSCREEN(ILIN)(ICOL:ICOL)=CHR(1:)
0026    		GOTO 1000
0027    	ENDIF
0028    C
0029    	DO I=ICOL,80		!INSERT MODE
0030    		IF(LOGSCREEN(ILIN,I))THEN
0031    		CHRLINE(I:I)=CHRSCREEN(ILIN)(I:I)
0032    	ELSE
0033    		GOTO 10
0034    	ENDIF
0035    	ENDDO
0036    C
0037    10	CHRSCREEN(ILIN)(ICOL+1:I-1)=CHRLINE(ICOL:I-2)
0038    	CHRSCREEN(ILIN)(ICOL:ICOL)=CHR(1:1)
0039    	ISTAT=LIB$PUT_SCREEN(CHRSCREEN(ILIN)(ICOL:ICOL+I-1),ILIN,ICOL)
0040    		IF(.NOT.ISTAT)CALL LIB$STOP(%VAL(ISTAT))
0041    1000	IF(LOGSCREEN(ILIN,ICOL+1))ICOL=ICOL+1
0042    	ISTAT=LIB$SET_CURSOR(ILIN,ICOL)
0043    		IF(.NOT.ISTAT)CALL LIB$STOP(%VAL(ISTAT))
0044    	RETURN
0045    	END

0001    	SUBROUTINE SCR_RDBATCH
0002    C	---- READ INPUT DATA FROM UNIT 5 (SYS$INPUT)
0003    	INCLUDE 'SCREEN.FOR'
0016    C
0017    	IC = 0
0018    	II = 0
0019    	IR = 0
0020     
0021    	DO I=1,INUM_LINES
0022    		IF (TYPE(I:I) .EQ.'A') THEN
0023    			IC = IC + 1
0024    			READ (5,10,ERR=100,END=150) CVAL(IC)
0025    10			FORMAT(A)
0026    		ELSE IF (TYPE(I:I) .EQ. 'I') THEN
0027    			II = II + 1
0028    			READ (5,*,ERR=200,END=150) IVAL(II)
0029    		ELSE IF (TYPE (I:I) .EQ. 'F') THEN
0030    			IR = IR + 1
0031    			READ (5,*,ERR=300,END=150) RVAL(IR)
0032    		ENDIF
0033    	ENDDO
0034    	RETURN
0035     
0036    100	TYPE *,'ERROR READING CHAR # ',IC
0037    	RETURN
0038    150	TYPE *,'END OF DATA ON CHAR # ',IC
0039    	RETURN
0040     
0041    200	TYPE *,'ERROR READING INTEGER # ',II
0042    	RETURN
0043    250	TYPE *,'END OF DATA ON CHAR # ',II
0044    	RETURN
0045     
0046    300	TYPE *,'ERROR READING REAL # ',IR
0047    	RETURN
0048    350	TYPE *,'END OF DATA ON CHAR # ',IR
0049    	RETURN
0050    	END

0001    	SUBROUTINE SCR_RDCHR(ICHAN,ICHR)
0002    C	---- POST A QIO TO READ THE INPUT WITH NO ECHO
0003    	INCLUDE '($IODEF)'
0414    	INTEGER*2 IOSB(4),ICHAN
0415    	INTEGER*4 TERMINATOR(2),SYS$QIOW
0416    	BYTE ICHR
0417    	TERMINATOR(1)=0
0418    	TERMINATOR(2)=0
0419    C
0420    	ISTAT=SYS$QIOW(,%VAL(ICHAN),
0421         &	%VAL(IO$_TTYREADALL.OR.IO$M_NOECHO),IOSB,,,
0422         &	ICHR,%VAL(1),,TERMINATOR,,)
0423    		IF(.NOT.ISTAT)CALL LIB$STOP(%VAL(ISTAT))
0424    		IF(.NOT.IOSB(1))CALL LIB$STOP(%VAL(IOSB(1)))
0425    	RETURN
0426    	END

0001    	SUBROUTINE SCR_RDSECT(FLAG,ISEC,IUNIT)
0002    C	---- READ IN THE SCREEN IMAGE AND FIELD DESCRIPTIONS FROM AN 
0003    C	----	ASCII FILE
0004    	INCLUDE 'SCREEN.FOR'
0017    	LOGICAL*1 FLAG
0018    	CHARACTER*80 LINE
0019    C
0020    	CALL SCR_RESETSCR
0021    	FLAG=.TRUE.
0022    	REWIND(UNIT=IUNIT,ERR=900,IOSTAT=ISTAT)
0023    C
0024    1	READ(IUNIT,10,END=910)LINE
0025    10	FORMAT(A)
0026    	IF(LINE(1:8).NE.'SECTION ')GOTO 1
0027    C
0028    	READ(LINE,20) ISECTNO
0029    20	FORMAT(8X,I1)
0030    	IF(ISECTNO.NE.ISEC)GOTO 1
0031    C
0032    	DO 30 NL=1,25
0033    	READ(IUNIT,10,END=920)LINE
0034    	IF(LINE(1:11).EQ.'END SECTION')GOTO 40
0035    	IF(NL.EQ.25)GOTO 920
0036    	CHRSCREEN(NL)(1:80)=LINE(1:80)
0037    30	CONTINUE
0038    C
0039    40	DO 60 ND=1,51
0040    	  READ(IUNIT,10,END=930)LINE
0041    	  IF(LINE(1:8).EQ.'END DATA')GOTO 100
0042    	  IF(ND.EQ.51)GOTO 930
0043     
0044    	READ(LINE, 50,ERR=940)I,TYPE(I:I),IFRACT(I)
0045    50	FORMAT(I2,1X,A,1X,I1)
0046    60	CONTINUE
0047    C
0048    100	FLAG=.FALSE.
0049    	INUM_FIELDS = ND - 1
0050    	INUM_LINES = NL - 1
0051    	CALL SCR_GETLOGSCR
0052    	RETURN
0053    C
0054    900	TYPE *,'ERROR REWINDING UNIT',IUNIT	
0055    	RETURN
0056    910	TYPE *,'SECTION',ISEC,' NOT FOUND'
0057    	RETURN
0058    920	TYPE *,'NO END OF SECTION FOUND FOR SECTION',ISEC
0059    	RETURN
0060    930	TYPE *,'NO END OF DATA DESCRIPTION FOUND FOR SECTION',ISEC
0061    	RETURN
0062    940	TYPE *,'ERROR READING DATA DESCRIPTION FOR SECTION',ISEC
0063    	RETURN
0064    	END

0001    	SUBROUTINE SCR_RESETSCR
0002    C	---- SETS VALUES TO ZERO AND CLEARS BOTH SCREEN ARRAYS
0003    	INCLUDE 'SCREEN.FOR'
0016    C
0017    	DO I=1,24
0018    		DO J=1,80
0019    		  CHRSCREEN(I)(J:J)=' '
0020    		  LOGSCREEN(I,J)=.FALSE.
0021    		END DO
0022    	END DO
0023    C
0024    	DO I=1,50
0025    		IXY(I,1)=0
0026    		IXY(I,2)=0
0027    		TYPE(I:I)=' '
0028    		IFRACT(I)=0
0029    		LENGTH(I)=0
0030    	END DO
0031    C
0032    	RETURN
0033    	END

0001    C**********************************************************************
0002    C
0003    C	MASTER ROUTINE TO MANIPULATE THE SCREEN
0004    C
0005    C**********************************************************************
0006    	SUBROUTINE SCR_SCRIN(ISEC, IUNIT, FLAG, LOGMODE, LOGKEY)
0007    C		---- ISEC = USER SECTION NUMBER
0008    C		---- IUNIT = OPEN UNIT # FOR SECTION FILE
0009    C		---- FLAG = RESPONCE TO CALLER IF ERROR HAS OCCURED
0010    C		---- LOGMODE = .TRUE. IF IN REPLACE MODE
0011    C		---- LOGKEY = .TRUE. IF IN KEYPAD MODE
0012    	INCLUDE 'SCREEN.FOR'
0025    	CHARACTER D_LINE*80,D_WORD*80, D_CHR*1, INSYMBOL*20,OUTSYMBOL*20
0026    	LOGICAL*1 GOLD,DIRECT, FLAG, LOGMODE, LOGKEY
0027    	INTEGER*4 DL_LEN, DW_LEN
0028    	BYTE ICHR
0029    	DATA ICHAN /-999/
0030    	PARAMETER MINCOL=1, MAXCOL=80, MINLIN=1, MAXLIN=24
0031     
0032    C	---- SEE IF WE ARE IN BATCH OR A COMMAND FILE MODE
0033    	CALL SCR_GETMODE(IMODE)
0034    	IF (IMODE.NE. 1) THEN
0035    		IF (ISEC .NE. ICURRENT_SECTION) THEN
0036    			CALL SCR_RDSECT(FLAG,ISEC,IUNIT)
0037    			IF (FLAG) RETURN
0038    			ICURRENT_SECTION = ISEC
0039    		ENDIF
0040    		CALL SCR_RDBATCH
0041    		RETURN
0042    	ENDIF
0043     
0044    C	---- IF FIRST TIME HERE, CHECK FOR VT100 AND INITIALIZE CHANNEL TO TT:
0045    	IF (ICHAN .EQ. -999) THEN
0046    		INSYMBOL = 'TERMINAL_TYPE'
0047    		CALL SCR_GETSYMBOL(INSYMBOL,OUTSYMBOL)
0048    		IF (OUTSYMBOL.NE.'VT100')THEN
0049    			TYPE *,'YOUR TERMINAL MUST BE A VT100 AND'
0050    			TYPE *,'YOU NEED TO DEFINE THE SYMBOL TERMINAL_TYPE'
0051    			TYPE *,'TO EQUAL "VT100"'
0052    			FLAG = .TRUE.
0053    			RETURN
0054    		ENDIF
0055    		CALL SCR_IOCHAN(ICHAN)
0056    	ENDIF
0057     
0058    C	---- IF USER SECTION NUMBER HAS CHANGED, GET NEW SECTION
0059    	IF (ISEC .LT. 0) THEN
0060    		ILIN = IXY(1,1)
0061    		ICOL = IXY(1,2)
0062    		CALL SCR_ENCVAL	!ENCODE USER VALUES
0063    		CALL SCR_WRTSECT	!WRITE FULL SCREEN
0064     
0065    	ELSE IF (ISEC .NE. ICURRENT_SECTION ) THEN
0066    		CALL SCR_RDSECT(FLAG, ISEC, IUNIT)
0067    		IF (FLAG) RETURN
0068    		ILIN = IXY(1,1)
0069    		ICOL = IXY(1,2)

0070    		CALL SCR_ENCVAL	!ENCODE USER VALUES
0071    		CALL SCR_WRTSECT	!WRITE FULL SCREEN
0072    		ICURRENT_SECTION = ISEC
0073     
0074    	ELSE
0075    C		---- SETUP USER VALUES ON SCREEN
0076    		CALL SCR_ENCVAL	!ENCODE USER VALUES
0077    		ILIN = IXY(1,1)
0078    		ICOL = IXY(1,2)
0079    		CALL SCR_WRTVALUE(IBOLD)	!WRITE USER VALUES TO SCREEN
0080    	ENDIF
0081     
0082    	CALL SCR_KEYPAD(LOGKEY)
0083     
0084    	DIRECT=.TRUE.
0085    1001	ILIN=IXY(1,1)
0086    	ICOL=IXY(1,2)
0087     
0088    C	---- MOVE THE CURSOR TO 1ST LOGICAL POSTION
0089    1	ISTAT=LIB$SET_CURSOR(ILIN,ICOL)
0090    		IF(.NOT.ISTAT)CALL LIB$STOP(%VAL(ISTAT))
0091    10	GOLD=.FALSE.		!SETUP GOLD KEY TO FALSE
0092    	CALL SCR_RDCHR(ICHAN,ICHR)	!READ CHARACTER FROM TT:
0093     
0094    C	---- IF CONTROL-B THEN REPAINT VALUES WITH REVERSE VIDIO
0095    	IF (ICHR.EQ.2) THEN
0096    		IF (IBOLD.EQ.0) THEN
0097    			IBOLD = 2
0098    		ELSE
0099    			IBOLD = 0
0100    		ENDIF
0101    		CALL SCR_WRTVALUE(IBOLD)
0102    		GOTO 10
0103     
0104     
0105    C	---- BOMB ON CONTROL-C OR CONTROL-Y
0106    	ELSE IF (ICHR.EQ.3 .OR. ICHR.EQ.25) THEN
0107    		ISTAT = LIB$SET_CURSOR(24,1)
0108    		TYPE *,'PROGRAM ABORTED ON CONTROL C OR Y'
0109    		CALL EXIT
0110     
0111    C	---- IF BACKSPACE, DEL, OR CAN, BACKSPACE AND DELETE CHAR
0112    	ELSE IF (ICHR.EQ.8 .OR.ICHR.EQ.127 .OR.ICHR.EQ.24) THEN
0113    		IF (LOGSCREEN(ILIN,ICOL-1)) ICOL = ICOL - 1
0114    		CALL SCR_DELC(D_CHR)
0115    		GOTO 10
0116     
0117    C	---- IF CONTROL-V THEN REPAINT THE VALUES
0118    	ELSE IF (ICHR.EQ.22) THEN
0119    		CALL SCR_WRTVALUE(IBOLD)
0120    		GOTO 10
0121     
0122    C	---- IF CONTROL-W THEN REPAINT THE SCREEN
0123    	ELSE IF (ICHR.EQ.23) THEN
0124    		CALL SCR_WRTSECT
0125    		GOTO 10
0126     

0127    C	---- IF CONTROL-Z THEN INPUT PHASE IS DONE, GET VALUES, BACK TO USER
0128    	ELSE IF(ICHR.EQ.26)THEN
0129    		ISTAT = LIB$SET_CURSOR(24,1)
0130    		CALL SCR_DECVAL
0131    		RETURN
0132     
0133    	ELSE IF(ICHR.EQ.13) THEN 	!<CR>, TREAT AS "0" KEY
0134    		GOTO 112 
0135     
0136    C	---- NORMAL NON-ESCAPE CHARACTER
0137    	ELSE IF(ICHR.NE.27)THEN
0138    		IF (ICHR.LT.32 .OR. ICHR.GT.126) GOTO 10	!SKIP CONTROLS
0139    		CALL SCR_PUTCHR(LOGMODE,ICHR)
0140    		GOTO 10
0141    	END IF
0142     
0143    C	---- ESCAPE RECEIVED, GET THE REST OF THE ESCAPE SEQUENCE
0144    	CALL SCR_RDCHR(ICHAN,ICHR)
0145    	IF(ICHR.EQ.91)GOTO 2000		!ARROW KEY "ESC ["
0146    	IF(ICHR.NE.79)GOTO 10		!UNKNOWN ESCAPE SEQUENCE ".NOT. ESC O"
0147     
0148    C	---- READ THIRD CHAR FOR KEYPAD SEQUENCE
0149    	CALL SCR_RDCHR(ICHAN,ICHR)
0150    	IF(ICHR.EQ.77) GOTO 112 	!ENTER KEY, TREAT AS "0" KEY "ESC O M"
0151     
0152    C	----	ESC O P THRU ESC O S IS PF KEYS
0153    	IF(ICHR.LT.80.OR.ICHR.GT.83)GOTO 1000	!KEYPAD DECODING
0154     
0155    C	---- PF KEYS
0156    	GOTO (100,200,300,400)ICHR-79
0157     
0158    C	--- PF1 KEY, SET GOLD ON
0159    100	GOLD=.TRUE.
0160    	IF(.NOT.LOGKEY)GOTO 10
0161     
0162    C	---- GOLD FUNCTION PROCESSING
0163    	CALL SCR_RDCHR(ICHAN,ICHR)
0164    		IF(ICHR.NE.27)GOTO 10
0165    	CALL SCR_RDCHR(ICHAN,ICHR)
0166    		IF(ICHR.NE.79)GOTO 10
0167    	CALL SCR_RDCHR(ICHAN,ICHR)
0168    C
0169    	IF (ICHR.EQ.80) GOTO 100	!GOLD GOLD, TREAT AS SINGLE GOLD
0170     
0171    	IF(ICHR.EQ.81)THEN	!GOLD PF2, TREAT AS STRAIGHT HELP
0172    		CALL SCR_KEYHELP(LOGMODE,LOGKEY)
0173    		GOTO 10
0174    	ENDIF
0175    C
0176    	IF(ICHR.EQ.82)THEN	!GOLD PF3, TREAT AS STRAIGHT TOGGLE KEYPAD
0177    		LOGKEY=.FALSE.
0178    		CALL SCR_KEYPAD(LOGKEY)
0179    		GOTO 10
0180    	ENDIF
0181    C
0182    	IF(ICHR.EQ.83)THEN	!GOLD PF4
0183    		CALL SCR_UNDL(D_LINE,DL_LEN)	!UNDELETE LINE

0184    		GOTO 10
0185    	ENDIF
0186    C
0187    C	---- PROCESS KEYPAD KEYS
0188    1000	IF (ICHR.EQ.77) GOTO 112	!GOLD ENTER IS JUST ENTER
0189    	IF (ICHR.LT.108 .OR. ICHR.GT.121) GOTO 10	!SKIP OTHER KEY SEQ.
0190    	GOTO(108,109,110,10,112,113,114,10,116,117,10,10,10,10)
0191         &		ICHR-107
0192    C
0193    C	---- "," KEY	ESC O l
0194    108	IF(GOLD)CALL SCR_UNDC(D_CHR)
0195    	IF(.NOT.GOLD)CALL SCR_DELC(D_CHR)
0196    	GOTO 10
0197    C
0198    C	---- "-" KEY	ESC O m
0199    109	IF(GOLD)CALL SCR_UNDL(D_WORD,DW_LEN)	!NOTE, WE USE UNDELETE LINE HERE
0200    	IF(.NOT.GOLD)CALL SCR_DELW(D_WORD,DW_LEN)
0201    	GOTO 10
0202    C
0203    C	---- "." KEY	ESC O n
0204    110	IF(LOGMODE)THEN
0205    		LOGMODE=.FALSE.
0206    		GOTO 10
0207    	ENDIF
0208    	LOGMODE=.TRUE.
0209    	GOTO 10
0210    C
0211    C	---- "0" KEY	ESC O p
0212    112	CALL SCR_NEXTFLD(DIRECT)
0213    	GOTO 10
0214    C
0215    C	---- "1" KEY	ESC O q
0216    113	CALL SCR_NEXTWD(DIRECT)
0217    	GOTO 10
0218    C
0219    C	---- "2" KEY	ESC O r
0220    114	IF(GOLD)CALL SCR_DELL(D_LINE,DL_LEN)
0221    	IF(.NOT.GOLD)CALL SCR_EOL(DIRECT)
0222    	GOTO 10
0223    C
0224    C	---- "4" KEY	ESC O t
0225    116	IF(GOLD)CALL SCR_BOTTOM
0226    	IF(.NOT.GOLD)DIRECT=.TRUE.
0227    	GOTO 10
0228    C
0229    C	---- "5" KEY	ESC O u
0230    117	IF(GOLD)GOTO 1001
0231    	IF(.NOT.GOLD)DIRECT=.FALSE.
0232    	GOTO 10
0233    C
0234    C	---- PF2 KEY
0235    200	CALL SCR_KEYHELP(LOGMODE,LOGKEY)
0236    	GOTO 10
0237    C
0238    C	---- PF3 KEY
0239    300	IF(LOGKEY)THEN
0240    		LOGKEY=.FALSE.

0241    		CALL SCR_KEYPAD(LOGKEY)
0242    		GOTO 10
0243    	ENDIF
0244    	LOGKEY=.TRUE.
0245    	CALL SCR_KEYPAD(LOGKEY)
0246    	GOTO 10
0247    C
0248    C	---- PF4 KEY
0249    400	IF(.NOT.LOGKEY)GOTO 10
0250    	CALL SCR_DELL(D_LINE,DL_LEN)
0251    	GOTO 10
0252    C
0253    C	---- ARROW KEY PROCESSING
0254    2000	CALL SCR_RDCHR(ICHAN,ICHR)
0255    	IF(ICHR.LT.65.OR.ICHR.GT.68)GOTO 10
0256    	GOTO(2111,2113,2115,2117)ICHR-64
0257     
0258    C	---- UP ARROW
0259    2111	NLIN=ILIN-1
0260    	IF(NLIN.LT.MINLIN)GOTO 1
0261    	IF(LOGSCREEN(NLIN,ICOL))THEN
0262    	  ILIN=NLIN
0263    	  GOTO 1
0264    	END IF
0265    2112	DO I=ICOL,1,-1
0266    	  IF(LOGSCREEN(NLIN,I))THEN
0267    		ILIN=NLIN
0268    		ICOL=I
0269    		GOTO 1
0270    	  END IF
0271    	END DO
0272    	DO I=ICOL,80,1
0273    	  IF(LOGSCREEN(NLIN,I))THEN
0274    		ILIN=NLIN
0275    		ICOL=I
0276    		GOTO 1
0277    	  END IF
0278    	END DO
0279    	IF(NLIN-1.LT.MINLIN)GOTO 1
0280    	NLIN=NLIN-1
0281    	GOTO 2112
0282     
0283    C	---- DOWN ARROR
0284    2113	NLIN=ILIN+1
0285    	IF(NLIN.GT.MAXLIN)GOTO 1
0286    	IF(LOGSCREEN(NLIN,ICOL))THEN
0287    	  ILIN=NLIN
0288    	  GOTO 1
0289    	END IF
0290    2114	DO I=ICOL,1,-1
0291    	  IF(LOGSCREEN(NLIN,I))THEN
0292    		ILIN=NLIN
0293    		ICOL=I
0294    		GOTO 1
0295    	  END IF
0296    	END DO
0297    	DO I=ICOL,80,1

0298    	  IF(LOGSCREEN(NLIN,I))THEN
0299    		ILIN=NLIN
0300    		ICOL=I
0301    		GOTO 1
0302    	  END IF
0303    	END DO
0304    	IF(NLIN+1.GT.MAXLIN)GOTO 1
0305    	NLIN=NLIN+1
0306    	GOTO 2114
0307     
0308    C	---- RIGHT ARROW
0309    2115	NCOL=ICOL+1
0310    	NLIN = ILIN
0311    	IF(NCOL.GT.MAXCOL)THEN
0312    		IF(ILIN+1.GT.MAXLIN)GOTO 1
0313    		NLIN=ILIN+1
0314    		NCOL=MINCOL
0315    	END IF
0316    2116	DO I=NCOL,80
0317    	  IF(LOGSCREEN(NLIN,I))THEN
0318    		ILIN=NLIN
0319    		ICOL=I
0320    		GOTO 1
0321    	  END IF
0322    	END DO
0323    	IF(NLIN+1.GT.MAXLIN)GOTO 1
0324    	NLIN=NLIN+1
0325    	NCOL=MINCOL
0326    	GOTO 2116
0327     
0328    C	---- LEFT ARROW
0329    2117	NCOL=ICOL-1
0330    	NLIN = ILIN
0331    	IF(NCOL.LT.MINCOL)THEN
0332    		IF(ILIN-1.LT.MINLIN)GOTO 1
0333    		NLIN=ILIN-1
0334    		NCOL=MAXCOL
0335    	END IF
0336    2118	DO I=NCOL,1,-1
0337    	  IF(LOGSCREEN(NLIN,I))THEN
0338    		ILIN=NLIN
0339    		ICOL=I
0340    		GOTO 1
0341    	  END IF
0342    	END DO
0343    	IF(NLIN-1.LT.MINLIN)GOTO 1
0344    	NLIN=NLIN-1
0345    	NCOL=MAXCOL
0346    	GOTO 2118
0347    	END

0001    	SUBROUTINE SCR_UNDC(D_CHR)
0002    C	---- UNDELETE CHARACTER
0003    	CHARACTER*1 D_CHR,DUMLIN*80
0004    	INCLUDE 'SCREEN.FOR'
0017    C
0018    	DO I=0,79
0019    		IF(ICOL+I.EQ.80)GOTO 10
0020    		IF(LOGSCREEN(ILIN,ICOL+I))THEN
0021    		  DUMLIN(I+1:I+1)=CHRSCREEN(ILIN)(ICOL+I:ICOL+I)
0022    		ELSE
0023    		  GOTO 10
0024    		ENDIF
0025    	ENDDO
0026    C
0027    10	CHRSCREEN(ILIN)(ICOL:ICOL)=D_CHR(1:1)
0028    	CHRSCREEN(ILIN)(ICOL+1:ICOL+I)=DUMLIN(1:I)
0029    	ISTAT=LIB$PUT_SCREEN(CHRSCREEN(ILIN)(ICOL:ICOL+I),ILIN,ICOL)
0030    		IF(.NOT.ISTAT)CALL LIB$STOP(%VAL(ISTAT))
0031    	ISTAT=LIB$SET_CURSOR(ILIN,ICOL)
0032    		IF(.NOT.ISTAT)CALL LIB$STOP(%VAL(ISTAT))
0033    	RETURN
0034    	END

0001    	SUBROUTINE SCR_UNDL(D_LINE,DL_LEN)
0002    C	---- UNDELETE LINE
0003    	CHARACTER*80 D_LINE
0004    	INTEGER DL_LEN
0005    	INCLUDE 'SCREEN.FOR'
0018    C
0019    	DO I=0,79
0020    		IF((ICOL+I).EQ.81)GOTO 10
0021    		IF(LOGSCREEN(ILIN,ICOL+I))THEN
0022    		  CHRSCREEN(ILIN)(ICOL+I:ICOL+I)=D_LINE(I+1:I+1)
0023    		ELSE
0024    		  GOTO 10
0025    		ENDIF
0026    	ENDDO
0027    C
0028    10	ISTAT=LIB$PUT_SCREEN(CHRSCREEN(ILIN)(ICOL:ICOL+I-1),ILIN,ICOL)
0029    		IF(.NOT.ISTAT)CALL LIB$STOP(%VAL(ISTAT))
0030    	ISTAT=LIB$SET_CURSOR(ILIN,ICOL)
0031    		IF(.NOT.ISTAT)CALL LIB$STOP(%VAL(ISTAT))
0032     
0033    	RETURN
0034    	END

0001    	SUBROUTINE SCR_WRTSECT
0002    C	----	PUT FULL SCREEN IMAGE ON SCREEN
0003    	INCLUDE 'SCREEN.FOR'
0016    C
0017    	ISTAT=LIB$ERASE_PAGE(1,1)
0018    		IF(.NOT.ISTAT)CALL LIB$STOP(%VAL(ISTAT))
0019    C
0020    	DO I=1,INUM_LINES
0021    	  ISTAT=LIB$PUT_SCREEN(CHRSCREEN(I)(1:80),I,1)
0022    		IF(.NOT.ISTAT)CALL LIB$STOP(%VAL(ISTAT))
0023    	END DO
0024    C
0025    	ISTAT=LIB$SET_CURSOR(ILIN,ICOL)
0026    		IF(.NOT.ISTAT)CALL LIB$STOP(%VAL(ISTAT))
0027     
0028    	RETURN
0029    	END

0001    	SUBROUTINE SCR_WRTVALUE(IBOLD)
0002    C	----	PUT VALUES ON SCREEN
0003    	INCLUDE 'SCREEN.FOR'
0016    C
0017     
0018    	DO I=1,INUM_FIELDS
0019    		IROW = IXY(I,1)
0020    		ISTART = IXY(I,2)
0021    		IEND = ISTART + LENGTH(I) - 1
0022    		ISTAT=LIB$PUT_SCREEN(CHRSCREEN(IROW)(ISTART:IEND),
0023         &			IROW,ISTART,IBOLD)
0024    		IF(.NOT.ISTAT)CALL LIB$STOP(%VAL(ISTAT))
0025    	END DO
0026    C
0027    	ISTAT=LIB$SET_CURSOR(ILIN,ICOL)
0028    		IF(.NOT.ISTAT)CALL LIB$STOP(%VAL(ISTAT))
0029     
0030    	RETURN
0031    	END