C	REWRITE MADE 9/86 BY JEFF STRICKLAND  MARTIN MARIETTA CORP.
C					      KENNEDY SPACE CENTER, FLA.
C	VAX/VMS Fortran 77 is required to compile this program.
C	
C	This program will read a VT125 or VT240/VT241's graphic screen
C	and dump the information back to the computer into a file name
C	specified by the user.  The file will be in a SIXEL format that
C	may then be spooled of to a graphic printer (LA50, LA100, LA12)
C	
C	Note :   After the startup of this program the keyboard is locked until
C             it is finished, due to the fact that any keyboard activity 
C             during the dump would corrupt the file.  It will take anywhere 
C             from 1 to 3 minutes depending on the load on your system.
C
C	
	IMPLICIT INTEGER *4 (A-Z)

	Include '($IODEF)'
	Include '($TTDEF)'

	Character*2 GOFF,GON,BUF
	Character*3 Device,move,prompt_erase
	Character*4 To_Computer,To_Printer,Hard_Copy
	Character*40 File_Name
	Character*5 portrait
	Character*4 enlarge
	Byte Done(2),SIXEL(50000),WCHAR
	Byte Carriage_Return,File_Byte(40),Delete
	Integer*4 Terminal_Mode(2)
	INTEGER*2 CHANNEL,IOSB(4)
	
	DATA Device /'TT:'/
	DATA Done   /27,92/
	DATA GON    /'Pp'/
	DATA GOFF   /'\'/
	DATA ESC    /27/
	DATA Delete /127/
	DATA To_Computer /'[?2i'/
	DATA To_Printer  /'[?0i'/
	DATA Hard_Copy   /'S(H)'/
	DATA up		/'[1A'/
	DATA move	/'[2C'/
	DATA prompt_erase /'[1K'/

	index=0
	Carriage_Return=13


C	Get the terminal's channel number for the QIO.
	Call Sys$Assign (Device,Channel,,)

C	Re-direct I/O from printer port to the communication port.

	Write(*,100) ESC,To_Computer
100	Format('+',A1,A4,$)
	
C	Enter ReGIS graphic mode on the terminal.
	Write(*,101) ESC,GON
101	Format('+',A1,A2,$)

C	Get the terminal's current mode of operation.
	status = Sys$QIOW (,%VAL(Channel),  %VAL(IO$_SENSEMODE),
	1                 %REF(IOSB),,,%REF(Terminal_Mode(1)),%VAL(8),,,,)
	If(.not. status) Call SYS$EXIT(%VAL(status))

C	Set the Host Sync flag in the terminal Characteristics word.
	Terminal_Mode(2) = IOR (Terminal_Mode(2),TT$M_HOSTSYNC)

C	Temporarily set the terminal to host sync mode to eliminate
C	any overrun which may occur because of the lack of XON-XOFF.
	status = Sys$QIOW (,%VAL(Channel),%VAL(IO$_SETMODE),%REF(IOSB),,,
	1             %REF(Terminal_Mode(1)),%VAL(8),,,,)
	If(.not.status) Call SYS$EXIT(%VAL(status))

C    MOVE UP AND OVER (1,1) AND ...

C	Write(*,103) ESC,up,ESC,move
C 103	format('+',A1,A3,A1,A3,$)

C    ...ERASE THE DOLLAR PROMPT.


C 	Write(*,7) ESC,PROMPT_ERASE
C 7	Format('+',A1,A3,$)

C	Enter ReGIS graphic mode on the terminal.

111	Write(*,8) ESC,GON
 8	Format('+',A1,A2,$)

C	Issue the SIXEL dump command to the terminal for hardcopy.

	Write(*,200) Hard_Copy
200	Format('+',A4,$)


C	Get the initial data sent, synchronize on the first <ESC> \

	Do While (.NOT. (SIXEL(1).EQ.Done(1) .and. SIXEL(2).EQ.Done(2)))
	status = Sys$QIOW (,%VAL(Channel),%VAL(IO$_READVBLK+IO$M_NOECHO),
	1	           IOSB,  ,  ,  %REF(WChar),  %VAL(1), , , , )
	       If(.not. status) Call SYS$EXIT(%VAL(status))
	    SIXEL(1)=SIXEL(2)
	    SIXEL(2)=WChar
	End Do

C	Now get some real data (SIXEL bit map data and terminate on <ESC> \

	Index=2

300	Status = Sys$QIOW (,%VAL(Channel),%VAL(IO$_READVBLK+IO$M_NOECHO),
	1                  IOSB,  ,  ,  %REF(WChar),  %VAL(1), , , , )
	       If(.not. status) Call SYS$EXIT(%VAL(status))
	  Index=Index+1
	  SIXEL(index)=WChar
	If (SIXEL(index-1).EQ.Done(1) .and. SIXEL(index).EQ.Done(2)) Goto 400
	Goto 300

C	Exit ReGIS graphics mode on the terminal.

400	Write(*,401) ESC,GOFF
401	Format('+',A1,A2,$)

C	Reset hardcopy to the printer port.

	Write(*,402) ESC,To_Printer
402	Format('+',A1,A4,$)

C	Check if file name is a null and if so exit the program.
	If(index.LE.1) Goto 900

	Open (Unit=1, Status='NEW', Access='Direct',
	1     Recordsize=20, FORM='Unformatted')

C	Write out the SIXEL data to the file.  Use random access file.

	   File_Rec=File_Rec+1
       enlarge = char(27)//char(80)//char(49)//char(113)
       Write(1'File_Rec) enlarge


	Do 600 J=8,index+3,80
	File_Rec=File_Rec+1
	IF(J .GE. INDEX+1) GOTO 900
600	Write(1'File_Rec) (SIXEL(I),I=J,J+79)


900	Call Exit
	END
