	PROGRAM MICOM_CONTROL
C Detached process between Micom 6000 Administrative port and talking programs
C such as MICOM and MICOM_LOCATE

C Why not do QIOW's w/ large buffer  and wait for prompt '>'?
C or multiple buffer and always have a QIO outstanding ?

c Must worry about the various 'editors' inside the micom
c  e.g. for SET MSG  and SET SHELF !!

	IMPLICIT INTEGER (A-Z)
	INCLUDE '($IODEF)/NOLIST'
	INCLUDE '($LNMDEF)/NOLIST'
	INCLUDE '($SSDEF)/NOLIST'
	PARAMETER ( PRMFLG = 1)
	EXTERNAL EXIT_HANDLER
	INTEGER*2 BUFLEN, ITEMCODE, MICOM_MBX_IOSB(4)
	INTEGER*4 BIN_OUT_DELAY(2),DESBLK(4),EXIT_STATUS
	CHARACTER MICOM_PORT*39, COMMAND*80, PID_MBX*14
	CHARACTER*12 USERNAME
	CHARACTER*16 IN_STRING
	BYTE ITMLST(0:15)
	INTEGER*4 OVERRUN

	COMMON/TIMER/ DELAY_EF, BIN_OUT_DELAY

	INTEGER*2 MICOM_IOSB(4)
	CHARACTER MICOM_BUF*80
	COMMON/MICOM_QIO/MICOM_CHAN, MICOM_IOSB,MICOM_BUF

	CHARACTER MICOM_MBX_BUF*80
	COMMON/MICOM_MBX_QIO/MICOM_MBX_CHAN,MICOM_MBX_IOSB,
	1 MICOM_MBX_BUF

	INTEGER*2 PID_MBX_IOSB(4)
	CHARACTER PID_MBX_BUF*80
	COMMON/PID_MBX_QIO/PID_MBX_CHAN,PID_MBX_IOSB,PID_MBX_BUF

C equivalence for QIO status block
	EQUIVALENCE (PID, MICOM_MBX_IOSB(3))
C equivalence for translate logical name system service
	EQUIVALENCE (BUFLEN, ITMLST(0)), (ITEMCODE, ITMLST(2)),
	1 (TRANSBUF_ADR, ITMLST(4)), (RETLEN_ADR, ITMLST(8)),
	2 (LISTEND,ITMLST(12))

C set up for declaring exit handler
	DESBLK(2) = %LOC(EXIT_HANDLER)
	DESBLK(3) = 1
	DESBLK(4) = %LOC(EXIT_STATUS)

C Declare the exit handler to delete permanent mailbox
	ISTAT = SYS$DCLEXH(%REF(DESBLK))
	IF (ISTAT .NE. SS$_NORMAL) CALL LIB$STOP(%VAL(ISTAT))

C set up for logical name translation
	BUFLEN= 39
	ITEMCODE=LNM$_STRING
	TRANSBUF_ADR= %LOC(MICOM_PORT)
	RETLEN_ADR= %LOC(RETLEN)
	LISTEND = 0

C Get the logical name for the Micom Command Console port
	ISTAT = SYS$TRNLNM(,'LNM$SYSTEM_TABLE','MICOM_PORT',,ITMLST)
	IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)

C Create and assign the MICOM detached process Mailbox 
C (for input from other processes)
	ISTAT = SYS$CREMBX(%VAL(PRMFLG),MICOM_MBX_CHAN,,,
	1 %VAL('5F0F'X),,'MICOM_MBX')
	IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)

C Assign a channel to the command port
	ISTAT = SYS$ASSIGN(MICOM_PORT,MICOM_CHAN,,)
	IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)

c ONLY IF CONNECTED TO ADMINISTRATIVE PORT VIA AN ORDINARY MICOM PORT
cC Connect to MICOM by sending space and waiting for response
c	COMMAND = ' '
c	LEN = 1
c	CALL SEND_MICOM(COMMAND,LEN)  ! no requesting PID, response discarded

C Main loop for reads from input mailbox
D	TYPE *,' Main loop for reads from input mailbox'

10	IF (PID_MBX_CHAN .NE. 0 )THEN	
C If there's a channel assigned to the previous PID mbx then deassign so
C	the mailbox can be deleted by the mailbox creator.
	   ISTAT = SYS$DASSGN(%VAL(PID_MBX_CHAN))
	   IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)
	ENDIF

