	PROGRAM QMT
C.begin.doc ************************** begin.doc
C  
C .c ;Module name: 
C .c ;^&QMT\&
C .nf
C .x QMT>Defined
C Source:QMT.FTN
C Designer           :EARL LAKIA
C Author             :EARL LAKIA
C Date of last update:13-FEB-87
C Revision level     :1.3
C 	
C .C ;Formal Parameter List
C Receives:
C     
C Returns:
C 	
C Accesses common(s):
C .X PARSE
C    PARSE                      COMMON BLOCK THAT WILL CONTAIN THE 
C                               ENTERED SWITCHES.
C 	
C Accesses file(s):
C 	
C Other modules referenced:
C 	
C .X QMTPRS>Referenced
C         QMTPRS                PARSES THE QMT COMMAND LINE
C .X NSET>Referenced
C  
c         NSET                  RETURNS NUMBER OF BITS SET IN A WORD
C 
C .SK
C .fill
C .SK
C Description:
C .sk    
C 	This program is responsible for maintaining the QUEUE files
C for the QUEACP task on an RSX11M plus node.  The
C user has the following options:
C .LIST 1,' '
C .LE;List message ids in the queue and the 
C parameters associated with the current queue file.
C Note: This only lists those ids that will be placed into
C the queue on the next queue creation and possibly not
C those that are currently in service.
C .SK
C 	MCR> QMT/LI
C .LE;Create a new queue file with the message ids
C from the message id file and with a size of nnnn message
C blocks.
C .SK
C 	MCR> QMT/CR:nnnn
C .LE;Reset all pointers and clean up the current queue
C file (will basically deallocate all message blocks
C and reset all message id list heads).  Note: Dismount the ACP
C from the device ZQ0: before performing the reset.
C .SK
C 	MCR>QMT/RE
C .LE;Add a new message id to the message id file.
C .SK
C 	MCR>QMT/IN/ID:<--16 character message id>/MX:<max number of messages>
C .LE;Update the maximum number of messages (permitted in the message id
C subqueue) in the message id file.
C .SK
C 	MCR>QMT/UP/ID:<--16 character message id>/MX:<max number of messages>
C .LE;Delete a message id from the message id file.
C .SK
C 	MCR>QMT/DE/ID:<--16 character message id>
C .LE;Delete messages from the message id subqueue.  The ACP
C must be mounted to device ZQ0:
C .SK
C 	MCR>QMT/DL/ID:<--16 character message id>/MX:<max number of messages>
C .LE;Perform a consistency check on the queue file (will basically traverse
C the message links in each message id subqueue and free all blocks that are 
C marked as used but are not linked in any subqueue).  Notes: Dismount the ACP
C from the device ZQ0: before performing this check.  Some link errors will
C result in an entire reset of the queue file.
C .SK
C 	MCR>QMT/CON
C .LE;Mount the ACP to device ZQ0:
C .SK
C 	MCR>QMT/MOU
C .LE;Dismount the ACP from the device ZQ0:
C .SK
C 	MCR>QMT/DMO
C .le;Dump the message id listhead for the specified message id.  The ACP
C must be mounted to device ZQ0:
C .SK
C 	MCR>QMT/DID/ID:<message id>
C .le;Dump the Message id Queue header.  The ACP must be mounted to device
C ZQ0:
C .SK
C 	MCR>QMT/DQH
C .ELS
C 
C end.doc ****************************** end.doc  
C

	IMPLICIT COMPLEX (A-Z)
C
C MACROS FOR THE QUEUE
C
	INCLUDE 'QHDDEF.TXT/LIST'
	INCLUDE 'MIDDEF.TXT/LIST'
	INCLUDE 'HDRDEF.TXT/LIST'
	INCLUDE 'QFILE.TXT/LIST'

C
 	INTEGER*2 	STATUS     	! RETURN STATUS
 	BYTE STATB(2)			! 
 	EQUIVALENCE(STATUS,STATB) 	! BYTE ADDRESSABLE STATUS
	INTEGER*2 IDCNT	! NUMBER OF IDS 
	BYTE IDNAME(16) ! MESSAGE ID NAME (FOR /ID SWITCH)
	INTEGER*2 QUESIZ ! NUMBER OF MESSAGE BLOCKS (FOR /CR SWITCH)
	INTEGER*2 SWITCH ! SWITCH DENOTING WHICH SWITCHES ARE PRESENT
	INTEGER*2 INDX	 ! DUMMY VARIABLE
	COMMON/PARSE/IDCNT,IDNAME,QUESIZ,SWITCH
C
	INTEGER CRMSK	! /CR SWITCH PRESENT
	INTEGER LIMSK	! /LI SWITCH PRESENT
	INTEGER REMSK	! /RE SWITCH PRESENT
	INTEGER INMSK	! /IN SWITCH PRESENT
	INTEGER IDMSK	! /ID SWITCH PRESENT
	INTEGER MXMSK	! /MX SWITCH PRESENT
	INTEGER UPMSK	! /UP SWITCH PRESENT
	INTEGER DEMSK	! /DE SWITCH PRESENT
	INTEGER MOUMSK	! /MOU SWITCH PRESENT
	INTEGER DMOMSK	! /DMO SWITCH PRESENT
	INTEGER DIDMSK	! /DID SWITCH PRESENT
	INTEGER DQHMSK	! /DQH SWITCH PRESENT
	INTEGER CONMSK	! /CON SWITCH PRESENT
	INTEGER DLMSK	! /DL SWITCH PRESENT
C
C LUNS
C
C
	INTEGER ICO	! CONSOLE OUTPUT LUN
	INTEGER IDLUN	! MESSAGE ID FILE LUN
	INTEGER IQULUN	! QUEUE FILE LUN
	INTEGER ILST	! LIST FILE
	INTEGER LUN	! ZQ0: LUN
	INTEGER IEFN    ! EVENT FLAG
C
	INTEGER DSW	! DIRECTIVE STATUS WORD
	BYTE DSWB(2)
	EQUIVALENCE (DSW,DSWB)
C
	INTEGER IOS(2)  ! I/O STATUS
	BYTE IOSB(4)
	EQUIVALENCE (IOS,IOSB)
C
C MESSAGE ID FILE RECORD
C
	BYTE IDREC(20)	! SIZE OF RECORD
	BYTE MESGID(16) ! MESSAGE ID
	INTEGER*2 MAXMSG ! NUMBER OF IDS
	INTEGER*2 DUMMY ! NOT USED
C
	EQUIVALENCE(IDREC(1),MESGID)
	EQUIVALENCE(IDREC(17),MAXMSG)
	EQUIVALENCE(IDREC(19),DUMMY)
C
	INTEGER INUM	! FORTRAN ERROR LAST SEEN
	INTEGER IFCS	! FCS RETURN STATUS
	INTEGER IFCS2	! SECOND FCS STATUS
	INTEGER IUNIT	! UNIT THAT ERROR OCCURRED ON
	INTEGER PAGCNT	! NUMBER OF LINES ON PAGE
C
	INTEGER HDRSIZ	! SIZE OF HEADER PORTION OF QUEUE
	INTEGER TOTQUE	! NOTAL NUMBER OF BLOCKS TO BE ALLOCATED IN QUEE
C
	INTEGER I,J,IBIT  ! LOOP VARIABLES
	INTEGER IMASK
	INTEGER QMTPRS	! COMMAND PARSER FUNCTION SUBROUTINE
	INTEGER NSET	! NUMBER OF BITS SET IN WORD FUNCTION SUBROUTINE
	INTEGER NONBLK	! TELLS IF ID IS NONBLANK OR NULL
	INTEGER ILOC	! LOCATION COUNTER 
C
	INTEGER*2	BLKREC	   ! CURRENT BLK RECORD
	INTEGER*2	CURLOC	   ! CURRENT LOCATION IN BLK
	INTEGER*2	DELQ	   ! DELETE MSGS FROM QUEUE FUNCTION VALUE
	INTEGER*2	READHD	   ! READ QUEUE HEADER FUNCTION VALUE
	INTEGER*2	READID	   ! READ MSG ID FUNCTION VALUE
	BYTE		MXASC(6)   ! ASCII CONNECTED TASK NAME
	INTEGER*2 	RECSIZ	   ! NUMBER OF BYTES READ
