      IMPLICIT INTEGER (A-Z)
      INCLUDE '($IODEF)/NOLIST'
      INCLUDE '($LNMDEF)/NOLIST'
      INCLUDE '($SSDEF)/NOLIST'
      PARAMETER ( PRMFLG = 1)
      EXTERNAL EXIT_HANDLER
      INTEGER*2 BUFLEN, ITEMCODE, MICOM_IOSB(4), MICOM_MBX_IOSB(4),
     1 PID_MBX_IOSB(4)
      INTEGER*4 BIN_OUT_DELAY(2),DESBLK(4),EXIT_STATUS
      CHARACTER MICOM_PORT*39,COMMAND*80,MICOM_BUF*80,
     1 MICOM_MBX_BUF*80,PID_MBX_BUF*80,PID_MBX*14
      CHARACTER ASC_OUT_DELAY*16/'0000 00:00:00.01'/
C     CHARACTER ASC_OUT_DELAY*16/'0000 00:00:00.25'/
      CHARACTER*12 USERNAME
      CHARACTER*16 IN_STRING
      BYTE ITMLST(0:15)
     
      COMMON/TIMER/ DELAY_EF, BIN_OUT_DELAY
      COMMON/MICOM_QIO/MICOM_CHAN, MICOM_IOSB,MICOM_BUF
      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
C
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
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 Get an event flag for the MICOM output delay timer and Micom channel
      ISTAT = LIB$GET_EF(DELAY_EF)
      IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)
     
C Convert the output delay time in ascii to binary
D     WRITE(5,1001)ASC_OUT_DELAY
D1001 FORMAT(' Delay time between sending characters [',A,']: ',$)
D     READ(5,'(Q,A)')LEN,IN_STRING
D     IF (LEN.NE.0) ASC_OUT_DELAY=IN_STRING
D     WRITE(5,'(A)')ASC_OUT_DELAY
      ISTAT = SYS$BINTIM(ASC_OUT_DELAY,BIN_OUT_DELAY)
      IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)
     
     
C Connect to MICOM by sending space and waiting for response
      COMMAND = ' '
      LEN = 1
      CALL SEND_MICOM(COMMAND,LEN)
     
C 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
         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(5,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 STA P 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:5) .EQ. 'STA P') THEN
         CALL SEND_MICOM(COMMAND,LEN)
      ELSE IF(COMMAND(1:5) .EQ. 'ENA P') 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 (CR = '0D'X)
     
      INTEGER*2 MICOM_IOSB(4)
      INTEGER*4 BIN_OUT_DELAY(2)
      INTEGER*4 CR_TERM(2)/0,'0000 2000'X/
      CHARACTER STRING*80,MICOM_BUF*80,CHAR_OUT*1
      COMMON/TIMER/DELAY_EF, BIN_OUT_DELAY
      COMMON/MICOM_QIO/MICOM_CHAN,MICOM_IOSB,MICOM_BUF
      EXTERNAL READ_AST
     
D     WRITE(5,2001)LEN,STRING
D2001 FORMAT(' SENDING ',I2,' CHARACTERS -- ',A<LEN>)
C Append a carriage return
      LEN = LEN + 1
      STRING(LEN:LEN) = CHAR(CR)
     
C Output loop for console commands.  Wait for delay event timer then QIO
      RETRY = 3
10    CONTINUE
     
      DO I=1,LEN
         ISTAT = SYS$SETIMR(%VAL(DELAY_EF),BIN_OUT_DELAY,,)
         IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)
         ISTAT = SYS$WAITFR(%VAL(DELAY_EF))
         IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)
     
C Primary single character output QIO to MICOM switch channel
         CHAR_OUT = STRING(I:I)
         ISTAT = SYS$QIO(,%VAL(MICOM_CHAN),
     1  %VAL(IO$_WRITEVBLK .OR. IO$M_NOFORMAT),,,,
     2  %REF(CHAR_OUT),%VAL(1),,,,)
         IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)
      ENDDO
C Initial read QIO from Micom switch channel (with purge of typeahead)
      ISTAT = SYS$QIO(,%VAL(MICOM_CHAN),
     1 %VAL(IO$_READVBLK.OR.IO$M_NOECHO.OR.IO$M_TIMED.OR.IO$M_PURGE),
     1 MICOM_IOSB,READ_AST,,%REF(MICOM_BUF),
     2 %VAL(80),%VAL(2),CR_TERM,,)
      IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)
     
C Hibernate and wait for the AST to wake after message completion
      ISTAT = SYS$HIBER()
      IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)
     
C Now we're awake again, check for success and retry
      IF (MICOM_IOSB(1) .NE. SS$_NORMAL) THEN   !Something wrong w/ message recv
d
         RETRY = RETRY - 1
         IF (RETRY .NE. 0) GOTO 10      !Send the command again
     