C	Wait for a command
	ISTAT = SYS$QIOW(,%VAL(MICOM_MBX_CHAN),
	1 %VAL(IO$_READVBLK),MICOM_MBX_IOSB,,,
	2 %REF(MICOM_MBX_BUF),%VAL(80),,,,)
	IF( ISTAT.NE.SS$_NORMAL ) CALL EXIT(ISTAT)

C Who sent it? Get the PID from status block
	WRITE(PID_MBX,'(6HMICOM_,Z8.8)')PID

C Assign a channel to the pid mailbox for return messages
	ISTAT = SYS$ASSIGN(PID_MBX,PID_MBX_CHAN,,)
	IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)

C Copy the command from the buffer
	LEN = MICOM_MBX_IOSB(2)
	COMMAND = MICOM_MBX_BUF

D	WRITE(6,4001)COMMAND
D4001	FORMAT(' RECEIVED MESSAGE FROM PID_MBX -- ',A<LEN>)

C SECURITY FEATURE!  Determine the command and who sent it.  
C	If the command is SHOW CH THEN 
C	   it's OK for everyone
C	ELSE 
C	   is the username for this PID SYSTEM?
C	   IF yes send the command to MICOM
C	   ELSE tell the user it's illegal command

	IF(COMMAND(1:8) .EQ. 'SHOW CH ') THEN 
	   CALL SEND_MICOM(COMMAND,LEN)
	ELSE
	   IF(USERNAME(PID).EQ.'SYSTEM')THEN
		CALL SEND_MICOM(COMMAND,LEN)
	   ELSE

C Send illegal command message
		PID_MBX_BUF = COMMAND
		RLEN = LEN
		ISTAT = SYS$QIO(,%VAL(PID_MBX_CHAN),
	1 %VAL(IO$_WRITEVBLK.OR.IO$M_NOW),PID_MBX_IOSB,,,
	2 %REF(PID_MBX_BUF),%VAL(RLEN),,,,)
		IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)
		PID_MBX_BUF = 'NO PRIVILEGE FOR COMMAND'
		RLEN = 24
D		TYPE *,' NO PRIVILEGE COMMAND SENT TO PID_MBX'
		ISTAT = SYS$QIO(,%VAL(PID_MBX_CHAN),
	1 %VAL(IO$_WRITEVBLK.OR.IO$M_NOW),PID_MBX_IOSB,,,
	2 %REF(PID_MBX_BUF),%VAL(RLEN),,,,)
		IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)

D		TYPE *,' SENT EOF TO PID_MBX'
		ISTAT = SYS$QIO(,%VAL(PID_MBX_CHAN),
	1 %VAL(IO$_WRITEOF .OR. IO$M_NOW),PID_MBX_IOSB,,,,,,,,)
		IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)
	   ENDIF

	ENDIF
	GOTO 10
	END

	SUBROUTINE SEND_MICOM(STRING,LEN)
	IMPLICIT INTEGER (A-Z)
	INCLUDE '($IODEF)/NOLIST'
	INCLUDE '($SSDEF)/NOLIST'
	PARAMETER MAXLINES=500
	PARAMETER (CR = '0D'X)

	INTEGER*4 BIN_OUT_DELAY(2)
	INTEGER*4 CR_TERM(2)/0,'0000 2000'X/
	CHARACTER STRING*80,CHAR_OUT*1
	COMMON/TIMER/DELAY_EF, BIN_OUT_DELAY

	INTEGER*2 MICOM_IOSB(4)
	CHARACTER*80 MICOM_BUF(MAXLINES)
	INTEGER MICOM_BUF_LEN(MAXLINES)
	COMMON /MICOM_QIO/ MICOM_CHAN,MICOM_IOSB,MICOM_BUF,MICOM_BUF_LEN

	INTEGER*2 PID_MBX_IOSB(4)
	CHARACTER PID_MBX_BUF*80
	COMMON/PID_MBX_QIO/PID_MBX_CHAN,PID_MBX_IOSB,PID_MBX_BUF

	CHARACTER*2 LFCR

	LFCR = CHAR(10)//CHAR(13)