C
	BYTE		BLOCK(512) ! DATA READ FROM ONE BLOCK OF QUEUE FILE
				   !    HEADER
	INTEGER*2	POS	   ! POSITION WITHIN BLOCK
	INTEGER*2	RECN	   ! NUMBER OF RECORD TO BE READ
	INTEGER*2	BITMAP(1250) ! MESSAGE BLOCKS USED
	INTEGER*2	MSGBLK(256)  ! DATA READ FROM ONE MESSAGE BLOCK
	INTEGER*2	BXCNT	   ! NUMBER OF BYTES IN MESSAGE THIS BLOCK
	INTEGER*2	BXNXT	   ! POINTER TO NEXT BLOCK OF MESSAGE
	INTEGER*2	BXMSG	   ! POINTER TO FIRST BLOCK NEXT MESSAGE
	EQUIVALENCE	(MSGBLK,HDRDEF)
	EQUIVALENCE	(MSGBLK(254),BXCNT),(MSGBLK(255),BXNXT),
	1		(MSGBLK(256),BXMSG)
	INTEGER*2	BLKNBR(15) ! BLOCK NUMBERS USED BY ONE MESSAGE
	INTEGER*2	INDEX	   ! POSITION IN 'BLKNBR' ARRAY
	INTEGER*2	MSGCNT	   ! NUMBER OF MESSAGES IN MSG ID SUBQUEUE
	INTEGER*2	VOLCNT	   ! NUMBER OF VOLATILE MSGS IN MSG ID SUBQUEUE
	INTEGER*2	HDRBKS	   ! NUMBER OF BLOCKS IN HEADER
	INTEGER*2	LSTBLK	   ! LAST BLOCK OF LAST MESSAGE EXAMINED
	INTEGER*2	BITSET	   ! NUMBER OF MESSAGE BLOCKS USED
	LOGICAL*2	FIRST	   ! IF TRUE, MESSAGE BLOCK READ IS FIRST
				   !   BLOCK OF MESSAGE
	INTEGER*2	ITYPE	   ! TYPE OF MESSAGE 
	INTEGER*2	BYTES	   ! TOTAL BYTES IN MESSAGE
C
	DATA IEFN/1/	! EVENT FLAG
	DATA LUN/6/	! ZQ0: LUN
	DATA CURLOC/0/
	DATA BLKREC/1/
C

	DATA CRMSK/"1/	! MASK IN SWITCH FOR EACH POSSIBLE SWITCH
	DATA LIMSK/"2/	
	DATA REMSK/"4/
	DATA INMSK/"10/
	DATA IDMSK/"20/
	DATA MXMSK/"40/
	DATA UPMSK/"100/
	DATA DEMSK/"200/
	DATA MOUMSK/"400/
	DATA DMOMSK/"1000/
	DATA DIDMSK/"2000/
	DATA DQHMSK/"4000/
	DATA CONMSK/"10000/
	DATA DLMSK/"20000/
C
	DATA IDLUN/1/
	DATA IQULUN/2/
	DATA ICO/5/
	DATA ILST/4/

C
C SET SO WON'T LOG SOME EXPECTED ERRORS
C
	CALL ERRSET(36,,,,.FALSE.,)	! DON'T LOG RECORD NOT FOUND ERRORS
c
c Get command option from the user
c
100	CONTINUE
	IF( QMTPRS(INDX) .LT. 0 )CALL EXIT  ! COMPLETE
C
D	TYPE *,' IDCNT: ',IDCNT
D	TYPE *,' QUESIZ: ',QUESIZ
D	WRITE (ICO,200)SWITCH
D200	FORMAT(' SWITCH: ',O6)
D	WRITE(ICO,210)IDNAME
D210	FORMAT(' IDNAME: ',16A1)
C
C NOW LOOK FOR INCOMPATABLE SWITCH SETTINGS
C
	IMASK= DEMSK .OR. REMSK .OR. 
	1	LIMSK .OR. UPMSK .OR. CRMSK .OR. INMSK .OR.
	1	MOUMSK .OR. DMOMSK .OR. DIDMSK .OR. DQHMSK .OR. 
	1	CONMSK .OR. DLMSK
	IF ((SWITCH .AND. IMASK) .EQ. 0)THEN
		TYPE *,' NO FUNCTION SELECTED '
		CALL EXIT
	ELSE
		IF(NSET(SWITCH .AND. IMASK) .GT. 1)THEN
		   TYPE *,' MULTIPLE FUNCTIONS SELECTED'
		   TYPE *,' ENTER ONLY ONE FUNCTION'
		   CALL EXIT
		ENDIF
	ENDIF

C
C CREATE FUNCTION
C
	IF((SWITCH .AND. CRMSK).NE. 0)THEN
	IF(QUESIZ .EQ. 0 .OR. QUESIZ .GT. 20000)THEN
		TYPE *,' INVALID QUESIZ ENTERED OF: ',QUESIZ
		CALL EXIT
	ENDIF
C
C READ THE MESSAGE ID FILE AND FIND OUT HOW MANY MESSAGE
C IDS ARE DEFINED
C
	CALL OPENID(IDLUN)
	IDCNT=0
1300	CONTINUE
	READ(UNIT=IDLUN,END=1400,ERR=820)IDREC
	IDCNT=IDCNT+1
	GO TO 1300
C
1400	CONTINUE
	TYPE *,' QUEUE WILL CONTAIN: ',IDCNT,' MESSAGE IDS'
C
C CALCULATE THE NUMBER OF BLOCKS THAT WILL BE NEEDED IN THE ACTUAL OUTPUT 
C QUEUE.  THE HEADER PORTION WHICH IS EVENTUALLY PLACED IN THE REGION CREATED 
C BY THE QUEACP IS MADE UP OF THE MESSAGE ID LIST HEADS, THE QUEUE HEADER, 
C THE BITMAPS FOR THE MESSAGE BLOCKS, AND SOME PADDING TO ROUND UP TO A WHOLE
C DISK BLOCK
C	HEADERSIZE=IDCOUNT(M_LEN)+Q_KSIZ+(QUESIZ+15/16)
C	HEADERSIZE=HEADERSIZE+IMOD(HEADERSIZE,512)
C TOTAL NUMBER OF BLOCKS IS THEREFORE:
C 	HEADERSIZE/512 + QUESIZ
C
	HDRSIZ=(IDCNT*MxLEN)+ ! SIZE OF THE MESSAGE ID LIST HEADS
	1	QxKSIZ+		! SIZE OF THE HEADER PORTION OF QUEUE
	1	(((QUESIZ+15)/16)*2) ! SIZE OF BIT MAP (ROUNDED TO WHOLE WORD)
C
	WRITE(ICO,1420)HDRSIZ
1420	FORMAT(' HEADER SIZE: ',O6)
	TOTQUE=((HDRSIZ+511)/512)+QUESIZ
	TYPE *,' TOTAL QUEUE SIZE IN BLOCKS: ',TOTQUE
C
C OPEN THE QUEUE FILE
C
	OPEN(UNIT=IQULUN,
	1	FILE=QFILE,
	1	ERR=1550,
	1	ACCESS='DIRECT',
	1	STATUS='NEW',
	1	RECL=128,	
	1	INITIALSIZE=TOTQUE,
	1	MAXREC=TOTQUE,
	1	FORM='UNFORMATTED',
	1	ORGANIZATION='SEQUENTIAL',
	1	CARRIAGECONTROL='NONE',
	1	RECORDTYPE='FIXED')

C
C NOW LOAD THE JUST OPENNED QUEUE FILE WITH THE MESSAGE IDS AND THE LIKE
C
	CLOSE(UNIT=IDLUN)	! CLOSE SO REPOSITION TO BEGINNING
	CALL OPENID(IDLUN)	! REOPEN SO CAN READ THE ID'S AGAIN