C We've exhausted our retries.  Things are seriously wrong.  Still connected?
c        ISTAT = SYS$PUTMSG()
c        IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)
         CALL EXIT
      ENDIF
      RETURN
      END
     
      SUBROUTINE READ_MICOM
      IMPLICIT INTEGER (A-Z)
      INCLUDE '($IODEF)/NOLIST'
      INCLUDE '($SSDEF)/NOLIST'
      INTEGER*2 MICOM_IOSB(4)
      INTEGER*4 CR_TERM(2)/0,'0000 2000'X/
      CHARACTER MICOM_BUF*80
      COMMON /MICOM_QIO/MICOM_CHAN,MICOM_IOSB,MICOM_BUF
      EXTERNAL READ_AST
     
      ISTAT = SYS$QIO(,%VAL(MICOM_CHAN),
     1 %VAL(IO$_READVBLK.OR.IO$M_NOECHO.OR.IO$M_TIMED),
     1 MICOM_IOSB,READ_AST,,%REF(MICOM_BUF),
     2 %VAL(80),%VAL(2),CR_TERM,,)
      IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)
      RETURN
      END
     
      SUBROUTINE READ_AST
      IMPLICIT INTEGER (A-Z)
      INCLUDE '($IODEF)/NOLIST'
      INCLUDE '($SSDEF)/NOLIST'
      PARAMETER ( END_OF_MESSAGE = '00'X )      !ASCII NULL
      PARAMETER ( LF = '0A'X )          !ASCII LINEFEED
      LOGICAL NULL_RCVD
      INTEGER*2 MICOM_IOSB(4),PID_MBX_IOSB(4)
      CHARACTER MICOM_BUF*80,PID_MBX_BUF*80
      COMMON /MICOM_QIO/MICOM_CHAN,MICOM_IOSB,MICOM_BUF
      COMMON/PID_MBX_QIO/PID_MBX_CHAN, PID_MBX_IOSB, PID_MBX_BUF
     
     
C     IF (MICOM_IOSB(1) .EQ. SS$_PARITY) THEN
C       TYPE *,' PARITY ERROR'
C       IF(MICOM_IOSB(2).NE.0) TYPE *,MICOM_BUF
C       CALL READ_MICOM
C       RETURN
C     ENDIF
C     IF (MICOM_IOSB(1) .EQ. SS$_TIMEOUT) THEN
C       TYPE *,' TIMEOUT  '
C     ENDIF
c     IF ((MICOM_IOSB(1) .NE. SS$_NORMAL) .AND.
c    1 (MICOM_IOSB(1) .NE. SS$_TIMEOUT))
c    1 CALL EXIT(MICOM_IOSB(1))
      IF (MICOM_IOSB(1) .NE. SS$_NORMAL)
     1 CALL EXIT(MICOM_IOSB(1))
     
      IF(MICOM_IOSB(2).EQ.0) THEN
D         TYPE *,' ZERO LENGTH RECORD RCVD'
          CALL READ_MICOM
          RETURN
      ENDIF
     
      IF((MICOM_IOSB(2).EQ.1).AND.(MICOM_BUF(1:1).EQ.CHAR(LF)))THEN
D         TYPE *,' LINE FEED RECORD RCVD'
          CALL READ_MICOM
          RETURN
      ENDIF
     
      NULL_RCVD = .FALSE.
      DO I=1,MICOM_IOSB(2)
      IF(MICOM_BUF(I:I).EQ.CHAR(END_OF_MESSAGE))THEN
         NULL_RCVD = .TRUE.
         RLEN = I - 1
         GOTO 10        !break do loop
      ELSE IF (MICOM_BUF(I:I).EQ.CHAR(LF)) THEN
         RLEN = I - 1
         GOTO 10        !break do loop
      ELSE
         CONTINUE
      ENDIF
      ENDDO
     
10    CONTINUE
D     TYPE *,' RLEN = ',RLEN
     
      IF((PID_MBX_CHAN.NE.0).AND.(RLEN.NE.0)) THEN
     
C Send response to requestor's mailbox
         DO I=1,RLEN
        PID_MBX_BUF(I:I) = MICOM_BUF(I:I)
         ENDDO
     
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(PID_MBX_BUF),%VAL(RLEN),,,,)
         IF (ISTAT .NE. SS$_NORMAL) CALL EXIT(ISTAT)
     
         ENDIF !(PID_MBX_CHAN
     
      IF(NULL_RCVD)THEN
D        TYPE *,' NULL 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
     
         MICOM_IOSB(1) = 1              !SS$_NORMAL
         ISTAT = SYS$WAKE(,)
         RETURN
         ENDIF
     
C Issue another read QIO from the switch
D     TYPE *,MICOM_BUF(1:RLEN)
      CALL READ_MICOM
      RETURN
      END
     
C
C
C FUNCTION SUBROUTINE TO DETERMINE PROCESS USERNAME
      CHARACTER*12 FUNCTION USERNAME(PID)
      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
     
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) CALL LIB$STOP(%VAL(STATUS))
      ENDIF
     
C Deassign channel to PID mailbox
      IF (PID_MBX_CHAN .NE. 0) THEN !a mailbox exists so delete it
          STATUS = SYS$DASSGN(%VAL(PID_MBX_CHAN))
          IF(STATUS.NE.SS$_NORMAL) CALL LIB$STOP(%VAL(STATUS))
      ENDIF
     
C Call the condition handler for istat
      CALL EXIT(ISTAT)
      END