D	WRITE(6,2001)LEN,STRING
D2001	FORMAT(' SENDING ',I2,' CHARACTERS to MICOM -- ',A<LEN>)
C Append a carriage return
	LEN = LEN + 1
	STRING(LEN:LEN) = CHAR(CR)

C Output loop for console commands.

C Initial read QIO from Micom switch channel (with purge of typeahead)
C    should do before sending to be sure not to miss response  ??? but get echo ?
D	TYPE *,'INITIAL READ FROM MICOM'
	ISTAT = SYS$QIO(,%VAL(MICOM_CHAN),
     1 %VAL(IO$_READVBLK.OR.IO$M_NOECHO.OR.IO$M_TIMED.OR.IO$M_PURGE),
	1 MICOM_IOSBI,,,%REF(MICOM_BUF(1)),
	2 %VAL(80),%VAL(2),CR_TERM,,)
	IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)

	ISTAT = SYS$QIO(,%VAL(MICOM_CHAN),
	1	%VAL(IO$_WRITEVBLK .OR. IO$M_NOFORMAT),,,,
	2	%REF(STRING),%VAL(LEN),,,,)
	IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)

	MICOM_IOSB(1) = SS$_NORMAL	! ??? not necessary ???
50	CONTINUE
	OVERRUN=0
	DO J=1,MAXLINES
	   ISTAT = SYS$QIOW(,%VAL(MICOM_CHAN),
	1    %VAL(IO$_READVBLK.OR.IO$M_NOECHO.OR.IO$M_TIMED),
	1    MICOM_IOSB,,,%REF(MICOM_BUF(J)),
	2    %VAL(80), %VAL(2), CR_TERM,,) ! 2-SEC timeout
	   IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)
	   MICOM_BUF_LEN(J)=MICOM_IOSB(2)
	   IF(MICOM_IOSB(1).EQ.SS$_TIMEOUT) GOTO 100
	   IF(MICOM_IOSB(1).EQ.SS$_DATAOVERUN) THEN ! Data overrun, ignore
	       OVERRUN=J
	   ELSE
	   	IF(MICOM_IOSB(1).NE.SS$_NORMAL) CALL EXIT(MICOM_IOSB(1))
	   ENDIF
	ENDDO
	TYPE *,' Too many lines of response from Micom Switch.'
	GOTO 50

C Timeout => ready to output to mailbox
100	CONTINUE
D	TYPE *,' TIMEOUT  '
	EOM_RCVD = .TRUE.
	IF(OVERRUN.NE.0) then
		TYPE *,' Data overrun in Micom Switch reply:'
		TYPE *,MICOM_BUF(OVERRUN)
	ENDIF
	NUMLINES = J	! includes the timedout line
D	TYPE *,' NUMLINES=',NUMLINES

c ??? should expand this for other prompts such as '*' and Time-of-Day
	IF(  INDEX( MICOM_BUF(NUMLINES)(1:MICOM_IOSB(2)), 'A>' ) .NE. 0  ) THEN
	   EOM_RCVD = .TRUE.
	ELSE
	   type *,' Failed to find MICOM prompt at end of its output'
	ENDIF

CCCC  ******  non-indented DO loop
	DO J = 1, NUMLINES
	RLEN = MICOM_BUF_LEN(J)

c strip LFCR if possible (note RLEN is offset of terminator.  is not length
        IF(  MICOM_BUF(J)( RLEN : RLEN+1 ) .EQ. LFCR   ) THEN
	   RLEN = RLEN - 1
D	   TYPE *,' stripping LFCR'
	ENDIF

	IF(RLEN.EQ.0) THEN
c  possibly null eaten since not passall ?
D	    TYPE *,' ZERO LENGTH RECORD RCVD (i.e. timout after NO char ?)'
C	    MICOM_BUF(J) = 'Zero length response from MICOM'
C	    RLEN = 31
	ENDIF

c don't output blank lines ? due to FORTRAN problems with zero length output ?
C	IF((RLEN.EQ.1).AND.(MICOM_BUF(J)(1:1).EQ.CHAR(LF)))THEN
D	    TYPE *,' LINE FEED RECORD RCVD (blank line)'
C	    GOTO 200
C	ENDIF


10	CONTINUE	   

D	TYPE *,' PID_MBX_CHAN,RLEN = ',PID_MBX_CHAN,RLEN
D	TYPE *,' line from micom=',MICOM_BUF(J)(1:RLEN),'=endofline'

C Send response to requestor's mailbox
	IF(PID_MBX_CHAN.NE.0) THEN
	   IF(RLEN.NE.0) PID_MBX_BUF(1:RLEN) = MICOM_BUF(J)(1:RLEN)
	
D	   TYPE *,' MESSAGE SENT TO PID_MBX'
	   ISTAT = SYS$QIO(,%VAL(PID_MBX_CHAN),
	1 %VAL(IO$_WRITEVBLK.OR.IO$M_NOW),PID_MBX_IOSB,,,
	2 %REF(MICOM_BUF(J)(1:RLEN)),%VAL(RLEN),,,,)
	   IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)
