	PROGRAM TSTACP
C.begin.doc ************************** begin.doc
C  
C .c ;Module name: 
C .c ;^&TSTACP\&
C .nf
C .x TSTACP>Defined
C Source:TSTACP.FTN
C Designer           :DAVE LUECK
C Author             :DAVE LUECK
C Date of last update:06-JAN-87
C Revision level     :1.3
C 	
C .C ;Formal Parameter List
C Receives:
C     
C Returns:
C 	
C Accesses common(s):
C 	
C Accesses file(s):
C 	
C Other modules referenced:
C 	
C .X WRITEQ>Referenced
C         WRITEQ              WRITES A MESSAGE TO A MESSAGE ID QUEUE
C .X READQ>Referenced
C         READQ               READS A MESSAGE FROM A MESSAGE ID QUEUE
C .X ATCHQ>Referenced
C         ATCHQ               CONNECTS A TASK WITH A MESSAGE ID QUEUE
C .X ACKQ>Referenced
C         ACKQ                ACKNOWLEDGES MESSAGE READ
C .X RNAQ>Referenced
C         RNAQ                PLACES READ NOT ACK MESSAGE AT QUEUE START
C .X READHD>Referenced
C         READHD              READS THE MAQUEUE HEADER
C .X READID>Referenced
C         READID              READS THE HEADER OF A MESSAGE ID QUEUE
C .X INITQ>Referenced
c         INITQ               HANG SPECIAL I/O TO THE QUEUE
C .X DISCQ>Referenced
c         DISCQ               REMOVE SPECIAL I/O TO THE QUEUE
C .X DELQ>Referenced
c         DELQ                DELETE MESSAGES FROM QUEUE
C .SK
C .fill
C .SK
C Description:
C .sk    
C 	This program tests all of the functions of the QUEACP.  The user is 
C asked to enter the ACP function to be tested and all of the input needed to 
C test the function.  If the function is not successful, an error code is 
C returned.  The meaning of the error codes are defined in the documentation
C of the ACP access routines listed above and in QUEACP and ZQDRV.
C 
C end.doc ****************************** end.doc  
C

	INCLUDE 'MIDDEF.TXT'
	INCLUDE 'QHDDEF.TXT'
	INCLUDE 'HDRDEF.TXT'


	INTEGER*2	CHOICE		! FUNCTION CODE ENTERED BY USER
 	INTEGER*2 	LUN	     	! LUN ASSIGNED TO ZQ0:
 	INTEGER*2 	IEFN	     	! EVENT FLAG

	INTEGER*2 	DSW		! DIRECTIVE STATUS MOUNT/DISMOUNT
	BYTE 		BDSW(2)	
	EQUIVALENCE (DSW,BDSW)
	INTEGER*2 	IOSTAT(2)	! I/O STATUS MOUNT/DISMOUNT
	BYTE 		BIOS(4)
	EQUIVALENCE (IOSTAT,BIOS)

	PARAMETER	BUFSIZ = 8000
	BYTE 		BUFF(BUFSIZ)    ! OPERATOR'S INPUT OF BUFFER
	EQUIVALENCE (BUFF,HDRDEF)
	INTEGER*2 	BYTCNT     	! MESSAGE BUFFER SIZE
 	BYTE 		MSGID(16)	! MESSAGE ID
 	INTEGER*2 	ITYPE      	! TYPE OF MESSAGE
 	INTEGER*2 	STATUS     	! RETURN STATUS
 	BYTE STATB(2)
 	EQUIVALENCE(STATUS,STATB) 	! BYTE ADDRESSABLE STATUS
 	INTEGER*2 QUESUC     		! NORMAL SUCCESSFUL STATUS

	BYTE	   	ANS	   ! ANSWER TO PAD QUESTION (Y OR N)
	BYTE	   	PAD	   ! CHARACTER TO PAD MESSAGE WITH
	INTEGER*2  	NBRPAD     ! NUMBER OF BYTES IN MESSAGE BUFFER TO PAD
 	INTEGER*2 	RECSIZ     ! RETURNED ACTUAL RECORD SIZE
	INTEGER*2	RNA	   ! RNA POINTER
	INTEGER*2	TEFN	   ! TASK EVENT FLAG TO SET WHEN MSG IN QUEUE
	BYTE		MXASC(6)   ! ASCII CONNECTED TASK NAME
	INTEGER*2 	WRITEQ     ! WRITE FUNCTION VALUE
	INTEGER*2	READQ	   ! READ FUNCTION VALUE
	INTEGER*2	ATCHQ	   ! CONNECT FUNCTION VALUE
	INTEGER*2	ACKQ	   ! ACK FUNCTION VALUE
	INTEGER*2	RNAQ	   ! RNA FUNCTION VALUE
	INTEGER*2	READHD	   ! READ QUEUE HEADER FUNCTION VALUE
	INTEGER*2	READID	   ! READ MSG ID FUNCTION VALUE
	INTEGER*2 	INITQ		! SETS UP EXIT HANDLING	
	INTEGER*2	DISCQ		! DISCONNECT FROM QUEUE
	INTEGER*2	DELQ		! DELETE MESSAGES FROM QUEU FUNC VALUE