C
C FIRST FILL IN THE HEADER
C
	QxSIZ=QUESIZ		! SIZE OF THE QUEUE
	QxIDC=IDCNT		! NUMBER OF MESSAGE ID'S DEFINED
	QxFREE=QUESIZ		! NUMBER FREE IS NUMBER AVAILABLE
	QxUPD(1)=0		! LAST UPDATED TIME
	QxUPD(2)=0
	QxUPD(3)=0
	QxUPD(4)=0
	DO 1500 I=1,6
		QxNODE(I)= 0	! LOCAL NODE NAME
1500	CONTINUE
C
	CALL TRANS(IQULUN,QHDDEF,QxKSIZ,BLKREC,CURLOC)	! TRANSFER TO FILE
C
C NOW FILL IN ALL OF THE MESSAGE IDS
C
1555	READ(UNIT=IDLUN,END=1570,ERR=820)IDREC
	DO 1560 I= 1,MxIDSZ
		MxMID(I)=MESGID(I)	! COPY MESSAGE ID NAME
1560	CONTINUE
C
	MxFLK=0 ! FORWARD LINK
	MxBLK=0	! BACKWARD LINK
	MxRNA=0 ! RNA
	MxBNA=0	! BNA
	MxMAX=MAXMSG ! MAXIMUM NUMBER OF MESSAGES THIS ID
	MxCNT=0 ! CURRENT NUMBER THIS ID
	MxQSEQ=0 ! ON QUEUE SEQUENCE
	MxR50(1)=0 ! RAD50 CONNECTED TASK NAME 
	MxR50(2)=0 ! RAD50 CONNECTED TASK NAME 
	MxTCB=0	! ATTACHTED TASK TCB ADDRESS
	MxEFN=0 ! EVENT FLAT TO SET
	MxNVC=0 ! NUMBER OF VOLITALE MESSAGES IN QUEUE
	MxNVL=0	! LINK TO LAST SCANNED VOLATILE MESSAGE
C	MxLST=0	! LAST BLOCK NUMBER OF MSG LINKED TO LAST SCANNED
	CALL TRANS(IQULUN,MIDDEF,MxLEN,BLKREC,CURLOC)	! TRANSFER TO FILE
	GO TO 1555			! GO UNTIL EMPTY MESSAGE ID FILE
C
C ALL MESSAGE ID'S STORED, NOW MARK ALL OF THE BLOCKS AS NOT IN USE
C IN THE BIT MAP.
C	
1570	CONTINUE
	I=(QUESIZ+15)/16 ! NUMBER OF WORDS NEEDED FOR BIT MAP
C
	DO 1600 J=1,I		! LOOP FOR NUMBER OF WORDS IN BIT MAP
	  CALL TRANS(IQULUN,0,2,BLKREC,CURLOC)	! SINGLE WORD FOR BIT MAP
1600	CONTINUE
C
C ALL DONE, TELL TRANS TO COMPLETE ITS WORK (WILL ZERO REST OF ANY
C LEFT OVER BLOCK AND WRITE RECORD "TOTQUE")
C
	CALL TRANS(IQULUN,0,-TOTQUE,BLKREC,CURLOC)
	TYPE *,' QUEUE HAS BEEN CREATED'
	CALL EXIT
C
C FILE OPEN ERROR ON THE QUEUE FILE
C
1550	CONTINUE
	CALL ERRSNS(INUM,IFCS,IFCS2,IUNIT)
	TYPE *,' FILE OPEN ERROR ON THE NEW QUEUE FILE'
	TYPE *,' RMS STATUS: ',IFCS
	CALL EXIT

C
C LIST FUNCTION
C
	ELSEIF((SWITCH .AND. LIMSK).NE. 0)THEN
	TYPE *,' LIST FUNCTION'
	CALL OPENID(IDLUN)
C
C SIMPLY READ AND FORMAT THE CONTENTS
C
	OPEN(UNIT=ILST,NAME='SY0:MESGID.LST',TYPE='NEW')
	PAGCNT=0
	WRITE(ILST,300)
300	FORMAT(1H1,T27,' MESSAGE ID  LIST')
	WRITE(ILST,310)
310	FORMAT(//,T20,'MESSAGE ID',5X,' MAXIMUM NUMBER',/
	1	T20,'-----------',6X,'--------------')
C
320	READ(UNIT=IDLUN,END=400)IDREC
	PAGCNT=PAGCNT+1
	IF(PAGCNT .GT. 60)THEN
		PAGCNT=0
		WRITE(ILST,300)
		WRITE(ILST,310)
	ENDIF
	WRITE(ILST,340)MESGID,MAXMSG
340	FORMAT(T20,16A1,5X,I5)
	GOTO 320
C
400	CLOSE(UNIT=ILST,DISPOSE='PRINT')
	TYPE *,' MESGID.LST HAS BEEN SPOOLED TO THE PRINTER'
	CALL EXIT

C
C RESET FUNCTION
C
	ELSEIF((SWITCH .AND. REMSK).NE. 0)THEN
	TYPE *,' RESET FUNCTION'
C
C OPEN THE QUEUE FILE
C
	OPEN(UNIT=IQULUN,
	1	FILE=QFILE,
	1	ERR=590,
	1	ACCESS='DIRECT',
	1	STATUS='OLD',
	1	RECL=128,	
	1	FORM='UNFORMATTED',
	1	ORGANIZATION='SEQUENTIAL',
	1	CARRIAGECONTROL='NONE',
	1	RECORDTYPE='FIXED')

