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: 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: 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: 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: 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