C
 	DATA LUN/1/	     ! ZQ0: LOGICAL UNIT NUMBER
 	DATA IEFN/1/	     ! EVENT FLAG FOR I/O SYNC
 	DATA QUESUC/"401/	     
	DATA TEFN/2/	     ! TASK EVENT FLAG
C


	STATUS=INITQ(LUN)
	TYPE *,' INIT Q STATUS: ',STATUS
50	CONTINUE

C	PRINT TABLE OF VALID FUNCTION CODES
	
	TYPE *, ' '
	TYPE *, ' '
	TYPE *,' 	1. MOUNT DRIVER/ACP '
	type *,' 	2. DISMOUNT DRIVER/ACP '
	TYPE *,' 	3. WRITE VIRTUAL BLOCK '
	TYPE *,' 	4. READ VIRTUAL BLOCK '
	TYPE *,' 	5. CONNECT TO MESSAGE ID QUEUE '
	TYPE *,' 	6. ACKNOWLEDGE READ '
	TYPE *,' 	7. PLACE READ NOT ACK MESSAGE BACK AT QUEUE START '
	TYPE *,' 	8. READ THE QUEUE HEADER '
	TYPE *,' 	9. READ THE MESSAGE ID HEADER '
	TYPE *,'        10. DELETE MESSAGES FROM QUEUE '
	TYPE *,' 	99. EXIT '
	TYPE *, ' '	

C ASK THE USER FOR HIS INPUT.

100	TYPE *, ' '
	TYPE 500
500	FORMAT('$ENTER DESIRED FUNCTION CODE (ENTER 98 TO PRINT CODE ',
	1      ' TABLE): ')
	READ (5,1000,END=90000,ERR=100 ) CHOICE
1000	FORMAT(I2)

	IF (CHOICE.EQ.98) GOTO 50
	IF (CHOICE.EQ. 0) GOTO 50
	IF (CHOICE.EQ.99) GOTO 90000

	IF (CHOICE.LT.1 .OR. CHOICE.GT.10) THEN
		TYPE *,' INVALID FUNCTION CODE'
		GOTO 100
	END IF

C VALID OPTION, SO NOW GO TO THE CORRECT ROUTINE AND PROCESS.

	GOTO (2000, 3000, 4000, 5000, 6000, 7000, 8000,
	1     9000, 10000, 11000) CHOICE



C	MOUNT FUNCTION

