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,A1) TYPE 4320 4320 FORMAT(' Do you want to pad message ? '$) 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,A1) DO 120 I=IL+1,16 MSGID(I) = ' ' 120 CONTINUE RETURN END