500	POS = 1
	RECN = 1

	READ (IQULUN'RECN,ERR=580) BLOCK
C
C	GET QUEUE HEADER DATA
C
	DO 505 I=1,QXKSIZ			
		QHDDEF(I) = BLOCK(POS)
		POS = POS + 1		! INCREMENT POSITION IN BLOCK
505	CONTINUE

CC	TYPE *,'*DEBUG* NUMBER OF MESSAGE BLOCKS = ',QxSIZ
CC	TYPE *,'*DEBUG* NUMBER OF MESSAGE ID''S DEFINED = ',QxIDC

C
C FIRST RESET THE HEADER
C
	QxFREE=QxSIZ		! NUMBER FREE IS NUMBER AVAILABLE
	QxUPD(1)=0		! LAST UPDATED TIME
	QxUPD(2)=0
	QxUPD(3)=0
	QxUPD(4)=0
	DO 510 I=1,6
		QxNODE(I)= 0	! LOCAL NODE NAME
510	CONTINUE
C
	CALL TRANS(IQULUN,QHDDEF,QxKSIZ,BLKREC,CURLOC)	! TRANSFER TO FILE
C
C NOW RESET ALL OF THE MESSAGE IDS
C
	DO 530 I=1,QxIDC

	     DO 520 J=1,MxLEN
		MIDDEF(J) = BLOCK(POS)	! MOVE MESSAGE ID HEADER DATA
		POS = POS + 1		! INCREMENT POSITION IN BLOCK
		IF (POS .GT. 512) THEN
		     RECN = RECN + 1	! NEXT RECORD
		     READ (IQULUN'RECN,ERR=580) BLOCK
		     POS = 1		! RESET POSITION IN BLOCK
		END IF
520	     CONTINUE

	     MxFLK=0 	! FORWARD LINK
	     MxBLK=0	! BACKWARD LINK
	     MxRNA=0 	! RNA
	     MxBNA=0	! BNA
	     MxCNT=0 	! CURRENT NUMBER THIS ID
	     MxQSEQ=0 	! ON QUEUE SEQUENCE
	     MxR50(1)=0 ! RAD50 CONNECTED TASK NAME 
	     MxR50(2)=0 ! RAD50 CONNECTED TASK NAME 
	     MxTCB=0	! ATTACHTED TASK TCB ADDRESS
	     MxEFN=0 	! EVENT FLAT TO SET
	     MxNVC=0 	! NUMBER OF VOLITALE MESSAGES IN QUEUE
	     MxNVL=0	! LINK TO LAST SCANNED VOLATILE MESSAGE
	     MxLST=0	! LAST BLOCK NUMBER OF MSG LINKED TO LAST SCANNED

	     CALL TRANS(IQULUN,MIDDEF,MxLEN,BLKREC,CURLOC)	! TRANSFER TO FILE

530	CONTINUE
C
C ALL MESSAGE ID'S STORED, NOW MARK ALL OF THE BLOCKS AS NOT IN USE
C IN THE BIT MAP.
C	
540	CONTINUE
	I=(QxSIZ+15)/16 ! NUMBER OF WORDS NEEDED FOR BIT MAP
C
	DO 550 J=1,I		! LOOP FOR NUMBER OF WORDS IN BIT MAP
	  CALL TRANS(IQULUN,0,2,BLKREC,CURLOC)	! SINGLE WORD FOR BIT MAP
550	CONTINUE
C
C
C ALL DONE, TELL TRANS TO WRITE LAST BLOCK OF HEADER
C
	CALL TRANS(IQULUN,0,0,BLKREC,CURLOC)
	TYPE *,' QUEUE HAS BEEN RESET'
	CALL EXIT
C
C ERROR READING FROM QUEUE FILE
C
580	TYPE *,'ERROR READING FROM QUEUE FILE'
	CALL EXIT
C
C FILE OPEN ERROR ON THE QUEUE FILE
C
590	CONTINUE
	CALL ERRSNS(INUM,IFCS,IFCS2,IUNIT)
	TYPE *,' FILE OPEN ERROR ON THE QUEUE FILE'
	TYPE *,' RMS STATUS: ',IFCS
	CALL EXIT

C
C INSERT FUNCTION
C
	ELSEIF((SWITCH .AND. INMSK).NE. 0)THEN
	IF ((SWITCH .AND. IDMSK) .EQ.0)THEN
		TYPE *,' NO MESSAGE ID SPECIFIED '
		CALL EXIT
	ENDIF
C
	NONBLK=0	! ASSUME NO NONBLANK ID FOUND
	DO 805 I=1,16
		IF(IDNAME(I).EQ. "0)IDNAME(I)="40 ! PAD NULLS WITH SPACES
		IF(IDNAME(I) .LT. "040)THEN	! INVALID CHARACTER
			TYPE *,' MESSAGE ID CONTAINS INVALID CHARACTER'
			CALL EXIT  ! THIS IS DIFFICULT TO HAPPEN
		ENDIF
		IF(IDNAME(I) .NE. "40)NONBLK=1 ! SET NONBLANK ID
		MESGID(I)=IDNAME(I)	! COPY ID NAME AS ENTERED BY USER
805	CONTINUE
C
	IF(NONBLK .EQ. 0)THEN
		TYPE *,' BLANK OR MISSING MESSAGE ID ENTERED'
		CALL EXIT
	ENDIF
C
	CALL OPENID(IDLUN)
	READ(UNIT=IDLUN,KEY=IDNAME,ERR=820)IDREC
	WRITE(ICO,810)IDNAME
810	FORMAT(' MESSAGE ID:',16A1,' ALREADY EXISTS ')
	CALL EXIT
C
C MAKE SURE THAT IT WAS A NOT FOUND TYPE CODE
C
820	CALL ERRSNS(INUM,IFCS,IFCS2,IUNIT)
	IF(INUM .NE. 36)THEN
		TYPE *,' FILE ACCESS ERROR WHILE ACCESSING MESSAGE ID FILE'
		TYPE *,' RMS ERROR CODE: ',IFCS
		TYPE *,' FORTRAN ERROR CODE: ',INUM
		TYPE *,' EXITING'
		CALL EXIT
	ENDIF
C
	WRITE(ICO,830)IDNAME
830	FORMAT(' MESSAGE ID: ',16A1,' NOT FOUND, ADDING')
C
	MAXMSG=IDCNT	! COPY MAX MESSAGE COUNT FROM USER
	IF(MAXMSG .LE. 0)THEN
		MAXMSG=5	! DEFAULT COUNT
		TYPE *,' WARNING-- MAXIMUM NUMBER OF MESSAGES NOT SPECIFIED'
		TYPE *,'           SETTING TO DEFAULT OF: ',MAXMSG
	ENDIF
C
	WRITE(UNIT=IDLUN)IDREC	! ADD TO OUR MESSAGE ID FILE
	WRITE(ICO,840)IDNAME,MAXMSG
840	FORMAT(' MESSAGE ID: ',16A1,' ADDED SUCCESSFULLY WITH: '
	1	I5,' MESSAGES ALLOWED')
	CALL EXIT

C
C REPLACE OR UPDATE FUNCTION
C
	ELSEIF((SWITCH .AND. UPMSK).NE. 0)THEN
	IF ((SWITCH .AND. IDMSK) .EQ.0)THEN
		TYPE *,' NO MESSAGE ID SPECIFIED '
		CALL EXIT
	ENDIF
C
	NONBLK=0	! ASSUME NO NONBLANK ID FOUND
	DO 905 I=1,16
		IF(IDNAME(I).EQ. "0)IDNAME(I)="40 ! PAD NULLS WITH SPACES
		IF(IDNAME(I) .LT. "040)THEN	! INVALID CHARACTER
			TYPE *,' MESSAGE ID CONTAINS INVALID CHARACTER'
			CALL EXIT  ! THIS IS DIFFICULT TO HAPPEN
		ENDIF
		IF(IDNAME(I) .NE. "40)NONBLK=1 ! SET NONBLANK ID
		MESGID(I)=IDNAME(I)	! COPY ID NAME AS ENTERED BY USER
905	CONTINUE
C
	IF(NONBLK .EQ. 0)THEN
		TYPE *,' BLANK OR MISSING MESSAGE ID ENTERED'
		CALL EXIT
	ENDIF
C
	CALL OPENID(IDLUN)
	READ(UNIT=IDLUN,KEY=IDNAME,ERR=920)IDREC
	MAXMSG=IDCNT	! COPY MAX MESSAGE COUNT FROM USER FOR UPDATE
	IF(MAXMSG .LE. 0)THEN
		MAXMSG=5	! DEFAULT COUNT
		TYPE *,' WARNING-- MAXIMUM NUMBER OF MESSAGES NOT SPECIFIED'
		TYPE *,'           SETTING TO DEFAULT OF: ',MAXMSG
	ENDIF
	REWRITE(UNIT=IDLUN,ERR=920)IDREC ! WRITE MODIFIED RECORD
	TYPE *,' MESSAGE ID UPDATED'
	CALL EXIT
C
C UNABLE TO FIND OR OTHER PROBLEM WITH MODIFING THE ID THE USER ENTERED 
C
920	CALL ERRSNS(INUM,IFCS,IFCS2,IUNIT)
	IF(INUM .NE. 36)THEN
		TYPE *,' FILE ACCESS ERROR WHILE ACCESSING MESSAGE ID FILE'
		TYPE *,' RMS ERROR CODE: ',IFCS
		TYPE *,' FORTRAN ERROR CODE: ',INUM
		TYPE *,' EXITING'
	ELSE
		TYPE *,' MESSAGE ID IS NOT KNOWN, NO UPDATE'
	ENDIF
	CALL EXIT

C
C DELETE FUNCTION
C
	ELSEIF((SWITCH .AND. DEMSK).NE. 0)THEN
	IF ((SWITCH .AND. IDMSK) .EQ. 0)THEN
		TYPE *,' NO MESSAGE ID SPECIFIED '
		CALL EXIT
	ENDIF
C
	NONBLK=0	! ASSUME NO NONBLANK ID FOUND
	DO 1005 I=1,16
		IF(IDNAME(I).EQ. "0)IDNAME(I)="40 ! PAD NULLS WITH SPACES
		IF(IDNAME(I) .LT. "040)THEN	! INVALID CHARACTER
			TYPE *,' MESSAGE ID CONTAINS INVALID CHARACTER'
			CALL EXIT  ! THIS IS DIFFICULT TO HAPPEN
		ENDIF
		IF(IDNAME(I) .NE. "40)NONBLK=1 ! SET NONBLANK ID
		MESGID(I)=IDNAME(I)	! COPY ID NAME AS ENTERED BY USER
1005	CONTINUE
C
	IF(NONBLK .EQ. 0)THEN
		TYPE *,' BLANK OR MISSING MESSAGE ID ENTERED'
		CALL EXIT
	ENDIF
C
	CALL OPENID(IDLUN)
	READ(UNIT=IDLUN,KEY=IDNAME,ERR=1020)IDREC
	DELETE(UNIT=IDLUN,ERR=1020) ! DELETE THIS MESSAGE ID RECORD
	TYPE *,' MESSAGE ID HAS BEEN DELETED'
	CALL EXIT
C
C UNABLE TO FIND OR OTHER PROBLEM WITH MODIFING THE ID THE USER ENTERED 
C
1020	CALL ERRSNS(INUM,IFCS,IFCS2,IUNIT)
	IF(INUM .NE. 36)THEN
		TYPE *,' FILE ACCESS ERROR WHILE ACCESSING MESSAGE ID FILE'
		TYPE *,' RMS ERROR CODE: ',IFCS
		TYPE *,' FORTRAN ERROR CODE: ',INUM
		TYPE *,' EXITING'
	ELSE
		TYPE *,' MESSAGE ID IS NOT KNOWN,  NO DELETEION'
	ENDIF
	CALL EXIT

C
C DELETE nn MESSAGES FROM MSG ID FUNCTION "/DL"
C
	ELSEIF ((SWITCH .AND. DLMSK) .NE. 0)THEN
	IF ((SWITCH .AND. IDMSK) .EQ. 0) THEN
		TYPE *,' NO MESSAGE ID SPECIFIED'
		CALL EXIT
	ENDIF
	
	NONBLK=0	! ASSUME NO NONBLANK ID FOUND
	DO 1100 I=1,16
		IF(IDNAME(I).EQ. "0)IDNAME(I)="40 ! PAD NULLS WITH SPACES
		IF(IDNAME(I) .LT. "040)THEN	! INVALID CHARACTER
			TYPE *,' MESSAGE ID CONTAINS INVALID CHARACTER'
			CALL EXIT  ! THIS IS DIFFICULT TO HAPPEN
		ENDIF
		IF(IDNAME(I) .NE. "40)NONBLK=1 ! SET NONBLANK ID
		MESGID(I)=IDNAME(I)	! COPY ID NAME AS ENTERED BY USER
1100	CONTINUE

	IF(NONBLK .EQ. 0)THEN
		TYPE *,' BLANK OR MISSING MESSAGE ID ENTERED'
		CALL EXIT
	ENDIF

	MAXMSG = IDCNT
	IF (MAXMSG .EQ. 0) THEN
		TYPE *,' NUMBER OF MESSAGES TO DELETE NOT ENTERED'
		CALL EXIT
	END IF

CC	TYPE 1130,MESGID,MAXMSG
CC1130	FORMAT (' MESSAGE ID: ',16A1,' MESSAGES TO DELETE: ',I4)

  	STATUS=DELQ(LUN,IEFN,MESGID,MAXMSG)
 	IF(STATUS .NE. "401)THEN
 		TYPE *,' BAD QUEUE  STATUS ON MESSAGE DELETE'
 		TYPE *,' DIRECTIVE STATUS: ',STATB(1)
 		TYPE *,' I/O STATUS: ',STATB(2)
 	ELSE
		TYPE *,' MESSAGE DELETE SUCCESSFUL'
 		TYPE *,' DIRECTIVE STATUS: ',STATB(1)
 		TYPE *,' I/O STATUS: ',STATB(2)
 	ENDIF

	CALL EXIT

C
C QUEUE CONSISTENCY CHECK FUNCTION "/CON"
C
	ELSEIF ((SWITCH .AND. CONMSK) .NE. 0)THEN
	TYPE *,' CONSISTENCY CHECK'
C
C OPEN THE QUEUE FILE
C
	OPEN(UNIT=IQULUN,
	1	FILE=QFILE,
	1	ERR=1290,
	1	ACCESS='DIRECT',
	1	STATUS='OLD',
	1	RECL=128,	
	1	FORM='UNFORMATTED',
	1	ORGANIZATION='SEQUENTIAL',
	1	CARRIAGECONTROL='NONE',
	1	RECORDTYPE='FIXED')

	POS = 1
	RECN = 1

	READ (IQULUN'RECN,ERR=1285) BLOCK
C
C	GET QUEUE HEADER DATA
C
	DO 1200 I=1,QXKSIZ			
		QHDDEF(I) = BLOCK(POS)
		POS = POS + 1		! INCREMENT POSITION IN BLOCK
1200	CONTINUE

	CALL TRANS(IQULUN,QHDDEF,QXKSIZ,BLKREC,CURLOC)

CC	TYPE *,'*DEBUG* NUMBER OF MESSAGE BLOCKS = ',QXSIZ
CC	TYPE *,'*DEBUG* NUMBER OF MESSAGE ID''S DEFINED = ',QXIDC
CC	TYPE *,'*DEBUG* NUMBER OF MSG BLOCKS FREE = ',QXFREE
C
	HDRSIZ=(QXIDC*MxLEN)+ 	! SIZE OF THE MESSAGE ID LIST HEADS
	1	QxKSIZ+		! SIZE OF THE HEADER PORTION OF QUEUE
	1	(((QXSIZ+15)/16)*2) ! SIZE OF BIT MAP (ROUNDED TO WHOLE WORD)
C
	HDRBKS = (HDRSIZ+511)/512	! NUMBER OF BLOCKS IN QUEUE HEADER
CC	TYPE *,'*DEBUG* BLOCKS IN HEADER = ',HDRBKS
	BITSET = 0			! INIT MESSAGE BLOCKS USED COUNTER

C	EXAMINE MESSAGE BLOCKS LINKED IN EVERY MESSAGE ID
C
	DO 1250 I=1,QXIDC

	     DO 1205 J=1,MXLEN
		MIDDEF(J) = BLOCK(POS)	! MOVE MESSAGE ID HEADER DATA
		POS = POS + 1		! INCREMENT POSITION IN BLOCK
		IF (POS .GT. 512) THEN
		     RECN = RECN + 1	! NEXT RECORD
		     READ (IQULUN'RECN,ERR=1285) BLOCK
		     POS = 1		! RESET POSITION IN BLOCK
		END IF
1205	     CONTINUE

CC	     TYPE 1207,MXMID
CC1207	     FORMAT ('0CHECKING MESSAGE ID SUBQUEUE: ',16A1)

	     MXNVL = 0		! ZERO VOLATILE MESSAGE SCAN POINTERS
	     MXLST = 0
	     MSGCNT = 0		! INIT NBR OF MESSAGES COUNTER
	     VOLCNT = 0 	! INIT NBR VOLATILE MESSAGES COUNTER

	     IF (MXFLK.EQ.0) THEN	   ! NO MESSAGES IN MSG ID QUEUE
		MXBLK = 0		   ! ZERO LAST BLOCK POINTER
		GOTO 1240
	     END IF

C	HAVE MESSAGES IN MSG ID QUEUE; VALIDATE THEM

	     INDEX = 1		! NUMBER OF BLOCKS IN MESSAGE COUNTER
	     BLKNBR(INDEX) = MXFLK   ! FIRST BLOCK
	     FIRST = .TRUE.	! READING FIRST BLOCK OF MESSAGE
	     
1230	     IF (BLKNBR(INDEX).LE.QXSIZ) THEN 	! BLOCK NUMBER IN QUEUE
		READ (IQULUN'HDRBKS+BLKNBR(INDEX),ERR=1285) MSGBLK
						! READ MESSAGE BLOCK
CC		TYPE *,'*DEBUG* MESSAGES... BXNXT = ',BXNXT,' BXMSG = ',BXMSG
CC		TYPE *,'*DEBUG* INDEX = ',INDEX
		IF (FIRST) THEN			! FIRST BLOCK OF MESSAGE
		   ITYPE = HXTYPE		! SAVE MESSAGE TYPE
CC		   TYPE *,'*DEBUG* TYPE = ',ITYPE,' LENGTH = ',HXLEN
		   BYTES = HXLEN + HXSIZ	! TOTAL BYTES IN MESSAGE
CC		   TYPE *,'*DEBUG* BYTES = ',BYTES
		   FIRST = .FALSE.		
		END IF

C		CHECK IF LAST BLOCK OF LAST MESSAGE.  IF LAST BLOCK, BOTH
C		BLOCK POINTERS MUST BE ZERO AND THE NUMBER OF BYTES IN
C		THE LAST BLOCK MUST EQUAL THE VALUE IN 'BYTES'.

		IF (BXNXT.EQ.0 .AND. BXMSG.EQ.0 .AND. BXCNT.EQ.BYTES) THEN
		    				! READ LAST BLOCK OF LAST MSG
		   MSGCNT = MSGCNT + 1		! INCREMENT NUMBER MESSAGES
		   IF (ITYPE.EQ.0) VOLCNT = VOLCNT + 1
						! INCREMENT NBR VOLATILE MSGS
		   DO 1235 IBIT=1,INDEX
			CALL SETBIT(BITMAP,BLKNBR(IBIT)-1)  ! MARK BLOCKS USED
			BITSET = BITSET + 1		    ! ADD TO TOTAL USED
CC			TYPE *,'*DEBUG* QUEUE MESSAGES... BLOCK IN USE: ',
CC	1			BLKNBR(IBIT),' MESSAGE: ',MSGCNT
1235		   CONTINUE
		   IF (MXBLK.NE.BLKNBR(INDEX)) THEN
		       				! REACHED END OF MESSAGE BUT
						!   LAST BLOCK NUMBER DOESN'T
						!   AGREE WITH MXBLK
		       TYPE 1236,MXMID
1236		       FORMAT ('0MESSAGE ID SUBQUEUE: ',16A1,' BAD LAST BLOCK',
	1		       ' POINTER.')
		       TYPE *,'   ENTIRE QUEUE WILL BE RESET'
		       CURLOC = 0	! RESET BLOCK AND POSITION POINTERS	
		       BLKREC = 1	!   FOR WRITE TO FILE
		       GOTO 500		! RESET ENTIRE QUEUE FILE
		   END IF
		   
C		CHECK IF LAST BLOCK OF MESSAGE.  IF LAST BLOCK, NEXT BLOCK
C		IN MESSAGE POINTER MUST BE ZERO, FIRST BLOCK OF NEXT
C		MESSAGE MUST BE NONZERO AND THE NUMBER OF BYTES IN
C		THE LAST BLOCK MUST EQUAL THE VALUE IN 'BYTES'

		ELSE IF (BXNXT.EQ.0 .AND. BXMSG.NE.0 .AND. BXCNT.EQ.BYTES) THEN
						! SETUP FOR READ OF FIRST BLOCK
						!   BLOCK IN NEXT MESSAGE
		   MSGCNT = MSGCNT + 1		! INCREMENT NUMBER MESSAGES
		   IF (ITYPE.EQ.0) VOLCNT = VOLCNT + 1
						! INCREMENT NBR VOLATILE MSGS
		   DO 1237 IBIT=1,INDEX
			CALL SETBIT(BITMAP,BLKNBR(IBIT)-1)  ! MARK BLOCKS USED
			BITSET = BITSET + 1		    ! ADD TO TOTAL USED
CC			TYPE *,'*DEBUG* QUEUE MESSAGES... BLOCK IN USE: ',
CC	1			BLKNBR(IBIT),' MESSAGE: ',MSGCNT
1237		   CONTINUE

		   LSTBLK = BLKNBR(INDEX)	! SAVE LAST BLOCK OF THIS MSG
		   FIRST = .TRUE.		! WILL BE READING FIRST BLOCK
						!   OF NEXT MESSAGE
		   INDEX = 1			! RESET BLOCK COUNTER
		   BLKNBR(INDEX) = BXMSG	! NEXT BLOCK TO READ
		   GO TO 1230
		
C		CHECK IF MORE BLOCKS IN MESSAGE.  IF MORE, THE POINTER TO THE 
C		NEXT BLOCK IN THE MESSAGE MUST BE NONZERO, THE POINTER TO THE 
C		FIRST BLOCK OF THE NEXT MESSAGE MUST BE ZERO, AND THE BYTE COUNT
C		OF THE BLOCK MUST BE 506.

		ELSE IF (BXNXT.NE.0 .AND. BXMSG.EQ.0 .AND. BXCNT.EQ.506) THEN
						! SETUP FOR READ OF NEXT BLOCK
						!   IN MESSAGE
		   INDEX = INDEX + 1		! INCREMENT COUNTER OF BLOCKS
						!   IN MESSAGE
		   BLKNBR(INDEX) = BXNXT	! NEXT BLOCK TO READ
		   BYTES = BYTES - 506		! FINISHED THIS BLOCK
		   GO TO 1230
		
		ELSE			
		   IF (MSGCNT.EQ.0) THEN	! ALL MESSAGES BAD
			MXFLK = 0
			MXBLK = 0
		   ELSE				! UPDATE END OF MESSAGES POINTER
		   	MXBLK = LSTBLK		! UPDATE LAST BLOCK POINTER
			READ (IQULUN'HDRBKS+LSTBLK,ERR=1285) MSGBLK
						! READ LAST BLOCK OF NEW LAST
						!   MESSAGE IN QUEUE
			BXNXT = 0		! UPDATE POINTERS IN THE BLOCK
			BXMSG = 0		
			WRITE (IQULUN'HDRBKS+LSTBLK,ERR=1287) MSGBLK
						! WRITE IT BACK
		   END IF
		   TYPE 1238,MXMID
1238		   FORMAT ('0MESSAGE ID SUBQUEUE: ',16A1,' BAD LINK; ',
	1		   'MESSAGES MAY BE LOST.')
		   TYPE *,'      PREVIOUS MESSAGE COUNT = ',MXCNT
		   TYPE *,'      UPDATED  MESSAGE COUNT = ',MSGCNT

		END IF

	     ELSE				! BAD BLOCK NUMBER
		IF (MSGCNT.EQ.0) THEN		! ALL MESSAGES BAD
		     MXFLK = 0
		     MXBLK = 0
		ELSE				! UPDATE END OF MESSAGES POINTER
		     MXBLK = LSTBLK		! UPDATE LAST BLOCK POINTER
		     READ (IQULUN'HDRBKS+LSTBLK,ERR=1285) MSGBLK
						! READ LAST BLOCK OF NEW LAST
						!   MESSAGE IN QUEUE
		     BXNXT = 0		! UPDATE POINTERS IN THE BLOCK
		     BXMSG = 0		
		     WRITE (IQULUN'HDRBKS+LSTBLK,ERR=1287) MSGBLK
						! WRITE IT BACK
		END IF
		TYPE 1239,MXMID
1239		FORMAT ('0MESSAGE ID SUBQUEUE: ',16A1,' BAD BLOCK NUMBER; ',
	1		'MESSAGES MAY BE LOST.')
		TYPE *,'      PREVIOUS MESSAGE COUNT = ',MXCNT
		TYPE *,'      UPDATED  MESSAGE COUNT = ',MSGCNT
	
	     END IF

1240	     MXCNT = MSGCNT		! UPDATE NUMBER OF MESSAGES IN MSG
					!   ID QUEUE
	     MXNVC = VOLCNT		! UPDATE NUMBER OF VOLATILE MESSAGES

	     CALL TRANS(IQULUN,MIDDEF,MXLEN,BLKREC,CURLOC)	
						! TRANSFER MSG ID HEADER FOR
						!   WRITE TO FILE
1250	CONTINUE	

C	TRANSFER BIT MAP FOR WRITE TO QUEUE FILE HEADER

	I = (QXSIZ+15)/16		! CALC NUMBER OF WORDS IN BITMAP
	DO 1260 J=1,I			! TRANSFER ONE WORD AT A TIME
	     CALL TRANS(IQULUN,BITMAP(J),2,BLKREC,CURLOC)	
1260	CONTINUE
	CALL TRANS(IQULUN,0,0,BLKREC,CURLOC)	! WRITE LAST HEADER BLOCK	

C	UPDATE FREE BLOCK COUNTER IN QUEUE HEADER IF NECESSAEY

	IF (QXSIZ-QXFREE.NE.BITSET) THEN	! NECESSARY TO UPDATE
	     READ (IQULUN'1,ERR=1285) MSGBLK	! READ FIRST BLOCK
	     MSGBLK(7) = QXSIZ - BITSET		! CALC NUMBER OF FREE BLOCKS
	     WRITE (IQULUN'1,ERR=1287) MSGBLK	! WRITE IT BACK
	     TYPE 1270,QXFREE
1270	     FORMAT ('0PREVIOUS FREE BLOCK COUNT = ',I7)
	     TYPE *,'UPDATED  FREE BLOCK COUNT = ',MSGBLK(7)
	END IF

	TYPE 1280
1280	FORMAT ('0CONSISTENCY CHECK COMPLETED')
	CALL EXIT
C
C ERROR READING FROM QUEUE FILE
C
1285	TYPE *,'ERROR READING FROM QUEUE FILE'
	CALL EXIT
C
C ERROR WRITING QUEUE FILE
C
1287	TYPE *,'ERROR WRITING TO QUEUE FILE'
	CALL EXIT
C
C FILE OPEN ERROR ON THE QUEUE FILE
C
1290	CONTINUE
	CALL ERRSNS(INUM,IFCS,IFCS2,IUNIT)
	TYPE *,' FILE OPEN ERROR ON THE QUEUE FILE'
	TYPE *,' RMS STATUS: ',IFCS
	CALL EXIT

C
C MOUNT FUNCTION "/MOU"
C
	ELSEIF ((SWITCH .AND. MOUMSK) .NE. 0)THEN
	TYPE *,' ATTEMPTING TO MOUNT ZQ:'
C
	CALL ASNLUN(LUN,'ZQ',0,DSW)		! ASSIGN LUN TO ZQ DEVICE
	IF(DSWB(1) .NE. 1)THEN			! UNABLE TO ASSIGN
		TYPE *,' UNABLE TO ASSIGN A LUN TO ZQ0: '
		TYPE *,' MAKE SURE DEVICE DRIVER IS LOADED '
		TYPE *,' DIRECTIVE STATUS ERROR: ',DSWB(1)
		CALL EXIT
	ENDIF
C		
	CALL WTQIO("14001,LUN,IEFN,,IOS,,DSW)  	! IO.APC + 1
	IF(DSWB(1) .NE. 1)THEN	! BAD DIRECTIVE STATUS
		TYPE *,' BAD DIRECTIVE STATUS WHILE ATTEMPTING TO MOUNT'
		TYPE *,' MAKE SURE YOU HAVE THE REQUIRED PRIVELEGE'
		TYPE *,' DIRECTIVE STATUS: ',DSWB(1)
		CALL EXIT
	ENDIF
C
	IF(IOSB(1) .NE. 1)THEN		! BAD STATUS
		TYPE *,' UNABLE TO MOUNT, STATUS: ',IOSB(1)
	ELSE
		TYPE *,' DEVICE MOUNTED SUCCESSFULLY'
	ENDIF
	CALL EXIT

C
C DISMOUNT FUNCTION "/DMO"
C
	ELSEIF ((SWITCH .AND. DMOMSK) .NE. 0)THEN
	TYPE *,' ATTEMPTING DISMOUNT OF ZQ0: '
	TYPE *,' ALL QUEUEING FUNCTIONS WILL BE DISABLED'
C
	CALL ASNLUN(LUN,'ZQ',0,DSW)		! ASSIGN LUN TO ZQ DEVICE
	IF(DSWB(1) .NE. 1)THEN			! UNABLE TO ASSIGN
		TYPE *,' UNABLE TO ASSIGN A LUN TO ZQ0: '
		TYPE *,' MAKE SURE DEVICE DRIVER IS LOADED '
		TYPE *,' DIRECTIVE STATUS ERROR: ',DSWB(1)
		CALL EXIT
	ENDIF
C		
	CALL WTQIO("14002,LUN,IEFN,,IOS,,DSW)  	! IO.APC + 2
	IF(DSWB(1) .NE. 1)THEN	! BAD DIRECTIVE STATUS
		TYPE *,' BAD DIRECTIVE STATUS WHILE ATTEMPTING TO DISMOUNT'
		TYPE *,' MAKE SURE YOU HAVE THE REQUIRED PRIVELEGE'
		TYPE *,' DIRECTIVE STATUS: ',DSWB(1)
		CALL EXIT
	ENDIF
C
	IF(IOSB(1) .NE. 1)THEN		! BAD STATUS
		TYPE *,' UNABLE TO DISMOUNT, STATUS: ',IOSB(1)
	ELSE
		TYPE *,' DEVICE DISMOUNTED SUCCESSFULLY'
	ENDIF
	CALL EXIT

C
C DISPLAY MESSAGE ID LISTHEAD  "/DID/ID:<....."
C
	ELSEIF ((SWITCH .AND. DIDMSK) .NE. 0)THEN
	DO 10000 I=1,16
		IF (IDNAME(I).EQ.0) IDNAME(I) = ' '
10000	CONTINUE
CCC	TYPE *,' DISPLAYING MESSAGE ID '
	CALL ASNLUN(LUN,'ZQ',0,DSW)		! ASSIGN LUN TO ZQ DEVICE
	IF(DSWB(1) .NE. 1)THEN			! UNABLE TO ASSIGN
		TYPE *,' UNABLE TO ASSIGN A LUN TO ZQ0: '
		TYPE *,' MAKE SURE DEVICE DRIVER IS LOADED '
		TYPE *,' DIRECTIVE STATUS ERROR: ',DSWB(1)
		CALL EXIT
	ENDIF
C
 	STATUS=READID(LUN,IEFN,IDNAME,MIDDEF,MXLEN,RECSIZ)
C
 	IF(STATUS .NE. "401)THEN
 		TYPE *,' BAD QUEUE  STATUS ON MESSAGE ID LIST HEAD READ'
 		TYPE *,' DIRECTIVE STATUS: ',STATB(1)
 		TYPE *,' I/O STATUS: ',STATB(2)
 	ELSE
		WRITE (5,10700) MXMID,RECSIZ
10700		FORMAT (' MESSAGE ID ',16A1,'        SIZE OF MSG ID HEADER = ',
	1		I2)
		WRITE (5,10710) MXFLK
10710		FORMAT ('0BLOCK NUMBER OF FIRST MESSAGE IN QUEUE ...',
	1		'.............. ',I6)
		WRITE (5,10720) MXBLK
10720		FORMAT (' BLOCK NUMBER OF LAST BLOCK OF LAST MESSAGE IN ',
	1		'QUEUE .... ',I6)
		WRITE (5,10730) MXRNA
10730		FORMAT (' READ BUT NOT ACK MESG FIRST BLOCK LINK ...',
	1		'.............. ',I6)
		WRITE (5,10740) MXBNA
10740		FORMAT (' READ BUT NOT ACK MESG LAST BLOCK LINK ...',
	1		'............... ',I6)
		WRITE (5,10750) MXMAX
10750		FORMAT (' MAX MESSAGES ALLOWED IN QUEUE ............',
	1		'.............. ',I6)
		WRITE (5,10760) MXCNT
10760		FORMAT (' CURRENT NUMBER OF MESSAGES IN QUEUE ......',
	1		'.............. ',I6)
		WRITE (5,10770) MXQSEQ
10770		FORMAT (' CURRENT ON QUEUE SEQUENCE NUMBER ..........',
	1		'............. ',I6)
		CALL R50ASC(6,MXR50,MXASC)
		WRITE (5,10780) MXASC
10780		FORMAT (' CONNECTED TASK NAME ........................',
	1		'............ ',6A1)
		WRITE (5,10790) MXTCB
10790		FORMAT (' OCTAL TCB ADDRESS OF CONNECTED TASK NAME ...',
	1		'............ ',O6)
		WRITE (5,10800) MXEFN
10800		FORMAT (' TASK EFN TO BE SET WHEN MESSAGE IN QUEUE ...',
	1		'............ ',I6)
		WRITE (5,10810) MXNVC
10810		FORMAT (' NUMBER OF TYPE 0 MESSAGES ....................',
	1		'.......... ',I6)
		WRITE (5,10820) MXNVL
10820		FORMAT (' BLOCK NUMBER OF NEXT POSSIBLE TYPE 0 MESSAGE ..',
	1		'......... ',I6)
		WRITE (5,10830) MXLST
10830		FORMAT (' LAST BLOCK NBR OF MESSAGE LINKED TO NEXT POSSIBLE .',
	1		'..... ',I6)
CCC 		TYPE *,' DIRECTIVE STATUS: ',STATB(1)
CCC 		TYPE *,' I/O STATUS: ',STATB(2)
 	ENDIF
	CALL EXIT

C
C DISPLAY QUEUE HEADER  "/DQH"
C
	ELSEIF ((SWITCH .AND. DQHMSK) .NE. 0)THEN
CC	TYPE *,' DISPLAYING THE QUEUE HEADER CURRENTLY IN USE'
	CALL ASNLUN(LUN,'ZQ',0,DSW)		! ASSIGN LUN TO ZQ DEVICE
	IF(DSWB(1) .NE. 1)THEN		! UNABLE TO ASSIGN
		TYPE *,' UNABLE TO ASSIGN A LUN TO ZQ0: '
		TYPE *,' MAKE SURE DEVICE DRIVER IS LOADED '
		TYPE *,' DIRECTIVE STATUS ERROR: ',DSWB(1)
		CALL EXIT
	ENDIF

 	STATUS=READHD(LUN,IEFN,QHDDEF,QXKSIZ,RECSIZ)
 	IF(STATUS .NE. "401 )THEN
 		TYPE *,' BAD QUEUE  STATUS ON QUEUE HEADER READ'
 		TYPE *,' DIRECTIVE STATUS: ',STATB(1)
 		TYPE *,' I/O STATUS: ',STATB(2)
 	ELSE
		WRITE (5,9700) RECSIZ
9700		FORMAT (' QUEUE HEADER        SIZE OF QUEUE HEADER = ',I2)
		WRITE (5,9710) QXSIZ
9710		FORMAT ('0SIZE OF QUEUE IN 512 BYTE BLOCKS .... ',I6)
CCC		WRITE (5,9720) QXUPD(1),QXUPD(2),QXUPD(3),QXUPD(4)
CCC9720		FORMAT (' LAST UPDATED TIME STAMP: ',4(O6,3X))
		WRITE (5,9730) QXIDC
9730		FORMAT (' NUMBER OF MESSAGE ID''S DEFINED ...... ',I6)
		WRITE (5,9740) QXFREE
9740		FORMAT (' NUMBER OF FREE 512 BYTE BLOCKS ...... ',I6)
		WRITE (5,9750) QXNODE
9750		FORMAT (' LOCAL NODE NAME ..................... ',6A1)
CCC 		TYPE *,' DIRECTIVE STATUS: ',STATB(1)
CCC 		TYPE *,' I/O STATUS: ',STATB(2)
	END IF
	CALL EXIT

C
C UNKNOWN FUNCTION
C
	ELSE
	TYPE *,' NO FUNCTION ENTERED OR NOT VALID'
	ENDIF	! END OF ALL VALID FUNCTION BIT
	END
	SUBROUTINE OPENID(IDFILE)
C
C THIS SUBROUTINE OPENS THE MESSAGE ID FILE
C
	INCLUDE 'IFILE.TXT/LIST'
C
	INTEGER IDFILE	! LOGICAL UNIT NUMBER FOR FILE
	INTEGER IFCS	! FCS ERROR CODE
	INTEGER IFCS2
	INTEGER INUM
	INTEGER IUNIT
C
	     OPEN(UNIT=IDFILE,
	1	TYPE='UNKNOWN',
	1	NAME=IFILE,
	1	ERR=2100,
	1	INITIALSIZE=15,
	1	RECL=5,
	1	ORGANIZATION='INDEXED',
	1	RECORDTYPE='FIXED',
	1	KEY=(1:16:CHARACTER),
	1	FORM='UNFORMATTED',
	1	ACCESS='KEYED')
	RETURN
C
C SOME KIND OF FILE OPEN ERROR
C
2100	TYPE *,' FILE OPEN ERROR ON QUEUEIDS.DAT FILE'
	CALL ERRSNS(INUM,IFCS,IFCS2,IUNIT)
	TYPE *,' FCS ERROR CODE: ',IFCS
	CALL EXIT	
	END
	SUBROUTINE TRANS(IQ,BUF,ICNT,BLKREC,CURLOC)
C
C THIS SUBROUTINE TRANSFERS DATA FROM BUF TO OUR
C BLOCK BUFFERS AND WRITES THEM TO THE DISK WHEN
C NECESSARY.  IF ICNT .LE. 0, THEN FINISH UP
C WHAT WE HAVE IN THE BLOCK BUFFERS AND WRITE
C THE LAST RECORD WICH IS (-ICNT).
C 
C ICNT= NUMBER OF BYTES TO TRANSFER
C BUF= WORD ADDRESSABLE BUFFER TO WRITE
C
	INTEGER BUF(*)		! SOURCE DATA  BUFFER
	INTEGER IQ		! QUEUE FILE LOGICAL UNIT
	INTEGER ICNT		! NUMBER OF BYTES TO TRANSFER
				! OR LAST RECORD TO WRITE
	INTEGER BLK1(256)	! BLK BUFFER ONE
C
	INTEGER BLKREC		! CURRENT BLK RECORD
	INTEGER CURLOC		! CURRENT LOCATION IN BLK
	INTEGER INUM,IFCS,IFCS2,IUNIT
C
	IF(ICNT .GT. 0)THEN
		IWRD=ICNT/2	! NUMBER OF WORDS TO MOVE
		DO 100 I=1,IWRD
		   CURLOC=CURLOC+1	! UPDATE CURRENT LOCATION COUNTER 
					! IN BLOCK
		   IF(CURLOC .GT. 256)THEN
			CURLOC=1
			WRITE(UNIT=IQ,REC=BLKREC,ERR=2000)BLK1
			BLKREC=BLKREC+1	! NEXT BLOCK
		   ENDIF
		   BLK1(CURLOC)=BUF(I)	! TRANSFER A WORD
100		CONTINUE
		RETURN
	ELSE IF (ICNT .EQ. 0) THEN
		WRITE(UNIT=IQ,REC=BLKREC,ERR=2000)BLK1 ! FLUSH LAST BLOCK
		RETURN
	ELSE
		WRITE(UNIT=IQ,REC=BLKREC,ERR=2000)BLK1 ! FLUSH LAST BLOCK
		BLKREC=-ICNT				! WRITE LAST RECORD
		WRITE(UNIT=IQ,REC=BLKREC,ERR=2000)BLK1 ! WRITE END OF FILE 
						       ! POINTER
		RETURN
	ENDIF
C
C ERROR WHILE WRITING
C
2000	TYPE *,' ERROR WHILE WRITING QUEUE FILE , BLOCK: ',BLKREC
	CALL ERRSNS(INUM,IFCS,IFCS2,IUNIT)
	TYPE *,' RMS STATUS: ',IFCS
	END