2000	CONTINUE

	CALL WTQIO("14001,LUN,IEFN,,IOSTAT,,DSW)  	! IO.APC + 1

	TYPE *,' IOSTATUS: ',BIOS(1)
	TYPE *,' DIRECTIVE STATUS: ',BDSW(1)

	GOTO 100


C	DISMOUNT FUNCTION

3000	CONTINUE

	CALL WTQIO("14002,LUN,IEFN,,IOSTAT,,DSW)  	! IO.APC + 2

	TYPE *,' IOSTATUS: ',BIOS(1)
	TYPE *,' DIRECTIVE STATUS: ',BDSW(1)

	GOTO 100


C	WRITE FUNCTION

4000	CONTINUE

C Ask for message id from operator.
	CALL ENTMID(MSGID)

C Ask for message type (0, 1, or 2)
4200	type 4210
4210	format(' Enter the message type (0, 1, or 2): '$)
	read (5,4220) itype
4220	format(i1)
	IF (ITYPE.LT.0 .OR. ITYPE.GT.2) GOTO 4200

C Ask for message from operator.
	NBRPAD = 0
	type 4300
4300	format(' Enter a message: '$)
	read(5,4310) ict, (buff(i), i = 1, ict)
4310	format(Q,<ICT>A1)
	TYPE 4320
4320	FORMAT(' Do you want to pad message <Y/N> ? '$)
	read(5,4330) ans
4330	format(a1)
	if (ans.eq.'y' .or. ans.eq.'Y') then
		type 4340 
4340		format(' Enter pad character: '$)
		read (5,4330) pad
		type 4350
4350		format(' Enter number of times to pad: '$)
		read (5,4360) nbrpad
4360		format(i4)
		do 4370 i=ict+1,nbrpad+ICT
		     buff(i) = pad
4370		continue
	end if

	BYTCNT = ICT + NBRPAD

  	STATUS=WRITEQ(LUN,IEFN,MSGID,BUFF,BYTCNT,ITYPE)
 	IF(STATUS .NE. QUESUC)THEN
 		TYPE *,' BAD QUEUE  STATUS ON WRITE'
 		TYPE *,' DIRECTIVE STATUS: ',STATB(1)
 		TYPE *,' I/O STATUS: ',STATB(2)
 	ELSE
		TYPE *,' SUCCESSFUL WRITE'
 		TYPE *,' DIRECTIVE STATUS: ',STATB(1)
 		TYPE *,' I/O STATUS: ',STATB(2)
 	ENDIF

	GOTO 100


C	READ FUNCTION

5000	CONTINUE

C Ask for message id from operator.
	CALL ENTMID(MSGID)		

  	STATUS=READQ(LUN,IEFN,MSGID,BUFF,BUFSIZ,RECSIZ,RNA)
 	IF(STATUS .NE. QUESUC)THEN
 		TYPE *,' BAD QUEUE  STATUS ON READ'
 		TYPE *,' DIRECTIVE STATUS: ',STATB(1)
 		TYPE *,' I/O STATUS: ',STATB(2)
 	ELSE
		TYPE *,' RNA POINTER:  ',RNA
		TYPE *,' NUMBER OF BYTES READ:  ',RECSIZ
		WRITE (5,5100) HXSNM
5100		FORMAT ('0SOURCE NODE NAME: ',6A1)
		WRITE (5,5200) HXDNM
5200		FORMAT (' DESTINATION NODE NAME: ',6A1)
		WRITE (5,5300) HXOFQT(1),HXOFQT(2),HXOFQT(3),HXOFQT(4)
5300		FORMAT (' OFF QUEUE TIME: ',4(O6,3X))
		WRITE (5,5400) HXTYPE
5400		FORMAT (' MESSAGE TYPE: ',I1)
		WRITE (5,5500) HXONQT(1),HXONQT(2),HXONQT(3),HXONQT(4)
5500		FORMAT (' ON QUEUE TIME: ',4(O6,3X))
		WRITE (5,5600) HXLEN
5600		FORMAT (' BYTE COUNT OF MESSAGE (NOT INCLUDING HEADER): ',I4)
		WRITE (5,5700) HXQSEQ
5700		FORMAT (' ON QUEUE SEQUENCE NUMBER: ',I4)
		WRITE (5,5800) (BUFF(I),I=35,RECSIZ)
5800		FORMAT (4X,75A1)
 		TYPE *,' DIRECTIVE STATUS: ',STATB(1)
 		TYPE *,' I/O STATUS: ',STATB(2)
 	ENDIF

	GOTO 100


C	CONNECT FUNCTION

6000	CONTINUE

C Ask for message id from operator.
	CALL ENTMID(MSGID)		

  	STATUS=ATCHQ(LUN,IEFN,MSGID,TEFN)
 	IF(STATUS .NE. QUESUC)THEN
 		TYPE *,' BAD QUEUE  STATUS ON CONNECT'
 		TYPE *,' DIRECTIVE STATUS: ',STATB(1)
 		TYPE *,' I/O STATUS: ',STATB(2)
 	ELSE
		TYPE *,' CONNECT SUCCESSFUL'
 		TYPE *,' DIRECTIVE STATUS: ',STATB(1)
 		TYPE *,' I/O STATUS: ',STATB(2)
 	ENDIF

	GOTO 100


C	ACKNOWLEDGE FUNCTION

7000	CONTINUE

C Ask for message id from operator.
	CALL ENTMID(MSGID)		

C Ask for RNA pointer 
	TYPE 7100
7100	format ('$Enter the RNA pointer: ')
	read (5,7200) RNA
7200	FORMAT (I5)

  	STATUS=ACKQ(LUN,IEFN,MSGID,RNA)
 	IF(STATUS .NE. QUESUC)THEN
 		TYPE *,' BAD QUEUE  STATUS ON ACKNOWLEDGE'
 		TYPE *,' DIRECTIVE STATUS: ',STATB(1)
 		TYPE *,' I/O STATUS: ',STATB(2)
 	ELSE
		TYPE *,' ACKNOWLEDGE SUCCESSFUL'
 		TYPE *,' DIRECTIVE STATUS: ',STATB(1)
 		TYPE *,' I/O STATUS: ',STATB(2)
 	ENDIF

	GOTO 100


C	RNA FUNCTION

8000	CONTINUE

C Ask for message id from operator.
	CALL ENTMID(MSGID)		

  	STATUS=RNAQ(LUN,IEFN,MSGID)
 	IF(STATUS .NE. QUESUC)THEN
 		TYPE *,' BAD QUEUE  STATUS ON BACKUP RNA'
 		TYPE *,' DIRECTIVE STATUS: ',STATB(1)
 		TYPE *,' I/O STATUS: ',STATB(2)
 	ELSE
		TYPE *,' BACKUP RNA SUCCESSFUL'
 		TYPE *,' DIRECTIVE STATUS: ',STATB(1)
 		TYPE *,' I/O STATUS: ',STATB(2)
 	ENDIF

	GOTO 100


C	READ QUEUE HEADER FUNCTION

9000	CONTINUE

 	STATUS=READHD(LUN,IEFN,QHDDEF,QXKSIZ,RECSIZ)
C
 	IF(STATUS .NE. QUESUC)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 ('0SIZE OF QUEUE HEADER = ',I2)
		WRITE (5,9710) QXSIZ
9710		FORMAT ('0SIZE OF QUEUE IN 512 BYTE BLOCKS: ',I5)
		WRITE (5,9720) QXUPD(1),QXUPD(2),QXUPD(3),QXUPD(4)
9720		FORMAT (' LAST UPDATED TIME STAMP: ',4(O6,3X))
		WRITE (5,9730) QXIDC
9730		FORMAT (' NUMBER OF MESSAGE ID''S DEFINED: ',I3)
		WRITE (5,9740) QXFREE
9740		FORMAT (' NUMBER OF FREE 512 BYTE BLOCKS: ',I5)
		WRITE (5,9750) QXNODE
9750		FORMAT (' LOCAL NODE NAME: ',6A1)
 		TYPE *,' DIRECTIVE STATUS: ',STATB(1)
 		TYPE *,' I/O STATUS: ',STATB(2)
	END IF

	GOTO 100


C	READ A MESSAGE ID HEADER FUNCTION

10000	CONTINUE

C Ask for message id from operator.
	CALL ENTMID(MSGID)		

C
C  READ THE MESSAGE ID LIST HEAD
C
 	STATUS=READID(LUN,IEFN,MSGID,MIDDEF,MXLEN,RECSIZ)
C
 	IF(STATUS .NE. QUESUC)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 ('0MESSAGE ID ',16A1,' SIZE OF LIST HEAD = ',I2)
		WRITE (5,10710) MXFLK
10710		FORMAT ('0BLOCK NUMBER OF FIRST MESSAGE IN QUEUE: ',I5)
		WRITE (5,10720) MXBLK
10720		FORMAT (' BLOCK NUMBER OF LAST BLOCK OF LAST MESSAGE IN ',
	1		'QUEUE: ',I5)
		WRITE (5,10730) MXRNA
10730		FORMAT (' READ BUT NOT ACK MESG FIRST BLOCK LINK: ',I5)
		WRITE (5,10740) MXBNA
10740		FORMAT (' READ BUT NOT ACK MESG LAST BLOCK LINK: ',I5)
		WRITE (5,10750) MXMAX
10750		FORMAT (' MAX MESSAGES ALLOWED IN QUEUE: ',I4)
		WRITE (5,10760) MXCNT
10760		FORMAT (' CURRENT NUMBER OF MESSAGES IN QUEUE: ',I4)
		WRITE (5,10770) MXQSEQ
10770		FORMAT (' CURRENT ON QUEUE SEQUENCE NUMBER: ',I4)
		CALL R50ASC(6,MXR50,MXASC)
		WRITE (5,10780) MXASC
10780		FORMAT (' CONNECTED TASK NAME: ',6A1)
		WRITE (5,10790) MXTCB
10790		FORMAT (' OCTAL TCB ADDRESS OF CONNECTED TASK NAME: ',O6)
		WRITE (5,10800) MXEFN
10800		FORMAT (' TASK EFN TO BE SET WHEN MESSAGE IN QUEUE: ',I2)
		WRITE (5,10810) MXNVC
10810		FORMAT (' NUMBER OF TYPE 0 MESSAGES: ',I4)
		WRITE (5,10820) MXNVL
10820		FORMAT (' BLOCK NUMBER OF NEXT POSSIBLE TYPE 0 MESSAGE: ',I5)
		WRITE (5,10830) MXLST
10830		FORMAT (' LAST BLOCK NBR OF MESSAGE LINKED TO LAST SCANNED:  ',
	1		I5)
 		TYPE *,' DIRECTIVE STATUS: ',STATB(1)
 		TYPE *,' I/O STATUS: ',STATB(2)
 	ENDIF

	GOTO 100


C	DELETE MESSAGES FROM MESSAGE ID QUEUE

11000	CONTINUE

C Ask for message id from operator.
	CALL ENTMID(MSGID)		
C
C Ask for number of messages to delete
	TYPE 11100
11100	format ('$Enter the number of messages to delete: ')
	read (5,11200) nbrdel
11200	FORMAT (I5)

  	STATUS=DELQ(LUN,IEFN,MSGID,NBRDEL)
 	IF(STATUS .NE. QUESUC)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

	GOTO 100


90000	STATUS=DISCQ(LUN)	! DO I/O KILL ON THE LAST OUTSTANDING I/O
	STOP
	END


	SUBROUTINE ENTMID(MSGID)

	BYTE	MSGID(16)	! MESSAGE ID NAME ENTERED BY USER

	type 100
100	format(' Enter message id (max 16 char): '$)
	read(5, 110)IL,(msgid(I),I=1,IL)
110	format(Q,<IL>A1)
	DO 120 I=IL+1,16
		MSGID(I) = ' '
120	CONTINUE

	RETURN
	END
