	PROGRAM MICOM
C Talk to detached MICOM_CONTROL process
C
C Originally by PEABODY @ UWACHEM.BITNET
C    of University of Washington Chemistry Dept
C Modifications by BELONIS @ UWAPHAST.BITNET
C    of University of Washington Physics Dept
C 860521 JJB use uppercase only for test EXIT and HELP, pass original COMMAND
C    to MICOM_CONTROL.  Change unit number to 6 (standard FORTRAN output)
C    and LIST carriage-control.
C    Prompt with prompt received from MICOM

C Should recognize special character indicating prompt ?  or include EOF with prompt ?

C
	IMPLICIT INTEGER (A-Z)
	INCLUDE '($IODEF)/NOLIST'
	INCLUDE '($SSDEF)/NOLIST'
	INCLUDE '($RMSDEF)/NOLIST'
	PARAMETER ( PRMFLG = 1 )
	INTEGER*2 PID_MBX_IOSB(4)
	INTEGER*4 EXIT_STATUS,DESBLK(4)
	CHARACTER PID_MBX*14, PID_MBX_BUF*80, COMMAND*80, COMMANDUP*80
	COMMON/PID_MBX/PID_MBX_CHAN,PID_MBX_IOSB,PID_MBX_BUF
	COMMON/CTRL_MASK/OLDMASK
	EXTERNAL EXIT_HANDLER
C
C Setup descriptor block for declaring exit handler
	DESBLK(2) = %LOC(EXIT_HANDLER)
	DESBLK(3) = 1
	DESBLK(4) = %LOC(EXIT_STATUS)

C Declare an exit handler
	ISTAT = SYS$DCLEXH(%REF(DESBLK))
	IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)

C Create the return mailbox name from the PID
	WRITE(PID_MBX,'(6HMICOM_,Z8.8)') PID()

C Create the return mailbox
	ISTAT = SYS$CREMBX(%VAL(PRMFLG),PID_MBX_CHAN,,,,,PID_MBX)
	IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)

C Assign a channel to the detached process mailbox
	ISTAT = SYS$ASSIGN('MICOM_MBX',MICOM_MBX_CHAN,,)
	IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)

	OPEN(UNIT=6,FILE='SYS$OUTPUT',CARRIAGECONTROL='LIST',TYPE='NEW')

C Set the old control mask
	CALL LIB$DISABLE_CTRL('02000000'X,OLDMASK)

C Set initial prompt  (which will be changed to last line returned from MICOM)
	PID_MBX_BUF ='MICOM> '	! default prompt
	PRLEN = 7

C Get the input from terminal or command file with ctrl Y enabled
10	CONTINUE
	CALL LIB$ENABLE_CTRL(OLDMASK)

	ISTAT = LIB$GET_INPUT(COMMAND,PID_MBX_BUF(1:PRLEN),LEN)
c  ??? the following does not detect '$' line in command file ???
	IF(ISTAT .EQ. RMS$_EOF) CALL EXIT(SS$_NORMAL)
	IF(ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)
	
C COMMAND DECODER
	COMMENTLOC = INDEX(COMMAND(1:LEN),'!')	! ignore comments
	IF( COMMENTLOC.GT.0 ) LEN = COMMENTLOC - 1
C Check for exit or help
	CALL STR$UPCASE(COMMANDUP,COMMAND)
	IF(COMMANDUP.EQ.'EXIT') CALL EXIT(SS$_NORMAL)
	IF(COMMANDUP.EQ.'HELP') THEN
	   CALL LIB$SPAWN('HELP SWITCH MICOM MICOM_program')
	   GOTO 10
	ENDIF

C Disable Control-Y's
	CALL LIB$DISABLE_CTRL('02000000'X,OLDMASK)

C Send MICOM command to detached process mailbox
C ??? no reason to wait ?
	ISTAT = SYS$QIOW(,%VAL(MICOM_MBX_CHAN),%VAL(IO$_WRITEVBLK),
	1 MICOM_MBX_IOSB,,,%REF(COMMAND),%VAL(LEN),,,,)
	IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)

C Read MICOM reply from PID mailbox
C  ??? no timeout ?

	DO WHILE (.TRUE.)
	   ISTAT = SYS$QIOW(,%VAL(PID_MBX_CHAN),
	1     %VAL(IO$_READVBLK.OR.IO$M_TIMED),
	1     PID_MBX_IOSB,,,%REF(PID_MBX_BUF),%VAL(80),%VAL(10),,,)
	   IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)

C Look for end of file (end of message)
	   IF( PID_MBX_IOSB(1) .EQ. SS$_ENDOFFILE ) GOTO 10	! prompt
D	   WRITE(6,'(19H PID_MBX_IOSB(2) = ,I2)')PID_MBX_IOSB(2)
	   PRLEN = PID_MBX_IOSB(2)	! remember in case prompt length
C Write to user's terminal
	   IF( PID_MBX_IOSB(2) .GT. 0 ) THEN
 	      WRITE(6,'(A)')PID_MBX_BUF(1:PID_MBX_IOSB(2))
	   ELSE
	      WRITE(6,'(A)')	! blank line
	   ENDIF
	ENDDO

C Close output file
999 	CLOSE(6)
	CALL EXIT

	END
	
C

	SUBROUTINE EXIT_HANDLER(ISTAT)
	IMPLICIT INTEGER (A-Z)
	INCLUDE '($SSDEF)/NOLIST'
	INTEGER*2 PID_MBX_IOSB(4)
	CHARACTER PID_MBX_BUF*80
	
	COMMON/PID_MBX/PID_MBX_CHAN,PID_MBX_IOSB,PID_MBX_BUF
	COMMON/CTRL_MASK/OLDMASK

C Delete the permanent mailbox 
	IF (PID_MBX_CHAN .NE. 0) THEN !a mailbox exists so delete it
	    STATUS = SYS$DELMBX(%VAL(PID_MBX_CHAN))
	    IF(STATUS.NE.SS$_NORMAL) CALL LIB$STOP(%VAL(STATUS))
	ENDIF
C Reset CTRL-Y
	CALL LIB$ENABLE_CTRL(OLDMASK)
	
C Call the condition handler for istat
	CALL EXIT(ISTAT)
	END