C  ???? never checks IOSB from mailbox write !


	ENDIF	! there was a requestor

200	CONTINUE	! comes here to NOT output line

	ENDDO	! *********   end of non-indented DO loop 

	IF(EOM_RCVD)THEN
D	   TYPE *,' End Of Message DETECTED'
	   IF(PID_MBX_CHAN .NE. 0) THEN
D		TYPE *,' END OF MESSAGE SENT TO PID_MBX'

		ISTAT = SYS$QIO(,%VAL(PID_MBX_CHAN),
	1 %VAL(IO$_WRITEOF .OR. IO$M_NOW),PID_MBX_IOSB,,,,,,,,)
		IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)

	 	ENDIF

	ENDIF

	RETURN
	END

	CHARACTER*12 FUNCTION USERNAME(PID)
C determine username
	IMPLICIT INTEGER (A-Z)
	INTEGER*2 IOSB(4), ITMLST(8)
	CHARACTER*12 NAMEBUF
	EQUIVALENCE (ITMLST(3), BUFADR), (ITMLST(5), RLADR),
	1 (ITMLST(7), LSTEND)
	INCLUDE '($JPIDEF)/NOLIST'
	ITMLST(1)= 12
	ITMLST(2)= JPI$_USERNAME
	BUFADR= %LOC(NAMEBUF)
	RLADR= 0
	LSTEND= 0
	STATUS= SYS$GETJPIW(,%REF(PID),, ITMLST, IOSB,,)
	IF (.NOT. STATUS) CALL EXIT(STATUS)
	USERNAME = NAMEBUF
	RETURN
	END

	SUBROUTINE EXIT_HANDLER(ISTAT)
	IMPLICIT INTEGER (A-Z)
	INCLUDE '($SSDEF)/NOLIST'
	INTEGER*2 MICOM_MBX_IOSB(4)
	INTEGER*4 BIN_OUT_DELAY(2)
	CHARACTER MICOM_MBX_BUF*80
	
	COMMON/TIMER/DELAY_EF,BIN_OUT_DELAY
	COMMON/MICOM_MBX_QIO/MICOM_MBX_CHAN,MICOM_MBX_IOSB,
	1 MICOM_MBX_BUF
	COMMON/PID_MBX_QIO/PID_MBX_CHAN,PID_MBX_IOSB,PID_MBX_BUF

	print *,' in exit handler'
C Delete the permanent mailbox 
	IF (MICOM_MBX_CHAN .NE. 0) THEN !a mailbox exists so delete it
	    STATUS = SYS$DELMBX(%VAL(MICOM_MBX_CHAN))
	    IF(STATUS.NE.SS$_NORMAL) then
		print *,' can''t delete mailbox on MICOM_MBX_CHAN'
	        CALL LIB$STOP(%VAL(STATUS))
	    ENDIF
	ENDIF

C Deassign channel to PID mailbox
C should be more complicated, so sends EOF ??? to keep MICOM program from hang ?
	IF (PID_MBX_CHAN .NE. 0) THEN !a mailbox exists so deassign it
	    STATUS = SYS$DASSGN(%VAL(PID_MBX_CHAN))
	    IF(STATUS.NE.SS$_NORMAL) THEN
		print *,' can''t deassign PID_MBX_CHAN'
		CALL LIB$STOP(%VAL(STATUS))
	     ENDIF
	ENDIF
	
C Call the condition handler for istat
	CALL EXIT(ISTAT)
	END
