PRGM SSLABEL; # TITLE SSLABEL - INITIALIZES *SSLABEL*. # BEGIN # SSLABEL # # *** SSLABEL - INITIALIZES *SSLABEL*. * * THIS PROCEDURE INITIALIZES *SSLABEL* BY * CRACKING THE CONTROL CARD AND SETTING * UP POINTERS AND DEFAULT VALUES. * * SSLABEL,I,L. * * PRGM SSLABEL. * * ENTRY. INPUTS TO SSLABEL ARE- * I SOURCE OF DIRECTIVES IS ON FILE * *INPUT*. * I = LFN SOURCE OF DIRECTIVES IS ON FILE * *LFN*. * I OMITTED SAME AS *I*. * *INPUT*. * L LISTABLE OUTPUT ON FILE *OUTPUT*. * L = LFN LISTABLE OUTPUT ON FILE *LFN*. * L = 0 NO OUTPUT FILE GENERATED. * L OMITTED SAME AS *L*. * * Z SOURCE OF DIRECTIVES IS ON THE * CONTROL CARD. * * *SSLABEL* DIRECTIVE OPTIONS ARE- * OP NOT PERMITTED. * OP = XX WHERE XX IS THE DIRECTIVE TO BE PROCESSED. * XX MAY BE ANY ONE OF THE FOLLOWING. * *AM*--ADD A CARTRIDGE (*ADDMSC*). * *RM*--REMOVE A CARTRIDGE (*RMVMSC*). * *RS*--RESTORE A CARTRIDGE (*RSTRMSC*). * *FX*--REPAIR A LABEL (*FIXVSN*). * *IB*--SET OR CLEAR *FCT INHIBIT FLAG* * (*FLAGMSC*). * *FC*--SET OR CLEAR *FREE CARTRIDGE FLAG* * (*FLAGFC*) IN FCT. * *AS*--ADD A *SM* TO A SUBFAMILY * (*ADDCSU*). * *RS*--REMOVE A SM FROM A SUBFAMILY * (*RMVCSU*). * *AB*--ADD A CUBE TO A SUBFAMILY * (*ADDCUBE*). * *RB*--REMOVE AN EMPTY CUBE FROM A SUBFAMILY * (*RMVCUBE*). * OP OMITTED NOT PERMITTED. * * N NUMBER OF CARTRIDGES OR CUBES = 1. * N = X NUMBER OF CARTRIDGES OR CUBES = X. * X MAY RANGE FROM 1 TO 100. * N OMITTED SAME AS *N*. * *NOTE* - *N* MUST BE 1 IF THE *CSN* * OPTION IS SPECIFIED. * * B SAME AS *B* = 600. * B = N NUMBER OF AU'S (N) USED FOR SMALL FILES. * 1931 - N AU'S REMAIN FOR LARGE FILES. * B OMITTED SAME AS *B*. * * CM CARTRIDGE MANUFACTURER CODE IS *A* INDICATI * *IBM*. * CM = A CARTRIDGE MANUFACTURER CODE IS *A* INDICATI * *IBM*. * CM = ANYTHING ELSE IS CURRENTLY ILLEGAL. * CM OMMITTED CARTRIDGE MANUFACTURER CODE IS *A*. * * CN CARTRIDGE SERIAL NUMBER OF CARTRIDGE IS * NOT SPECIFIED. * CN = CSN SERIAL NUMBER OF CARTRIDGE IS * *CSN*. * C OMITTED SAME AS *C*. * *NOTE* - *CSN* MUST BE SPECIFIED WITH * *RMVMSC LOST(LS)* OPTION. * *CSN* MAY NOT BE SPECIFIED WHEN ANY *PK* * OPTION IS USED. * *NOTE* - PK IS SET TO 0 * WHENEVER CSN IS SPECIFIED. * *N* MUST BE 1 IF THE *C* = CSN * OPTION IS SPECIFIED. * *CSN* MAY NOT BE SPECIFIED WITH * *OP* = *ADDCSU* (AC) * *OP* = *RMVCSU* (RC) * *OP* = *ADDCUBE* (AB) * *OP* = *RMVCUBE* (RB) * * * GR CHOOSE DEFAULT GROUP. * GR = N GROUP TO WHICH CARTRIDGE IS ADDED/REMOVED. * INVALID IF *PT* = P IS SPECIFIED WITH * *OP* = *AM*. N MUST BE O TO 127. * GR OMITTED SAME AS *GR*. * * PK SAME AS *PK* = P. * PK = D CARTRIDGE IS TO BE PICKED FROM INPUT * DRAWER SLOT. * PK = P CARTRIDGE OR CUBE IS PICKED FROM POOL. * PK = F CARTRIDGE OR CUBE IS PICKED FROM THE * SPECIFIED FAMILY (SEE *FM* OPTION) AND * SUBFAMILY (SEE *SB* OPTION) AND GROUP * (SEE *GR* OPTION). * PK OMITTED SAME AS *PK*. * *NOTE* - VALID USES OF *PK* * OP=AM - PK=D OR PK=P * OP=RM - PK=P OR PK=F * OP=RB - PK=P OR PK=F OR PK=R * NONE OF THE *PK* OPTION MAY BE * USED IF *C* = CSN OPTION IS * SPECIFIED. * PK=D OR F IF PT=P. * * PT SAME AS *PT* = P. * PT = D CARTRIDGE IS TO BE PLACED IN THE * DRAWER. * PT = P CARTRIDGE OR CUBE IS PUT IN THE POOL. * PT = F CARTRIDGE OR CUBE IS PUT IN THE SPECIFIED * FAMILY (SEE *FM* OPTION) AND SUBFAMILY * (SEE *SB* OPTION). * PT = R CUBE IS PUT INTO THE *RESERVED FOR * ALTERNATE SMMAP* AREA OF THE SMMAP. * PT OMITTED SAME AS *PT*. * *NOTE* - VALID USES OF *PT* * OP=AM - PT=P OR PT=F * HOWEVER, WITH OP=AM AND THE CSN * SPECIFIED, *PT* CANNOT BE EQUAL * TO *P*. * OP=RM - PT=D OR PT=P * OP=AB - PT=P OR PT=F OR PT=R * * LT CARTRIDGE IS LOST AND EXISTS ONLY IN THE * CATALOG. ITS CATALOG ENTRY IS TO BE * REMOVED. * LT OMITTED NO ACTION. * *NOTE* - *LT* IS VALID ONLY WITH OP=RM * (*RMVMSC*). * * SM USE *SM* *A*. * SM = N USE *SM* N WHERE N IS ONE OF THE * FOLLOWING * A - SM A * B - SM B * C - SM C * D - SM D * E - SM E * F - SM F * G - SM G * H - SM H * SM OMITTED SAME AS *SM*. * * ON TURN ON A FLAG. * * OF TURN OFF A FLAG. * * YI INVALID. * YF INVALID. * ZI INVALID. * ZF INVALID. * YI = I ROW I IS SELECTED FOR THE *ADDCUBE* * OR *RMVCUBE* DIRECTIVE. I IS FROM 0 TO 21. * ZI = J COLUMNN J IS SELECTED FOR THE *ADDCUBE* OR * *RMVCUBE* DIRECTIVE. J IS FROM 0 TO 15. * YI=I,ZI=J LOCATION (I,J) IS SELECTED FOR THE * *ADDCUBE* OR *RMVCUBE* DIRECTIVE. * YI=I,ZI=J, A RECTANGLE OF CELLS BOUNDED BY (I,J), * YF=K,ZF=L (I,L), (K,J) AND (K,L) ARE SELECTED FOR * THE *ADDCUBE* OR *RMVCUBE* DIRECTIVE. * *NOTE* - YF=K AND ZF=L MUST BOTH BE * SPECIFIED IF EITHER IS SPECIFIED. * YF=K AND ZF=L CANNOT BE SPECIFIED UNLESS * BOTH YI=I AND ZI=J ARE SPECIFIED. * K MUST BE GREATER THAN I AND L MUST BE * GREATER THAN J. * YI=I AND YF=K MUST BE LESS THAN OR EQUAL * TO 21. * ZI=J AND ZF=L MUST BE LESS THAN OR EQUAL * TO 15. * THE FOLLOWING LOCATIONS ARE RESERVED: * (0,0),((Y,6),Y=0,21),(0,15),(11,15), * (21,15),((Y,Z),Y=11,15,Z=0,1),(0,1), * (0,14),(21,0),AND (21,14). * YI AND ZI *ADDCUBE* WILL SELECT THE NEXT AVAILABLE * OMITTED CUBE CLOSEST TO THE TOP OF THE *SM* FOR * ASSIGNMENTS TO A FAMILY OR THE FARTHEST * CUBE FOR ASSIGNMENT TO THE POOL. * *RMVCUBE* WILL SELECT THE FIRST UNASSIG- * NED CUBE FROM THE *AST* FOR A FAMILY. * * FM USE DEFAULT FAMILY. * FM = FAMILY SELECT SPECIFIED FAMILY. * FM OMITTED SAME AS *FM*. * * SB SELECT SUB-FAMILY 0. * SB = SUB SELECT SUB-FAMILY SUB. * SB OMITTED SAME AS *SB*. * *NOTE* - SUB MUST BE BETWEEN 0 AND 7. * * EXIT. *SSLABEL* DIRECTIVES PROCESSED OR * AN ERROR CONDITION ENCOUNTERED. * * MESSAGES. 1. SSLABEL COMPLETE. * 2. UNABLE TO CONNECT WITH EXEC. * 3. SSLABEL - MUST BE SYSTEM ORIGIN. * * NOTES. PROC *SSLABEL* INITIALIZES *SSLABEL*. * *SSLABEL* PROCESSING IS CONTROLLED BY * THE USE OF DIRECTIVES. THE DIRECTIVES CAN * BE SPECIFIED ON THE CONTROL CARD, ON * *INPUT* FILE OR ON * AN ALTERNATE FILE. PROC *SSLABEL* * CRACKS THE CONTROL CARD AND READS * IN THE DIRECTIVES FROM THE FILE * SPECIFIED INTO THE CIO BUFFER. PROC * *LBLOOP* IS CALLED TO CRACK THE DIREC- * TIVES AND TO WRITE THEM ON A TEMPORARY * FILE. THE CRACKED PARAMETERS ARE RETUR- * NED IN COMMON AREA *ULBPCOM*. ANY ERROR * IN THE DIRECTIVE CAUSES *SSLABEL* TO * ABORT. PROC *LBERR* DOES ERROR PROCESSING * FOR *SSLABEL*. AFTER THE DIRECTIVES ARE * CRACKED AND SYNTAX CHECKED A *CONNECT* IS * SET WITH EXEC. PROC *LBMAIN* IS CALLED * TO PROCESS ALL THE DIRECTIVES. A * *DISCONNECT* IS DONE WITH EXEC AFTER ALL * THE DIRECTIVES ARE PROCESSED. # # **** PROC SSLABEL - XREF LIST BEGIN. # XREF BEGIN PROC ABORT; # ABORT PROCESSING # PROC BZFILL; # BLANK OR ZERO-FILLS A BUFFER # PROC CALL1; # SENDS TYPE 1 CALLSS TO EXEC # PROC GETFAM; # GETS DEFAULT FAMILY # PROC GETPFP; # GET USER INDEX AND FAMILY # PROC GETSPS; # GET PRIVILIDGES # PROC LBERR; # ERROR PROCESSOR # PROC LBHEAD; # WRITES HEADER ON OUTPUT FILE # PROC LBLOOP; # CRACK AND SYNTAX CHECK DIRECTIVES # PROC LBMAIN; # PROCESSES SSLABEL DIRECTIVES # PROC LBTAB; # SETS UP THE ARGUMENT LIST # PROC MESSAGE; # DISPLAYS MESSAGE IN DAYFILE # PROC PDATE; # GETS PACKED DATE AND TIME # PROC READ; # READS A FILE # PROC RESTPFP; # RESTORE USER-S *PFP* AND ABORT OR RETURN # PROC RPCLOSE; # CLOSES OUTPUT FILE # PROC RPLINE; # WRITES A LINE ON OUTPUT FILE # PROC RPOPEN; # OPENS OUTPUT FILE # PROC RPSPACE; # WRITES A BLANK LINE # PROC VERSION; # GETS OS LEVEL # PROC XARG; # CRACK PARAMETER LIST # PROC XZAP; # *Z* ARGUMENT PROCESSOR # PROC ZSETFET; # SETS UP A FET # END # **** PROC SSLABEL - XREF LIST END. # DEF LISTCON #0#; # DO NOT LIST COMDECKS # CONTROL PRESET; *CALL COMBFAS *CALL COMBBZF *CALL COMBCMD *CALL COMBCPR *CALL COMBLBL *CALL COMBPFP *CALL COMBUCR *CALL COMSPFM *CALL COMTERR *CALL COMTFMT *CALL COMTLAB *CALL COMTLBP *CALL COMTOUT ITEM ARGLIST U; # ADDRESS OF ARGUMENT TABLE # ITEM BUFP U; # FWA OF CIO BUFFER # ITEM DEFAULT I; # DEFAULT FAMILY ORDINAL # ITEM ERRFLAG B; # ERROR FLAG # ITEM FAM$NUM I; # NUMBER OF FAMILIES # ITEM FETP U; # FWA OF FET # ITEM FLAG I; # ERROR FLAG # ITEM LFN C(7); # TEMP LOC FOR FILE NAME # ITEM LINK I; # LINK FAMILY ORDINAL # ITEM OPTION I; # OPTION OF SKIPPING OVER PROGRAM NAME IN CONTROL CARD # ITEM REQCODE U; # REQUEST CODE # ITEM RESP$CODE U; # RESPONSE CODE FROM EXEC # ARRAY CALL$SS [0:0] P(CPRLEN);; # CALLSS REQUEST BLOCK # ARRAY OUT$FET [0:0] S(SFETL);; # FET FOR OUTPUT FILE # BASED ARRAY RA [0:0] P(1);; # ACCESS CONTROL CARD AREA # ARRAY SPSSTAT [0:0] S(1); BEGIN ITEM SPS$STATUS U(00,48,12); # RETURN STATUS # END CONTROL EJECT; # * USER MUST HAVE SYSTEM ORIGIN PRIVILIDGES. # GETSPS(SPSSTAT); IF SPS$STATUS NQ OK THEN BEGIN LBMSG$LINE[0] = " SSLABEL - MUST BE SYSTEM ORIGIN."; MESSAGE(LBMSG$BUF[0],SYSUDF1); ABORT; END REQID$LB = REQNAME"RQILABL"; # SET REQUESTOR ID FOR SSLABEL # # * SAVE THE USER-S CURRENT FAMILY AND USER INDEX IN COMMON. # GETPFP(PFP[0]); USER$FAM[0] = PFP$FAM[0]; USER$UI[0] = PFP$UI[0]; # * CRACK THE PARAMETERS ON SSLABEL CALL. # LBTAB(ARGLIST); # SET UP THE ARGUMENT LIST # OPTION = 0; # SKIP OVER PROGRAM NAME # XARG(ARGLIST,OPTION,FLAG); # CRACK THE CONTROL STATEMENT # IF FLAG NQ 0 THEN # SYNTAX ERROR # BEGIN ERRCODE = S"SYNTX$ABRT"; # ABORT WITH *SYNTAX ERROR* # OUT$FETP = 0; LBERR(ERRCODE); END # * SET UP FET FOR READING THE DIRECTIVE FILE. # FETP = LOC(LBIN$FET[0]); LB$BUFP = LOC(LBIN$BUF[0]); LFN = LBARG$I[0]; ZSETFET(FETP,LFN,LB$BUFP,BUFL,SFETL); # * DO *Z* ARGUMENT PROCESSING. # IF LBARG$Z[0] NQ 0 THEN # *Z* OPTION SPECIFIED # BEGIN XZAP(LBIN$FET[0]); # PROCESS *Z* ARGUMENTS # END ELSE BEGIN READ(LBIN$FET[0],NRCL); # READ INPUT FILE # END # * SET UP FET POINTER FOR OUTPUT FILE. # IF LBARG$L[0] EQ 0 THEN # NO OUTPUT FILE # BEGIN OUT$FETP = 0; END ELSE # SET UP THE FWA OF THE FET # BEGIN OUT$FETP = LOC(OUT$FET[0]); END # * OPEN OUTPUT FILE AND WRITE THE CONTROL CARD * IMAGE TO IT. # RPOPEN(LBARG$L[0],OUT$FETP,LBHEAD); P = 0; # SET TO RA+0 # BZFILL(RA[O"70"],TYPFILL"BFILL",80); RPLINE(OUT$FETP,RA[O"70"],2,80,0); RPSPACE(OUT$FETP,SP"SPACE",1); # * READ EACH DIRECTIVE AND CRACK AND SYNTAX CHECK IT. # ERRFLAG = FALSE; # INITIALIZE ERROR STATUS # LBLOOP(ARGLIST,ERRFLAG); IF ERRFLAG THEN # ERROR IN ANY DIRECTIVE # BEGIN ERRCODE = S"SYNTX$ABRT"; # ABORT WITH DAYFILE MESSAGE # LBERR(ERRCODE); END PDATE(PD$T); # GET PACKED DATE/TIME # VERSION(OSVERSION[0]); # GET *OS* LEVEL # # * GET DEFAULT FAMILY AND SUBSYSTEM ID. # SSID$LB = ATAS; GETFAM(FAMT,FAM$NUM,LINK,DEFAULT,SSID$LB); DEF$FAM = FAM$NAME[DEFAULT]; # * INITIALIZE THE POINTER OF THE BASED ARRAY * DESCRIBING THE FORMAT OF THE CALLSS REQUEST * BLOCK. # P = LOC(CALL$SS[0]); # * SET UP CONNECT WITH EXEC. # REQCODE = REQTYP1"CONNECT"; CALL1(REQCODE,RESP$CODE); IF RESP$CODE NQ OK THEN BEGIN LBMSG$LINE[0] = " UNABLE TO CONNECT WITH EXEC."; MESSAGE(LBMSG$BUF[0],SYSUDF1); RPCLOSE(OUT$FETP); # CLOSE OUTPUT FILE # RESTPFP(PFP$ABORT); # RESTORE USER-S *PFP* AND ABORT # END # * PROCESS EACH DIRECTIVE. # LBMAIN; # * DISCONNECT WITH EXEC. # REQCODE = REQTYP1"DISCONNECT"; CALL1(REQCODE,RESP$CODE); RPCLOSE(OUT$FETP); # CLOSE OUTPUT FILE # # * DISPLAY *SSLABEL COMPLETE* IN THE DAYFILE. # LBMSG$LINE[0] = " SSLABEL COMPLETE."; MESSAGE(LBMSG$BUF[0],SYSUDF1); RESTPFP(PFP$END); # RESTORE USER-S *PFP* # END # SSLABEL # TERM PROC CALL1((REQ$CODE),RESP$CODE); # TITLE CALL1 - SETS UP AND ISSUES A CALLSS TYPE 1 REQUEST. # BEGIN # CALL1 # # ** CALL1 - SETS UP AND ISSUES A CALLSS TYPE 1 REQUEST. * * THIS PROC SETS UP THE CALLSS REQUEST BLOCK FOR A * UCP REQUEST TYPE 1 AND CALLS *CALLSS* TO ISSUE IT * TO EXEC. * * PROC CALL1((REQ$CODE),RESP$CODE) * * ENTRY (REQCODE) = REQUEST CODE. * (REQID$LB) = REQUESTOR ID. * (SSID$LB) = SUBSYSTEM ID. * P = FWA OF PARAMETER BLOCK. * * EXIT (RESP$CODE) = RESPONSE FROM EXEC. * * NOTES PROC *CALL1* SETS UP THE CALLSS PARAMETER * BLOCK FOR A UCP TYPE 1 REQUEST. TYPE 1 * REQUESTS ARE THE UCP LINKAGE REQUESTS I.E * CONNECT AND DISCONNECT. THE REQUEST CODE * IS SET UP IN THE CALLSS PARAMETER BLOCK * TO IDENTIFY THE TYPE OF REQUEST BEING SENT * TO EXEC. THE RESPONSE CODE IS RETURNED * TO THE CALLING PROCEDURE. # ITEM REQ$CODE U; # REQUEST CODE # ITEM RESP$CODE U; # RESPONSE CODE FROM EXEC # # **** PROC CALL1 - XREF LIST BEGIN. # XREF BEGIN PROC CALLSS; # ISSUES A CALLSS TO EXEC # END # **** PROC CALL1 - XREF LIST END. # DEF LISTCON #0#; # DO NOT LIST COMDECKS # *CALL COMBFAS *CALL COMBCPR *CALL COMTLAB ITEM I I; # LOOP VARIABLE # CONTROL EJECT; # * ZERO FILL THE CALLSS PARAMETER REQUEST BLOCK. # SLOWFOR I = 0 STEP 1 UNTIL CPRLEN-1 DO BEGIN CPR1[I] = 0; END CPR$WC[0] = TYP1$WC; # SET UP WORD COUNT # CPR$RQT[0] = TYP"TYP1"; # TYPE 1 REQUEST # CPR$RQC[0] = REQ$CODE; # SET UP REQUEST CODE # CPR$RQI[0] = REQID$LB; # SET UP REQUESTOR ID # CPR$SSPFLG[0] = TRUE; CALLSS(SSID$LB,CPR[0],RCL); # ISSUE CALLSS # RESP$CODE = CPR$ES[0]; # RETURN THE RESPONSE CODE # RETURN; END # CALL1 # TERM PROC CALL3((REQ$CODE),PT$CSU$ENT,(CATFLD),(CATVALUE),RESP$CODE); # TITLE CALL3 - SETS UP AND ISSUES A TYPE 3 CALLSS TO EXEC. # BEGIN # CALL3 # # ** CALL3 - SETS UP AND ISSUES A TYPE 3 CALLSS TO EXEC. * * PROC CALL3((REQ$CODE),PT$CSU$ENT,(CATFLD),(CATVALUE),RESP$CODE) * * ENTRY (REQ$CODE) = REQUEST CODE. * (PT$CSU$ENT) = 3 WORD SMMAP ENTRY WITH THE THIRD * WORD CONTAINING THE Y,Z COORDINATES. * (CATFLD) = CATALOG FIELD TO BE UPDATED. * (CATVALUE) = NEW VALUE FOR THE CATALOG FIELD TO * BE UPDATED. * (REQID$LB) = REQUESTOR ID. * (NEWLABP) = FWA OF BUFFER CONTAINING NEW CARTRIDGE * LABEL. * (OLDLABP) = FWA OF BUFFER CONTAINING OLD CARTRIDGE * LABEL. * (SSID$LB) = SUBSYSTEM ID. * (LBARG$B) = LARGE FILE ALLOCATION SPACE. * (LBARG$SMID) = *SM*-ID. * (LBARG$FM) = FAMILY NAME. * (LBARG$SB) = SUBFAMILY ID. * P = FWA OF PARAMETER BLOCK. * * EXIT (RESP$CODE) = RESPONSE FROM EXEC. * * NOTES PROC *CALL3* SETS UP THE CALLSS PARAMETER BLOCK * FOR A TYPE 3 REQUEST TO EXEC. TYPE 3 REQUESTS * ARE THE REQUESTS TO MODIFY MSF CATALOGS AND MAPS. * THE SPECIFIC REQUEST ISSUED IS DEPENDENT ON THE * VALUE OF *REQCODE*. PARAMETERS NOT NEEDED FOR * THE REQUEST ARE IGNORED. IF THE RESPONSE CODE * RETURNED BY EXEC IS *RESUBMIT THE REQUEST*, THE * CALLSS IS REISSUED. OTHERWISE THE RESPONSE CODE * IS RETURNED TO THE CALLING PROC. # ITEM REQ$CODE U; # REQUEST CODE # ARRAY PT$CSU$ENT [0:0] P(5); # *PUT* SMMAP ENTRY # BEGIN ITEM PT$MAPENT C(00,00,30); # THREE WORD MAP ENTRY # ITEM PT$Y U(03,00,30); # Y COORDINATE # ITEM PT$Z U(03,30,30); # Z COORDINATE # ITEM PT$GR U(04,00,07); # GROUP # ITEM PT$GRT U(04,07,05); # GROUP ORDINAL # END ITEM CATFLD U; # CATALOG FIELD # ITEM CATVALUE U; # NEW VALUE FOR CATALOG FIELD # ITEM RESP$CODE U; # RESPONSE CODE FROM EXEC # # **** PROC CALL3 - XREF LIST BEGIN. # XREF BEGIN PROC CALLSS; # ISSUES A CALLSS TO EXEC # END # **** PROC CALL3 - XREF LIST END. # DEF LISTCON #0#; # CONTROLS LISTING OF COMDECKS # *CALL COMBFAS *CALL COMBCPR *CALL COMBLBL *CALL COMBMAP *CALL COMTLAB *CALL COMTLBP ITEM COMPLETE B; # CALLSS COMPLETION STATUS # ITEM I I; # LOOP VARIABLE # SWITCH CALL3ACT: REQTYP3 # TYPE OF CALLSS ISSUED # ADDCBFM: ADD$CUBE, # ADD CUBE TO FAMILY # ADDCRFM: ADD$CART, # ADD CARTRIDGE TO FAMILY # ADDCSFM: ADD$CSU, # ADD *SM* TO FAMILY # RMVCBFM: RMV$CUBE, # REMOVE CUBE FROM FAMILY # RMVCRFM: RMV$CART, # REMOVE CARTRIDGE FROM FAMILY # RMVCSFM: RMV$CSU, # REMOVE *SM* FROM FAMILY # UPDCAT: UPD$CAT, # UPDATE CATALOG FIELD # UPDMAP: UPD$MAP; # UPDATE SMMAP FIELD # CONTROL EJECT; # * ZERO FILL CALLSS REQUEST BLOCK AND SET UP FIELDS COMMON * TO MOST REQUESTS. # COMPLETE = FALSE; SLOWFOR I = 0 STEP 1 UNTIL CPRLEN-1 DO BEGIN CPR1[I] = 0; END # * SET UP PARAMETER BLOCK. # CPR$RQT[0] = TYP"TYP3"; CPR$RQC[0] = REQ$CODE; CPR$RQI[0] = REQID$LB; CPR$FAM[0] = LBARG$FM[0]; CPR$SUB[0] = LBARG$SB[0]; CPR$CSU[0] = LBARG$SMID[0]; CPR$WC[0] = TYP3$WC; P = LOC(PT$CSU$ENT[0]); # * SET UP ADDITIONAL REQUEST BLOCK FIELDS FOR SPECIFIC * REQUEST CODES. # GOTO CALL3ACT[REQ$CODE]; ADDCBFM: # ADD CUBE TO FAMILY # CPR$Y[0] = PT$Y[0]; # SET Y AND Z COORDINATES # CPR$Z[0] = PT$Z[0]; GOTO ISSUECALL; ADDCRFM: # ADD CARTRIDGE TO FAMILY # P = NEWLABP; CPR$FCT[0] = (PT$GR[0]) * 16 + PT$GRT[0]; CPR$Y[0] = LAB$Y[0]; # SET Y AND Z COORDINATES # CPR$Z[0] = LAB$Z[0]; CPR$CSND[0] = LAB$CSND[0]; # SET VSN FIELD # CPR$CCOD[0] = LAB$CCOD[0]; CPR$GR[0] = LBARG$GR[0]; # SET GROUP PARAMETERS # CPR$GRT[0] = PT$GRT; # CALCULATE GRTO # CPR$B[0] = LBARG$B[0]; CPR$STRD[0] = LAB$STRD[0]; CPR$STWR[0] = LAB$STWR[0]; CPR$SRDE[0] = LAB$SRDE[0]; CPR$SWRE[0] = LAB$SWRE1[0]; B<28,4>CPR$SWRE = LAB$SWRE[0]; CPR$HRDE[0] = LAB$HRDE[0]; CPR$STDM[0] = LAB$STDM[0]; CPR$CRLD[0] = LAB$CRLD[0]; CPR$LDER[0] = LAB$LDER[0]; GOTO ISSUECALL; ADDCSFM: # ADD *SM* TO FAMILY # GOTO ISSUECALL; RMVCBFM: # REMOVE CUBE FROM FAMILY # CPR$FCT[0] = CM$FCTORD[0]; # SET FCT ORDINAL # CPR$Y[0] = PT$Y[0]; # SET Y AND Z COORDINATES # CPR$Z[0] = PT$Z[0]; GOTO ISSUECALL; RMVCRFM: # REMOVE CARTRIDGE FROM FAMILY # CPR$FAM[0] = CM$FMLYNM[0]; # USE *FM* AND *SB* FROM SMMAP # CPR$SUB[0] = CM$SUB[0]; CPR$FCT[0] = CM$FCTORD[0]; # SET FCT ORDINAL # CPR$GR[0] = LBARG$GR[0]; # SET GROUP # CPR$Y[0] = PT$Y[0]; # SET Y AND Z COORDINATES # CPR$Z[0] = PT$Z[0]; GOTO ISSUECALL; RMVCSFM: # REMOVE *SM* FROM FAMILY # GOTO ISSUECALL; UPDCAT: # UPDATE CATALOG FIELD # CPR$FAM[0] = CM$FMLYNM[0]; # USE *FM* AND *SB* FROM SMMAP # CPR$SUB[0] = CM$SUB[0]; CPR$FCT[0] = CM$FCTORD[0]; # SET FCT ORDINAL # CPR$FLD[0] = CATFLD; # SET FIELD NAME # CPR$VAL[0] = CATVALUE; # SET CATALOG FIELD VALUE # GOTO ISSUECALL; UPDMAP: # UPDATE SMMAP ENTRY # CPR$Y[0] = PT$Y[0]; # SET Y AND Z COORDINATES # CPR$Z[0] = PT$Z[0]; CPR$MAPENT[0] = PT$MAPENT[0]; # SET UP NEW SMMAP ENTRY # GOTO ISSUECALL; ISSUECALL: # ISSUE REQUEST TO EXEC # REPEAT WHILE NOT COMPLETE DO BEGIN CALLSS(SSID$LB,CPR[0],RCL); IF CPR$RQR[0] NQ RESPTYP3"RESUB$REQ" THEN # REQUEST COMPLETE # BEGIN COMPLETE = TRUE; TEST DUMMY; END # * RESUBMIT THE REQUEST. # CPR$RQR[0] = 0; CPR$C[0] = FALSE; END RESP$CODE = CPR$RQR[0]; RETURN; END # CALL3 # TERM PROC CALL4((REQ$CODE),(DRD),(CART$CSN),(OLD$Y),(OLD$Z),RESP$CODE); # TITLE CALL4 - SETS UP AND ISSUES A TYPE 4 CALLSS TO EXEC. # BEGIN # CALL4 # # ** CALL4 - SETS UP AND ISSUES A TYPE4 CALLSS TO EXEC. * * PROC CALL4((REQ$CODE),(OLD$Y),(OLD$Z),(NEW$Y),(NEW$Z),RESP$CODE) * * ENTRY (REQ$CODE) = REQUEST CODE. * (OLD$Y) = PRIMARY Y COORDINATE. * (OLD$Z) = PRIMARY Z COORDINATE. * (NEW$Y) = SECONDARY Y COORDINATE. * (NEW$Z) = SECONDARY Z COORDINATE. * (REQID$LB) = REQUESTOR ID. * (SSID$LB) = SUBSYSTEM ID. * (NEWLABP) = FWA OF BUFFER CONTAINING NEW * CARTRIDGE LABEL. * (OLDLABP) = FWA OF BUFFER CONTAINING OLD * CARTRIDGE LABEL. * (ADDRSNS) = FWA OF BUFFER TO HOLD DRAWER * STATUS TABLE. * (DRD$NUM) = TRANSPORT ID. * (LBARG$SMID) = *SM*-ID. * P = FWA OF PARAMETER BLOCK. * * EXIT (RESP$CODE) = RESPONSE FROM EXEC. * * NOTES PROC *CALL4* SETS UP THE CALLSS PARAMETER BLOCK * FOR A TYPE 4 REQUEST TO EXEC. TYPE 4 ARE THE * REQUESTS THAT REQUIRE SM OR M860 ACTIONS PERFOR- * -MED. THE SPECIFIC REQUEST ISSUED IS DEPENDENT * ON THE VALUE OF *REQCODE*. PARAMETERS NOT NEEDED * FOR THE REQUEST ARE IGNORED. IF THE RESPONSE * RETURNED BY EXEC IS *RESUBMIT* THE REQUEST*, THE * CALLSS IS REISSUED. OTHERWISE THE RESPONSE CODE * IS RETURNED TO THE CALLING PROC. # ITEM CART$CSN U; # CARTRIDGE SERIAL NUMBER # ITEM DRD U; # DRIVE NUMBER # ITEM REQ$CODE U; # REQUEST CODE # ITEM OLD$Y I; # OLD Y COORDINATE # ITEM OLD$Z I; # OLD Z COORDINATE # ITEM NEW$Y I; # NEW Y COORDINATE # ITEM NEW$Z I; # NEW Z COORDINATE # ITEM RESP$CODE U; # RESPONSE CODE FROM EXEC # # **** PROC CALL4 - XREF LIST BEGIN. # XREF BEGIN PROC CALLSS; # ISSUES A CALLSS TO EXEC # END # **** PROC CALL4 - XREF LIST END. # DEF LISTCON #0#; # CONTROLS LISTING OF COMDECKS # *CALL COMBFAS *CALL COMBCPR *CALL COMTLAB *CALL COMTLBP SWITCH CALL4ACT: REQTYP4 # TYPE OF CALLSS TO BE ISSUED # GETCART: LOAD$CART, # GET CARTRIDGE # PUTCART: UNLD$CART, # PUT CARTRIDGE # WRITLAB: WRT$LAB; # WRITE LABEL # ITEM I I; # LOOP VARIABLE # CONTROL EJECT; # * ZERO-FILL CALLSS REQUEST BLOCK AND SET UP FIELDS USED BY * MOST REQUESTS. # SLOWFOR I = 0 STEP 1 UNTIL CPRLEN-1 DO BEGIN CPR1[I] = 0; END CPR$RQT[0] = TYP"TYP4"; CPR$RQC[0] = REQ$CODE; CPR$RQI[0] = REQID$LB; CPR$CSU[0] = LBARG$SMID[0]; CPR$WC[0] = TYP4$WC; CPR$Y[0] = OLD$Y; CPR$Z[0] = OLD$Z; # * SET UP ADDITIONAL REQUEST BLOCK FIELDS FOR SPECIFIC REQUEST. # GOTO CALL4ACT[REQ$CODE]; GETCART: # GET CARTRIDGE REQUEST # CPR$ADDR2[0] = OLDLABP; GOTO ISSUECALL; PUTCART: # PUT CARTRIDGE REQUEST # GOTO ISSUECALL; WRITLAB: # WRITE LABEL REQUEST # CPR$ADDR2[0] = NEWLABP; GOTO ISSUECALL; ISSUECALL: # ISSUE REQUEST TO EXEC # CALLSS(SSID$LB,CPR[0],RCL); RESP$CODE = CPR$RQR[0]; RETURN; END # CALL4 # TERM PROC CKLAB(LAB$TYPE); # TITLE CKLAB - CHECKS CARTRIDGE LABEL. # BEGIN # CKLAB # # ** CKLAB - CHECKS CARTRIDGE LABEL. * * THIS PROCEDURE CHECKS CARTRIDGE LABEL * TO SEE IF IT IS A RECOGNIZABLE LABEL. * * PROC CKLAB(LAB$TYPE) * * ENTRY OLDLABP, AN ITEM CONTAINING FWA OF BUFFER * CONTAINING OLD CARTRIDGE LABEL. * * EXIT CARTRIDGE LABEL CHECKED. * LAB$TYPE, AN ITEM CONTAINING * LABEL TYPE. * * NOTES PROC *CKLAB* CHECKS THE LABEL * TO SEE IF IT IS A MANUFACTURERS * LABEL, SCRATCH LABEL, FAMILY * LABEL OR AN UNRECOGNIZABLE LABEL. # ITEM LAB$TYPE U; # CARTRIDGE LABEL TYPE # # **** PROC CKLAB - XREF LIST BEGIN. # XREF BEGIN PROC CONVSN; # CONVERTS VSN FROM EBCDIC TO CDC DISPLAY CODE # END # **** PROC CKLAB - XREF LIST END. # DEF PROCNAME #"CKLAB."#; # PROC NAME # DEF LISTCON #0#; # DO NOT LIST COMDECKS # *CALL COMBFAS *CALL COMBLBL *CALL COMTLAB ITEM CONTYPE I; # TYPE OF CONVERSION # ITEM FLAG I; # CHECK FOR LEGAL CHARACTER # ITEM TEMP$VSN C(8); # CSN IN CDC DISPLAY CODE # CONTROL EJECT; # * CONVERT THE TWELVE BYTES IN THE CSN IN EBCDIC TO * DISPLAY CODE AND ALSO CHECK TO SEE IF THEY ARE * LEGAL CDC CHARACTERS (A - Z EXCEPT I AND O AND * 0 - 9). # CONTYPE = 1; CONVSN(TEMP$VSN,CONTYPE,FLAG); IF FLAG NQ 0 THEN # NOT LEGAL CDC CHARACTER # BEGIN GOTO UNREC$LAB; # PROCESS THE ERROR # END P = OLDLABP; # * CHECK FOR A FAMILY LABEL. # IF (LAB$FMLY[0] NQ " ") AND (LAB$CARTTP[0] EQ 1) THEN BEGIN LAB$TYPE = LABTYPE"FAM$LAB"; RETURN; END # * CHECK FOR A SCRATCH LABEL. # IF (LAB$FMLY[0] EQ " ") AND (LAB$CARTTP[0] EQ LABTYPE"SCR$LAB") THEN BEGIN LAB$TYPE = LABTYPE"SCR$LAB"; RETURN; END LAB$TYPE = LABTYPE"MAN$LAB"; RETURN; UNREC$LAB: # UNRECOGNIZABLE LABEL # LAB$TYPE = LABTYPE"UNR$LAB"; RETURN; END # CKLAB # TERM PROC CONVSN(DC$VSN,(CONTYPE),CONFLAG); # TITLE CONVSN - CONVERTS CSN BETWEEN EBCDIC AND DISPLAY CODE. # BEGIN # CONVSN # # ** CONVSN - CONVERTS CSN BETWEEN EBCDIC AND DISPLAY CODE. * * THIS PROCEDURE CONVERTS THE CSN FROM EBCDIC TO DISPLAY CODE, * OR FROM DISPLAY CODE TO EBCDIC. * * PROC CONVSN(DC$VSN,(CONTYPE),CONFLAG) * * ENTRY CONTYPE TYPE OF CONVERSION REQUESTED. * 0, DISPLAY CODE TO EBCDIC. * 1, EBCDIC TO DISPLAY CODE. * DC$VSN AN ITEM CONTAINING CSN IN CDC * DISPLAY CODE. * OLDLABP AN ITEM CONTAINING FWA OF BUFFER * CONTAINING OLD CARTRIDGE LABEL. * * EXIT CONFLAG BOOLEAN ITEM CONTAINING ERROR STATUS. * FALSE, NO ERROR. * TRUE, NOT A LEGAL CDC CHARACTER. * * NOTES PROC *CONVSN* CONVERTS THE EBCDIC CSN FROM * *OLDLABEL* AND RETURNS A DISPLAY CODE CSN IN ITEM * *DC$VSN*, OR IT CONVERTS THE DISPLAY CODE CSN FROM * ITEM *DC$VSN* TO EBCDIC AND STORES THE RESULT IN * ARRAY *OLDLABEL*. IF ANY CHARACTERS ARE NOT LEGAL * CDC CHARACTERS (ALPHANUMERIC, EXCLUDING *O* AND *I*) * ERROR FLAG *CONFLAG* IS SET. # ITEM DC$VSN C(8); # CSN IN CDC DISPLAY CODE # ITEM CONTYPE U; # TYPE OF CONVERSION # ITEM CONFLAG B; # ERROR FLAG FOR ILLEGAL CSN # # **** PROC CONVSN - XREF LIST BEGIN. # XREF BEGIN PROC DCEBC; # CONVERTS BETWEEN EBCDIC AND DISPLAY CODE # END # **** PROC CONVSN - XREF LIST END. # DEF LISTCON #0#; # DO NOT LIST THE COMDECKS # *CALL COMBFAS *CALL COMBLBL *CALL COMTLAB ITEM DCTEMP C(1); # TEMPORARY DISPLAY CODE ITEM # ITEM EBCTEMP U; # TEMPORARY EBCDIC ITEM # ITEM I I; # LOOP VARIABLE # ITEM LEGCHAR B; # LEGAL CHARACTER FLAG # ARRAY EBC$VSN [1:12] P(1); # CONTAINS EBCDIC CHARACTERS # BEGIN ITEM EBC$CHAR U(00,00,60); # EBCDIC CHARACTER # END CONTROL EJECT; P = OLDLABP; # LABEL FORMAT DESCRIPTION # CONFLAG = FALSE; # * CONVERSION FROM DISPLAY CODE TO EBCDIC. # IF CONTYPE EQ 0 THEN BEGIN # DISPLAY TO EBCDIC CONVERSION # SLOWFOR I = 0 STEP 1 UNTIL 7 DO BEGIN DCTEMP = CDC$VSN; IF DCTEMP EQ "I" ## OR DCTEMP EQ "O" ## OR DCTEMP LS "A" ## OR DCTEMP GR "9" THEN # ILLEGAL CDC CHARACTER # BEGIN CONFLAG = TRUE; RETURN; END DCEBC(DCTEMP,EBCTEMP,0); # CONVERT TO EBCDIC # EBC$CHAR[I+1] = EBCTEMP; END B<32,8>LAB$CSN[0] = B<52,8>EBC$CHAR[1]; B<40,8>LAB$CSN[0] = B<52,8>EBC$CHAR[2]; B<48,8>LAB$CSN[0] = B<52,8>EBC$CHAR[3]; B<56,4>LAB$CSN[0] = B<52,4>EBC$CHAR[4]; B<0,4>LAB$CSN[1] = B<56,4>EBC$CHAR[4]; B<4,8>LAB$CSN[1] = B<52,8>EBC$CHAR[5]; B<12,8>LAB$CSN[1] = B<52,8>EBC$CHAR[6]; B<20,8>LAB$CSN[1] = B<52,8>EBC$CHAR[7]; B<28,8>LAB$CSN[1] = B<52,8>EBC$CHAR[8]; RETURN; END # DISPLAY TO EBCDIC CONVERSION # # * CONVERSION FROM EBCDIC TO DISPLAY CODE. # IF CONTYPE EQ 1 THEN BEGIN # EBCDIC TO DISPLAY CONVERSION # EBC$CHAR[1] = B<32,8>LAB$CSN[0]; # SAVE EBCDIC BYTES # EBC$CHAR[2] = B<40,8>LAB$CSN[0]; EBC$CHAR[3] = B<48,8>LAB$CSN[0]; B<52,4>EBC$CHAR[4] = B<56,4>LAB$CSN[0]; B<56,4>EBC$CHAR[4] = B<0,4>LAB$CSN[1]; EBC$CHAR[5] = B<4,8>LAB$CSN[1]; EBC$CHAR[6] = B<12,8>LAB$CSN[1]; EBC$CHAR[7] = B<20,8>LAB$CSN[1]; EBC$CHAR[8] = B<28,8>LAB$CSN[1]; LEGCHAR = TRUE; SLOWFOR I = 0 STEP 1 WHILE LEGCHAR AND I LQ 7 DO BEGIN DCEBC(DCTEMP,EBC$CHAR[I+1],1); # CONVERT TO DISPLAY CODE # IF DCTEMP EQ "I" ## OR DCTEMP EQ "O" ## OR DCTEMP LS "A" ## OR DCTEMP GR "9" THEN # ILLEGAL CDC CHARACTER # BEGIN LEGCHAR = FALSE; TEST I; END CDC$VSN = DCTEMP; END IF NOT LEGCHAR THEN # RETURN ERROR FLAG # BEGIN CONFLAG = TRUE; END RETURN; END # EBCDIC TO DISPLAY CONVERSION # END # CONVSN # TERM PROC DCEBC(DC$ITEM,EBC$ITEM,FLAG); # TITLE DCEBC - CONVERTS TO/FROM EBCDIC VALUES. # BEGIN # DCEBC # # ** DCEBC CONVERTS TO/FROM EBCDIC VALUES. * * THIS PROCEDURE CONVERTS AN ITEM FROM DISPLAY * CODE TO EBCDIC (FLAG = 0), OR FROM EBCDIC TO * DISPLAY CODE (FLAG = 1). * * PROC DCEBC(DC$ITEM,EBC$ITEM,FLAG) * * ENTRY FLAG, AN ITEM CONTAINING CODE FOR THE * THE TYPE OF CONVERSION. * 0, DISPLAY CODE TO EBCDIC. * 1, EBCDIC TO DISPLAY CODE. * DC$ITEM, DISPLAY CODE VALUE (IF FLAG=0). * EBC$ITEM, EBCDIC VALUE (IF FLAG=1). * * EXIT CONVERSION DONE AND THE CONVERTED VALUE SET * UP IN DC$ITEM (FLAG=1) OR EBC$ITEM(FLAG=0). * (DC$ITEM) = 0, IF AN ILLEGAL CHARACTER. * * NOTES PROC *DCEBC* CONVERTS AN ITEM FROM DISPLAY * CODE TO EBCDIC OR EBCDIC TO DISPLAY CODE * VALUE DEPENDING ON THE VALUE OF FLAG. A * TABLE HAS BEEN PRESET WITH THE EBCDIC VALUES. * THE ORDINAL OF THE MATCHING EBCDIC VALUE GIVES * THE DISPLAY CODE VALUE. # ITEM DC$ITEM U; # DISPLAY CODE VALUE # ITEM EBC$ITEM U; # EBCDIC VALUE # ITEM FLAG I; # DIRECTION OF CONVERSION # DEF CTLEN #36#; # CONVERSION TABLE LENGTH # DEF LISTCON #0#; # DO NOT LIST COMDECKS # *CALL COMBFAS ITEM I I; # LOOP VARIABLE # # * DISPLAY CODE / EBCDIC CONVERSION TABLE. # ARRAY CONVTBL [1:CTLEN] P(1); # EBCDIC VALUE # BEGIN ITEM CONV$VAL U(00,00,08) = [X"C1", # A # X"C2", # B # X"C3", # C # X"C4", # D # X"C5", # E # X"C6", # F # X"C7", # G # X"C8", # H # X"C9", # I # X"D1", # J # X"D2", # K # X"D3", # L # X"D4", # M # X"D5", # N # X"D6", # O # X"D7", # P # X"D8", # Q # X"D9", # R # X"E2", # S # X"E3", # T # X"E4", # U # X"E5", # V # X"E6", # W # X"E7", # X # X"E8", # Y # X"E9", # Z # X"F0", # 0 # X"F1", # 1 # X"F2", # 2 # X"F3", # 3 # X"F4", # 4 # X"F5", # 5 # X"F6", # 6 # X"F7", # 7 # X"F8", # 8 # X"F9"]; # 9 # END CONTROL EJECT; IF FLAG EQ 1 THEN BEGIN # CONVERT FROM EBCDIC TO DISPLAY CODE # SLOWFOR I = 1 STEP 1 UNTIL CTLEN DO BEGIN IF CONV$VAL[I] EQ EBC$ITEM THEN BEGIN B<0,6>DC$ITEM = I; RETURN; END END DC$ITEM = 0; # ILLEGAL CHARACTER # RETURN; END # CONVERT FROM EBCDIC TO DISPLAY CODE # ELSE BEGIN # CONVERT FROM DISPLAY CODE TO EBCDIC # I = B<0,6>DC$ITEM; EBC$ITEM = CONV$VAL[I]; RETURN; END # CONVERT FROM DISPLAY CODE TO EBCDIC # END # DCEBC # TERM PROC DLABFLD; # TITLE DLABFLD - DISPLAYS FIELDS IN THE CARTRIDGE LABEL. # BEGIN # DLABFLD # # ** DLABFLD - DISPLAYS FIELDS IN THE CARTRIDGE LABEL. * * PROC DLABFLD. * * ENTRY (OLDLABP) = FWA OF BUFFER CONTAINING * CARTRIDGE LABEL. * * EXIT ALL APPROPRIATE FIELDS ARE DISPLAYED IN THE * DAYFILE AND IN THE REPORT FILE. * * MESSAGES 1) CSN = XXXXXXXX. * 2) FAMILY = XXXXXXX. * 3) SUBFAMILY = X. 4) SM = X. * 5) X = X. * 6) Y = X. * * NOTES PROC *DLABFLD* CALLS *CONVSN* AND *XCDD* TO * CONVERT ALL FIELDS TO DISPLAY CODE. THE APPROPRIATE * FIELDS FROM THE OLD CARTRIDGE LABEL ARE THEN DISPLAYED * IN THE DAYFILE AND IN THE REPORT FILE. # # **** PROC DLABFLD - XREF LIST BEGIN. # XREF BEGIN PROC BZFILL; # BLANK/ZERO FILLS A BUFFER # PROC CONVSN; # CONVERTS VSN FROM EBCDIC TO DISPLAY CODE # PROC LBERR; # ERROR PROCESSOR # PROC MESSAGE; # DISPLAYS DAYFILE MESSAGES # PROC RPLINE; # WRITES A LINE ON OUTPUT FILE # FUNC XCDD C(10); # CONVERTS ITEMS FROM INTEGERS TO DISPLAY CODE # END # **** PROC DLABFLD - XREF LIST END. # DEF PROCNAME #"DLABFLD."#; # PROC NAME # DEF LISTCON #0#; # DO NOT LIST COMDECKS # *CALL COMBFAS *CALL COMBBZF *CALL COMBLBL *CALL COMTERR *CALL COMTLAB *CALL COMTOUT ITEM CONFLAG B; # CONVERSION FLAG # ITEM CONTYPE I; # TYPE OF CONVERSION # ITEM DIS$SUB C(10); # SUBFAMILY IN DISPLAY CODE # ITEM DIS$VSN C(8); # *CSN* IN DISPLAY CODE # ITEM DIS$Y C(10); # Y COORDINATE IN DISPLAY CODE # ITEM DIS$Z C(10); # Z COORDINATE IN DISPLAY CODE # ITEM TEMP C(7); # TEMPORARY ITEM # ARRAY LABFLD [0:0] P(4); # DISPLAY FIELDS ARRAY # BEGIN ITEM LABMSG C(00,00,38); # MESSAGE DISPLAY FIELD # ITEM LABY C(00,30,02); # Y COORDINATE IN DISPLAY # ITEM LABZ C(00,30,02); # Z COORDINATE IN DISPLAY # ITEM LABCSU C(00,42,01); # *SM* IN DISPLAY CODE # ITEM LABCM C(00,42,02); # CARTRIDGE MANUFACTURER # ITEM LABVSN C(00,42,08); # *CSN* IN DISPLAY CODE # ITEM LABFAM C(01,00,07); # FAMILY IN DISPLAY CODE # ITEM LABSUB C(01,18,01); # SUBFAMILY IN DISPLAY CODE # ITEM LABTERM U(03,48,12) = [0]; # TERMINATOR # END CONTROL EJECT; # * CONVERT EACH BYTE IN *CSN* TO DISPLAY CODE. # CONTYPE = 1; CONVSN(DIS$VSN,CONTYPE,CONFLAG); IF CONFLAG THEN # ILLEGAL *CSN* # BEGIN ERRCODE = S"ILLEG$C"; LBERR(ERRCODE); END # * DISPLAY CARTRIDGE MANUFACTURER. # P = OLDLABP; LABMSG[0] = " CM = "; LABCM[0] = LAB$CCOD[0]; MESSAGE(LABFLD[0],UDFL1); RPLINE(OUT$FETP,"CM = ",8,8,1); RPLINE(OUT$FETP,LABCM[0],14,2,0); # * DISPLAY *CSN* IN DAYFILE AND IN REPORT FILE. # LABMSG[0] = " CSN = "; LABVSN[0] = DIS$VSN; MESSAGE(LABFLD[0],UDFL1); RPLINE(OUT$FETP,"CSN = ",8,8,1); RPLINE(OUT$FETP,DIS$VSN,14,8,0); # * DISPLAY FAMILY AND SUBFAMILY FOR A FAMILY LABEL. # IF LAB$FMLY[0] NQ " " THEN BEGIN # DISPLAY FAMILY/SUBFAMILY # TEMP = LAB$FMLY[0]; # BLANK FILL FAMILY NAME # BZFILL(TEMP,TYPFILL"BFILL",7); LABMSG[0] = " FAMILY = "; LABFAM[0] = TEMP; MESSAGE(LABFLD[0],UDFL1); RPLINE(OUT$FETP,"FAMILY = ",8,9,1); RPLINE(OUT$FETP,TEMP,17,7,0); DIS$SUB = XCDD(LAB$SF[0]); LABMSG[0] = " SUBFAMILY"; LABFAM[0] = " = "; LABSUB[0] = C<9,1>DIS$SUB; MESSAGE(LABFLD[0],UDFL1); RPLINE(OUT$FETP,"SUBFAMILY = ",8,12,1); RPLINE(OUT$FETP,LABSUB[0],20,1,0); END # DISPLAY FAMILY/SUBFAMILY # # * DISPLAY *SM* IDENTIFIER. # LABMSG[0] = " SM = "; LABCSU[0] = LAB$SMID[0]; MESSAGE(LABFLD[0],UDFL1); RPLINE(OUT$FETP,"SM = ",8,6,1); RPLINE(OUT$FETP,LABCSU[0],14,1,0); # * DISPLAY Y,Z COORDINATES. # DIS$Y = XCDD(LAB$Y[0]); LABMSG[0] = " Y = "; LABY[0] = C<8,2>DIS$Y; MESSAGE(LABFLD[0],UDFL1); RPLINE(OUT$FETP,"Y = ",8,4,1); RPLINE(OUT$FETP,LABY[0],12,2,0); DIS$Z = XCDD(LAB$Z[0]); LABMSG[0] = " Z = "; LABZ[0] = C<8,2>DIS$Z; MESSAGE(LABFLD[0],UDFL1); RPLINE(OUT$FETP,"Z = ",8,4,1); RPLINE(OUT$FETP,LABZ[0],12,2,0); RETURN; END # DLABFLD # TERM PROC GENLAB((LAB$TYPE),PT$CSU$ENT,(LD$CNT),(LD$ERR),(SR$ERR), ( STR$RD),(STR$WR),(STR$DM)); # TITLE GENLAB - SETS UP A FAMILY OR SCRATCH LABEL. # BEGIN # GENLAB # # ** GENLAB - SETS UP A FAMILY OR SCRATCH LABEL. * * THIS PROCEDURE SETS UP A FAMILY OR SCRATCH * LABEL DEPENDING UPON THE *LABTYPE* SPECIFIED. * * PROC GENLAB((LAB$TYPE),PT$CSU$ENT,(LD$CNT),(LD$ERR), * (SR$ERR),(SW$ERR),(HR$ERR)) * * ENTRY PT$CSU$ENT AN ARRAY CONTAINING THE * SMMAP ENTRY. * LD$CNT AN ITEM CONTAINING THE * CARTRIDGE LOAD COUNT. * LD$ERR AN ITEM CONTAINING A COUNT OF * LOAD ERRORS. * SR$ERR AN ITEM CONTAINING A COUNT OF * SOFT READ ERRORS. * SW$ERR AN ITEM CONTAINING A COUNT OF * SOFT WRITE ERRORS. * HR$ERR AN ITEM CONTAINING A COUNT OF * HARD READ ERRORS. * STR$RD AN ITEM CONTAINING A COUNT OF * STRIPES WRITTEN. * STR$WR AN ITEM CONTAINING A COUNT OF * STRIPES READ. * STR$DM AN ITEM CONTAINING A COUNT OF * STRIPES DEMARKED. * NEWLABP AN ITEM CONTAINING FWA OF BUFFER * CONTAINING NEW CARTRIDGE LABEL. * DRD$NUM AN ITEM CONTAINING TRANSPORT ID. * * EXIT LABEL SET UP IN *NEWLABEL*. * * NOTES PROC *GENLAB* SETS UP THE FIELDS FOR * A FAMILY OR SCRATCH LABEL FOR A CARTRIDGE. # ITEM LAB$TYPE U; # TYPE OF CARTRIDGE LABEL # ARRAY PT$CSU$ENT [0:0] P(5); # *PUT* SMMAP ENTRY # BEGIN ITEM PT$MAPENT C(00,00,30); # THREE WORD MAP ENTRY # ITEM PT$Y U(03,00,30); # Y COORDINATE # ITEM PT$Z U(03,30,30); # Z COORDINATE # ITEM PT$GR U(04,00,07); # GROUP # ITEM PT$GRT U(04,07,04); # GROUP ORDINAL # END ITEM LD$CNT I; # CARTRIDGE LOAD COUNT # ITEM PS$CNT I; # CARTRIDGE PASS COUNT # ITEM ERR$CNT I; # CARTRIDGE ERROR COUNT # # **** PROC GENLAB - XREF LIST BEGIN. # XREF BEGIN PROC CONVSN; # CONVERTS VSN FROM EBCDIC TO DISPLAY CODE # PROC LBERR; # ERROR PROCESSOR # END # **** PROC GENLAB - XREF LIST END. # DEF PROCNAME #"GENLAB."#; # PROC NAME # DEF LISTCON #0#; # DO NOT LIST COMDECKS # *CALL COMBFAS *CALL COMBLBL *CALL COMBMAP *CALL COMTERR *CALL COMTLAB *CALL COMTLBP ITEM CONTYPE I; # TYPE OF CONVERSION # ITEM FLAG I; # ERROR FLAG # ITEM HR$ERR I; # HARD READ ERRORS # ITEM I I; # LOOP VARIABLE # ITEM LD$ERR I; # LOAD ERRORS # ITEM TEMP$VSN C(8); # CSN IN CDC DISPLAY CODE # ITEM SR$ERR I; # SOFT READ ERRORS # ITEM STR$RD I; # STRIPES READ # ITEM STR$WR I; # STRIPES WRITTEN # ITEM STR$DM I; # STRIPES DEMARKED # ITEM SW$ERR I; # SOFT WRITE ERRORS # # * BASED ARRAY TO ACCESS FIRST FOUR WORDS OF CARTRIDGE LABEL. # BASED ARRAY TEMP$LAB [0:0] P(1); BEGIN ITEM TEMP$LABW U(00,00,60); # FIRST WORD OF LABEL # END CONTROL EJECT; # * ZERO FILL THE *NEWLABEL* ARRAY. # P = NEWLABP; SLOWFOR I = 0 STEP 1 UNTIL LABLEN-1 DO BEGIN LAB$W1[I] = 0; END # * SET THE FIRST 4 WORDS WORDS OF *NEWLABEL* * EQUAL TO THE FIRST 4 WORDS OF *OLDLABEL*. # P = OLDLABP; P = NEWLABP; SLOWFOR I = 0 STEP 1 UNTIL 3 DO BEGIN TEMP$LABW[I] = LAB$W1[I]; END # * CONVERT EACH OF THE SIX EBCDIC BYTES IN *OLDLABEL* * TO DISPLAY CODE. # CONTYPE = 1; CONVSN(TEMP$VSN,CONTYPE,FLAG); IF FLAG NQ 0 THEN # ILLEGAL VSN # BEGIN ERRCODE = S"ILLEG$C"; LBERR(ERRCODE); END P = NEWLABP; P = LOC(PT$CSU$ENT[0]); # * SET UP VARIOUS FIELDS IN *NEWLABEL*. # LAB$CSND[0] = TEMP$VSN; LAB$Y[0] = PT$Y[0]; LAB$Z[0] = PT$Z[0]; LAB$FMLY[0] = CM$FMLYNM[0]; LAB$SF[0] = CM$SUB[0]; LAB$SMID[0] = LBARG$SM[0]; LAB$CLF[0] = 1; # * SET UP *P* FLAG. # IF LAB$TYPE EQ LABTYPE"SCR$LAB" THEN # A SCRATCH LABEL # BEGIN LAB$CARTTP[0] = 2; END ELSE # A FAMILY LABEL # BEGIN LAB$CARTTP[0] = 1; END # * SET UP THE LOAD COUNT, LOAD ERRORS, SOFT READ/WRITE * AND HARD READ ERRORS. * FOR THE CARTRIDGE. # LAB$CRLD[0] = LD$CNT; LAB$LDER = LD$ERR; LAB$SWRE = B<28,4>SW$ERR; LAB$SWRE1 = B<32,28>SW$ERR; LAB$SRDE = SR$ERR; LAB$HRDE = HR$ERR; LAB$STRD[0] = B<28,8>STR$RD; LAB$STWR1[0] = B<36,24>STR$WR; LAB$STWR[0] = STR$WR; LAB$STDM[0] = STR$DM; # * SET UP NUMBER OF THE TRANSPORT ON WHICH * LABEL WAS WRITTEN. ALSO SET UP THE DATE * AND TIME WHEN LABEL WAS WRITTEN. # LAB$DTTM[0] = PD$T; RETURN; END # GENLAB # TERM PROC LBADCSU; # TITLE LBADCSU - ADDS A *SM* TO A SUBFAMILY. # BEGIN # LBADCSU # # ** LBADCSU - ADDS A *SM* TO A SUBFAMILY. * * THIS PROCEDURE ADDS A *SM* TO A FAMILY * IN THE CATALOG. THIS DIRECTIVE DOES NOT * MANIPULATE CUBES OR CARTRIDGES. * * PROC LBADCSU. * * ENTRY CRACKED AND SYNTAX CHECKED DIRECTIVE PARAMETERS * SET UP IN COMMON AREA DEFINED IN *COMTLBP*. * * EXIT *SM* ADDED TO THE SPECIFIED FAMILY. * * NOTES PROC *LBADCSU* SENDS A REQUEST TO EXEC TO ADD * THE *SM* TO THE FAMILY CATALOG. IF THE *SM* IS * ALREADY DEFINED, IT CALLS THE ERROR PROCESSOR * WITH THE CORRESPONDING ERROR CODE. SEE *LBERR* * FOR FURTHER INFORMATION. # # **** PROC LBADCSU - XREF LIST BEGIN. # XREF BEGIN PROC CALL3; # SENDS TYPE 3 CALLSS TO EXEC # PROC LBRESP; # RESPONSE CODE PROCESSOR # END # **** PROC LBADCSU - XREF LIST END. # DEF LISTCON #0#; # DO NOT LIST COMDECKS # *CALL COMBFAS *CALL COMBCPR ITEM RESP$CODE U; # RESPONSE CODE FROM EXEC # CONTROL EJECT; # * ADD *SM* TO FAMILY CATALOG. # CALL3(REQTYP3"ADD$CSU",0,0,0,RESP$CODE); # * PROCESS THE RESPONSE CODE RETURNED BY EXEC. # IF RESP$CODE NQ RESPTYP3"OK3" THEN BEGIN LBRESP(RESP$CODE,TYP"TYP3"); END RETURN; END # LBADCSU # TERM PROC LBADCUB; # TITLE LBADCUB - ADDS CUBES TO A FAMILY OR POOL. # BEGIN # LBADCUB # # ** LBADCUB - ADDS CUBES TO A FAMILY OR POOL. * * THIS PROC ADDS NON-ASSIGNED CUBES TO A FAMILY OR * THE POOL. * * PROC LBADCUB. * * ENTRY CRACKED AND SYNTAX CHECKED DIRECTIVE PARAMETERS * SET UP IN COMMON AREA DEFINED IN *COMTLBP*. * * EXIT A SPECIFIED NUMBER OR LOCATIONS OF CUBES * ADDED TO A FAMILY OR POOL. * * NOTES PROC *LBADCUB* ADDS UNASSIGNED CUBES TO * A FAMILY OR POOL. IT ADDS A SPECIFIED * NUMBER OF CUBES IF *N* IS SPECIFIED OR * ADDS THE CUBES AT THE LOCATIONS SPECIFIED * BZ *YI*, *YF*, *ZI*, *ZF*. IT SEARCHES * THE SMMAP FOR AN UNASSIGNED CUBE AND * SENDS A REQUEST TO EXEC TO ADD IT TO THE * FAMILY CATALOG OR TO THE POOL. IF AN * ERROR CONDITION IS ENCOUNTERED, *LBERR* IS * CALLED TO DO THE ERROR PROCESSING. # # **** PROC LBADCUB - XREF LIST BEGIN. # XREF BEGIN PROC CALL3; # SENDS TYPE 3 CALLSS TO EXEC # PROC LBERR; # *SSLABEL* ERROR PROCESSOR # PROC LBRESP; # RESPONSE CODE PROCESSOR # PROC MFLUSH; # FLUSH MAP BUFFER # PROC MCLOSE; # CLOSE SMMAP # PROC MOPEN; # OPEN SMMAP # PROC SERCSU; # SEARCHES SMMAP # PROC SETCORD; # SETS UP Y Z COORDINATE TABLE # END # **** PROC LBADCUB - XREF LIST END. # DEF LISTCON #0#; # DO NOT LIST COMDECKS # *CALL COMBFAS *CALL COMBCPR *CALL COMBMAP *CALL COMTERR *CALL COMTLAB *CALL COMTLBP ITEM FLAG I; # ERROR FLAG # ITEM I I; # LOOP VARIABLE # ITEM LOC$OPTION B ; # TRUE, IF *LOC* OPTION SELECTED FALSE, IF *N* OPTION SELECTED # ITEM RESP$CODE U; # RESPONSE CODE FROM EXEC # ITEM SERTYPE S:SERCH$TYPE; # SMMAP SEARCH TYPE # ITEM SP$CODE U; # CODE FOR CUBE/CARTRIDGE ASSIGNMENT # ITEM SP$FAM C(7); # SPECIFIED FAMILY # ITEM SP$SUB U; # SPECIFIED SUB FAMILY # ITEM SP$VSN C(8); # SPECIFIED *CSN* # ITEM SP$Y U; # Y COORDINATE # ITEM SP$Z U; # Z COORDINATE # ARRAY PK$CSU$ENT [0:0] P(4); # *PICK* SMMAP ENTRY # BEGIN ITEM PK$MAPENT C(00,00,30); # THREE WORD MAP ENTRY # ITEM PK$Y U(03,00,30); # Y COORDINATE # ITEM PK$Z U(03,30,30); # Z COORDINATE # END ARRAY CMAP$NM [0:0] P(1); # BUILD SMMAP FILE NAME # BEGIN ITEM CMAP$NAME C(00,00,07); # SMMAP FILE NAME # ITEM CMAP$IN C(00,00,05); # FIRST FIVE CHARACTERS # ITEM CMAP$ID C(00,30,01); # SM-ID # ITEM CMAP$Z U(00,36,24) = [0]; # ZERO FILL # END CONTROL EJECT; # * CHECK TO SEE IF THE *N* OPTION OR THE *LOC* OPTION * IS SPECIFIED. # LOC$OPTION = FALSE; # INITIALIZE # IF (LBARG$YI[0] NQ -1) OR (LBARG$ZI[0] NQ -1) THEN # *LOC* OPTION SPECIFIED # BEGIN SETCORD; # SET UP THE Y/Z COORDINATES # LOC$OPTION = TRUE; END # * INITIALIZE ITEMS TO SEARCH SMMAP FOR UNASSIGNED * CUBES. # SP$VSN = " "; SP$CODE = CUBSTAT"UNASGN"; SP$FAM = " "; SP$SUB = 0; IF NOT LOC$OPTION THEN BEGIN # *N* OPTION # IF LBARG$PT[0] EQ "F" THEN # SEARCH SMMAP FOR FIRST UNASSIGNED CUBE # BEGIN SERTYPE = S"ASSIGN"; END IF LBARG$PT[0] EQ "P" THEN # SEARCH SMMAP FOR LAST UNASSIGNED CUBE # BEGIN SERTYPE = S"LST$UNAS"; END END # *N* OPTION # ELSE # *LOC* OPTION # BEGIN SERTYPE = S"LOC"; # SEARCH FOR LOCATION # END # * PROCESS EACH OF THE *NOPT* CUBES. # SLOWFOR I = 1 STEP 1 UNTIL LBARG$N[0] DO BEGIN # ADD CUBES # IF SERTYPE EQ S"LOC" THEN BEGIN SP$Y = Y$COORD[I]; # SET UP Y AND Z COORDINATES # SP$Z = Z$COORD[I]; END # * SEARCH SMMAP FOR THE SPECIFIC ENTRY. # SERCSU(SERTYPE,SP$Y,SP$Z,SP$CODE,SP$VSN,SP$FAM,SP$SUB, PK$CSU$ENT[0],FLAG); IF FLAG NQ 0 THEN # ENTRY NOT FOUND # BEGIN NUMDONE = I - 1; # NUMBER OF CUBES PROCESSED # ERRCODE = S"INSUF$CB"; LBERR(ERRCODE); RETURN; END CMAP$ID[0] = LBARG$SM[0]; CMAP$IN[0] = SMMAP; # * CHECK THE *CODE* IN SMMAP ENTRY TO SEE IF * THE CUBE IS UNASSIGNED. # P = LOC(PK$CSU$ENT[0]); IF CM$CODE[0] NQ CUBSTAT"UNASGN" THEN BEGIN NUMDONE = I - 1; # NUMBER OF CUBES PROCESSED # ERRCODE = S"CB$ASGN"; LBERR(ERRCODE); RETURN; END # * CHECK *PT* TO SEE IF THE CUBE IS TO BE ADDED TO * FAMILY, POOL OR THE RESERVED AREA AND SEND A * CORRESPONDING REQUEST TO EXEC. # IF LBARG$PT[0] EQ "F" THEN # ADD CUBE TO FAMILY # BEGIN CALL3(REQTYP3"ADD$CUBE",PK$CSU$ENT[0],0,0,RESP$CODE); IF RESP$CODE NQ RESPTYP3"OK3" THEN BEGIN LBRESP(RESP$CODE,TYP"TYP3"); RETURN; END END ELSE BEGIN # ADD CUBE TO POOL/RESERVED AREA # IF LBARG$PT[0] EQ "P" THEN BEGIN CM$CODE[0] = CUBSTAT"SCRPOOL"; END IF LBARG$PT[0] EQ "R" THEN BEGIN CM$CODE[0] = CUBSTAT"ALTCSU"; END CALL3(REQTYP3"UPD$MAP",PK$CSU$ENT[0],0,0,RESP$CODE); END # ADD CUBE TO POOL/RESERVED AREA # # * CHECK THE RESPONSE CODE RETURNED BY EXEC. # IF RESP$CODE NQ RESPTYP3"OK3" THEN BEGIN LBRESP(RESP$CODE,TYP"TYP3"); RETURN; END MFLUSH; # FLUSH MAP BUFFER # END # ADD CUBES # # * ALL THE CUBES ADDED. # RETURN; END # LBADCUB # TERM PROC LBADMSC; # TITLE LBADMSC - PROCESS THE *ADDMSC* DIRECTIVE. # BEGIN # LBADMSC # # ** LBADMSC - PROCESS THE *ADDMSC* DIRECTIVE. * * PROC LBADMSC. * * ENTRY CRACKED AND SYNTAX CHECKED DIRECTIVE PARAMETERS * SET UP IN COMMON AREA DEFINED IN *COMTLBP*. * * EXIT ALL CARTRIDGES PROCESSED. * * NOTES THE SMMAP IS SEARCHED FOR THE APPROPRIATE * *PICK* AND *PUT* LOCATIONS. IF SUCCESSFUL, THE * CARTRIDGE IS BROUGHT TO A TRANSPORT AND GIVEN A NEW * LABEL. THE SMMAP (AND FCT AND AST IF ADDED TO A * FAMILY) IS UPDATED TO REFLECT THE NEW CARTRIDGE * ASSIGNMENT, AND THE CARTRIDGE IS UNLOADED TO THE * NEW LOCATION. ANY ERROR CONDITIONS ARE PROCESSED * BY PROC *LBERR*. # # **** PROC LBADMSC - XREF LIST BEGIN. # XREF BEGIN PROC CALL3; # SENDS TYPE 3 CALLSS TO EXEC # PROC CALL4; # SENDS TYPE 4 CALLSS TO EXEC # PROC CKLAB; # CHECKS CARTRIDGE LABEL TYPE # PROC GENLAB; # GENERATES NEW LABEL # PROC LBERR; # *SSLABEL* ERROR PROCESSOR # PROC LBRESP; # RESPONSE CODE PROCESSOR # PROC LBSTCLR; # STORE A *CE* CARTRIDGE # PROC MFLUSH; # FLUSH MAP BUFFER # PROC SERASTG; # DETERMINE GROUP AND ORDINAL # PROC SERCSU; # SEARCHES SMMAP # END # **** PROC LBADMSC - XREF LIST END. # DEF LISTCON #0#; # DO NOT LIST COMDECKS # *CALL COMBFAS *CALL COMBCPR *CALL COMBLBL *CALL COMBMAP *CALL COMTERR *CALL COMTLAB *CALL COMTLBP ITEM CART$CSN C(20); # CARTRIDGE SERIAL NUMBER # ITEM CATFLD U; # CATALOG FIELD # ITEM CATVALUE U; # NEW VALUE FOR CATALOG FIELD # ITEM ERR$CNT I; # CARTRIDGE ERROR COUNT # ITEM FLAG I; # ERROR FLAG # ITEM GROUP I; # GROUP NUMBER # ITEM GRT I; # ORDINAL WITHIN GROUP # ITEM HR$ERR I; # HARD READ ERRORS # ITEM I I; # LOOP VARIABLE # ITEM LD$CNT I; # CARTRIDGE LOAD COUNT # ITEM LD$ERR I; # LOAD ERRORS # ITEM PS$CNT U; # CARTRIDGE PASS COUNT # ITEM REQCODE U; # REQUEST CODE # ITEM RESP$CODE U; # RESPONSE CODE # ITEM SGROUP I; # SAVE GROUP PARAMETER # ITEM SERFLAG B; # SMMAP SEARCH FLAG # ITEM SERTYPE S:SERCH$TYPE; # SMMAP SEARCH TYPE # ITEM SP$CODE U; # CUBE/CARTRIDGE ASSIGNMENT # ITEM SP$FAM C(7); # SPECIFIED FAMILY NAME # ITEM SP$SUB U; # SPECIFIED SUB FAMILY ID # ITEM SP$VSN C(8); # SPECIFIED CARTRIDGE *CSND* # ITEM SP$Y I; # Y COORDINATE # ITEM SP$Z I; # Z COORDINATE # ITEM SR$ERR I; # SOFT READ ERRORS # ITEM STR$RD I; # STRIPES READ # ITEM STR$WR I; # STRIPES WRITTEN # ITEM STR$DM I; # STRIPES DEMARKED # ITEM SW$ERR I; # SOFT WRITE ERRORS # ARRAY PK$CSU$ENT [0:0] P(4); # *PICK* SMMAP ENTRY # BEGIN ITEM PK$MAPENT C(00,00,30); # THREE WORD MAP ENTRY # ITEM PK$Y U(03,00,30); # Y COORDINATE # ITEM PK$Z U(03,30,30); # Z COORDINATE # END ARRAY PT$CSU$ENT [0:0] P(5); # *PUT* SMMAP ENTRY # BEGIN ITEM PT$MAPENT C(00,00,30); # THREE WORD MAP ENTRY # ITEM PT$Y U(03,00,30); # Y COORDINATE # ITEM PT$Z U(03,30,30); # Z COORDINATE # ITEM PT$GR U(04,00,07); # GROUP # ITEM PT$GRT U(04,07,05); # GROUP ORDINAL # END CONTROL EJECT; IF LBARG$CC[0] NQ -1 THEN # STORE CLEAR CARTRIDGE # BEGIN LBSTCLR; RETURN; END SGROUP = LBARG$GR[0]; SLOWFOR I = 1 STEP 1 UNTIL LBARG$N[0] DO BEGIN # LBADMSC PROCESSING # # * SEARCH FOR DEFAULT GROUP AND GROUP ORDINAL. # IF LBARG$PT[0] NQ "P" THEN BEGIN LBARG$GR[0] = SGROUP; GROUP = LBARG$GR[0]; SERASTG(GROUP,GRT,FLAG); IF FLAG NQ 0 THEN # GROUP OR ORDINAL NOT AVAILABLE # BEGIN ERRCODE = S"GR$FULL"; LBERR(ERRCODE); RETURN; END ELSE # SEARCH SUCCESSFUL # BEGIN LBARG$GR[0] = GROUP; PT$GR[0] = GROUP; PT$GRT[0] = GRT; END END # * SEARCH FOR EMPTY CUBE TO WHICH CARTRIDGE IS TO BE ADDED. # IF LBARG$PT[0] EQ "F" THEN # ADD CARTRIDGE TO FAMILY # BEGIN # FAMILY SEARCH # SERTYPE = S"ASSIGN"; SP$CODE = CUBSTAT"SUBFAM"; SP$VSN = " "; # SEARCH FOR AN EMPTY CUBE # SERCSU(SERTYPE,0,0,SP$CODE,SP$VSN,LBARG$FM[0],LBARG$SB[0], PT$CSU$ENT[0],SERFLAG); IF SERFLAG THEN # NO EMPTY CUBE IN FAMILY # BEGIN NUMDONE = I - 1; ERRCODE = S"NO$EMPCBFP"; LBERR(ERRCODE); # DO ERROR PROCESSING # RETURN; END END # FAMILY SEARCH # IF LBARG$PT[0] EQ "P" THEN # ADD CARTRIDGE TO POOL # BEGIN # POOL SEARCH # SERTYPE = S"ASSIGN"; SP$FAM = " "; # SEARCH FOR AN EMPTY CUBE # SP$SUB = 0; SP$VSN = " "; SP$CODE = CUBSTAT"SCRPOOL"; SERCSU(SERTYPE,0,0,SP$CODE,SP$VSN,SP$FAM,SP$SUB, ## PT$CSU$ENT[0],SERFLAG); IF SERFLAG THEN # NO EMPTY CUBE IN POOL # BEGIN NUMDONE = I - 1; ERRCODE = S"NO$EMPCBFP"; LBERR(ERRCODE); # DO ERROR PROCESSING # RETURN; END END # POOL SEARCH # # * SEARCH FOR CARTRIDGE TO BE ADDED. # IF LBARG$PK[0] EQ "P" AND LBARG$C[0] EQ 0 THEN BEGIN # SEARCH POOL FOR ANY CARTRIDGE # SERTYPE = S"CART$POOL"; SERCSU(SERTYPE,0,0,0,0,0,0,PK$CSU$ENT[0],SERFLAG); IF SERFLAG THEN # POOL EMPTY # BEGIN NUMDONE = I - 1; ERRCODE = S"NO$CR$PL"; LBERR(ERRCODE); # DO ERROR PROCESSING # RETURN; END END # SEARCH POOL FOR ANY CARTRIDGE # IF LBARG$C[0] NQ 0 THEN BEGIN # SEARCH POOL FOR VSN # SERTYPE = S"CSN$MATCH"; SERCSU(SERTYPE,0,0,0,LBARG$C[0],0,0,PK$CSU$ENT[0],SERFLAG); IF SERFLAG THEN # VSN NOT FOUND # BEGIN ERRCODE = S"CSN$NOTFND"; LBERR(ERRCODE); # DO ERROR PROCESSING # RETURN; END ELSE # VSN FOUND # BEGIN P = LOC(PK$CSU$ENT[0]); IF CM$CODE[0] NQ CUBSTAT"SCRPOOL" THEN # CARTRIDGE NOT ASSIGNED TO POOL # BEGIN ERRCODE = S"UNX$CR$ASN"; LBERR(ERRCODE); # DO ERROR PROCESSING # RETURN; END END END # SEARCH POOL FOR VSN # IF LBARG$PK[0] EQ "D" THEN # SET COORDINATES TO CAS ENTRY # BEGIN PK$Y[0] = SM$ENT$TY; PK$Z[0] = 0; END # * LOAD CARTRIDGE AND READ THE LABEL. # CALL4(REQTYP4"LOAD$CART",DRD$NUM,CART$CSN,PK$Y[0], PK$Z[0], FLAG); IF FLAG NQ RESPTYP4"OK4" ## AND FLAG NQ RESPTYP4"UNK$CART" THEN BEGIN # LOAD FAILS # P = LOC(PK$CSU$ENT[0]); IF FLAG EQ RESPTYP4"CELL$EMP" ## AND CM$CODE[0] EQ CUBSTAT"SCRPOOL" THEN BEGIN # SET ERROR FLAG IN SMMAP ENTRY # CM$FLAG1[0] = TRUE; CALL3(REQTYP3"UPD$MAP",PK$CSU$ENT[0],0,0,FLAG); NUMDONE = I - 1; ERRCODE = S"CR$NOTFND"; # CARTRIDGE NOT FOUND # LBERR(ERRCODE); IF FLAG NQ RESPTYP3"OK3" THEN BEGIN LBRESP(FLAG,TYP"TYP3"); END RETURN; END # SET ERROR FLAG IN SMMAP ENTRY # P = OLDLABP; IF FLAG EQ RESPTYP4"UNK$CART" AND LAB$CARTTP[0] NQ 0 THEN # *CSN* MISMATCH # BEGIN LBRESP(FLAG,TYP"TYP4"); RETURN; END ELSE # PROCESS THE RESPONSE CODE # BEGIN LBRESP(FLAG,TYP"TYP4"); RETURN; END END # LOAD FAILS # CKLAB(FLAG); # CHECK LABEL TYPE # P = OLDLABP; IF (FLAG NQ LABTYPE"MAN$LAB" ## AND FLAG NQ LABTYPE"SCR$LAB") ## THEN # UNKNOWN LABEL TYPE # BEGIN CALL4(REQTYP4"UNLD$CART",0,0,SM$EXIT$TY,SM$TY$Z,RESP$CODE); IF RESP$CODE NQ 0 THEN BEGIN LBRESP(RESP$CODE,TYP"TYP4"); RETURN; END ERRCODE = S"UNKNWN$LAB"; LBERR(ERRCODE); TEST I; END LD$CNT = LAB$CRLD[0]; # USE OLD COUNTS # LD$ERR = LAB$LDER[0]; SR$ERR = LAB$SRDE[0]; SW$ERR = LAB$SWRE1[0]; B<28,4>SW$ERR = LAB$SWRE; HR$ERR = LAB$HRDE[0]; STR$RD = LAB$STRD[0]; STR$WR = LAB$STWR1[0]; B<36,24>STR$WR = LAB$STWR[0]; STR$DM = LAB$STDM[0]; IF LBARG$PK[0] NQ "D" THEN BEGIN # VERIFY VSN, Y, Z IN THE LABEL # P = OLDLABP; P = LOC(PK$CSU$ENT[0]); IF LAB$CSND[0] NQ CM$CSND[0] ## AND (LAB$Y[0] NQ PK$Y[0] OR LAB$Z[0] NQ PK$Z[0]) THEN BEGIN # TEST Y,Z # REQCODE = REQTYP4"UNLD$CART"; CALL4(REQCODE,0,0,SM$EXIT$TY,SM$TY$Z,RESP$CODE); IF RESP$CODE NQ RESPTYP4"OK4" THEN BEGIN LBRESP(RESP$CODE,TYP"TYP4"); RETURN; END ERRCODE = S"M86$HARDWR"; # MSF HARDWARE PROBLEM # LBERR(ERRCODE); RETURN; END # TEST Y,Z # END # VERIFY VSN, Y, Z IN THE LABEL # # * GENERATE NEW CARTRIDGE LABEL # IF LBARG$PT[0] EQ "P" THEN # SET UP SCRATCH LABEL # BEGIN GENLAB(LABTYPE"SCR$LAB",PT$CSU$ENT[0],LD$CNT,LD$ERR, SR$ERR, SW$ERR,HR$ERR,STR$RD,STR$WR,STR$DM); END ELSE # SET UP FAMILY LABEL # BEGIN GENLAB(LABTYPE"FAM$LAB",PT$CSU$ENT[0],LD$CNT,LD$ERR, SR$ERR, SW$ERR,HR$ERR,STR$RD,STR$WR,STR$DM); END # * UPDATE THE CARTRIDGE LOAD AND PASS COUNTS IN THE * NEW LABEL. # P = NEWLABP; LAB$CRLD[0] = LAB$CRLD[0] + 1; IF B<0,8>LAB$CSN[0] NQ X"C9" ## OR B<8,8>LAB$CSN[0] NQ X"C2" OR B<16,8>LAB$CSN[0] NQ X"D4" THEN # CARTRIDGE NOT IBM # BEGIN LAB$CCOD[0] = OTHCART; END ELSE BEGIN LAB$CCOD[0] = IBMCART; END # * IF THE CARTRIDGE IS FROM THE INPUT DRAWER, ENSURE THAT * THE VSN IS NOT ALREADY IN THE SMUMAP. # IF LBARG$PK[0] EQ "D" THEN BEGIN # CHECK FOR DUPLICATE VSN # SERTYPE = S"CSN$MATCH"; SERCSU(SERTYPE,0,0,0,LAB$CSND[0],0,0, PK$CSU$ENT[0],SERFLAG) ; IF NOT SERFLAG THEN # VSN ALREADY IN SMMAP # BEGIN REQCODE = REQTYP4"UNLD$CART"; CALL4(REQCODE,0,0,SM$EXIT$TY,SM$TY$Z,RESP$CODE); IF RESP$CODE NQ RESPTYP4"OK4" THEN BEGIN LBRESP(RESP$CODE,TYP"TYP4"); RETURN; END ERRCODE = S"DUPL$CSN"; LBERR(ERRCODE); RETURN; END END # CHECK FOR DUPLICATE VSN # # * IF CARTRIDGE PICKED FROM POOL, UPDATE SMMAP ENTRY AND AST FOR * NOW EMPTY CUBE IN POOL. # IF LBARG$PK[0] NQ "D" THEN # PICKED FROM POOL # BEGIN P = LOC(PK$CSU$ENT[0]); CM$CCOD[0] = " "; CM$CSND[0] = " "; # CLEAR VSN FIELD # CALL3(REQTYP3"UPD$MAP",PK$CSU$ENT[0],0,0,FLAG); IF FLAG NQ RESPTYP3"OK3" THEN # MAP UPDATE FAILS # BEGIN REQCODE = REQTYP4"UNLD$CART"; CALL4(REQCODE,0,0,PK$Y[0],PK$Z[0],RESP$CODE); IF RESP$CODE NQ RESPTYP4"OK4" THEN BEGIN LBRESP(RESP$CODE,TYP"TYP4"); RETURN; END LBRESP(FLAG,TYP"TYP3"); # PROCESS ERROR CODE # RETURN; END END # * WRITE NEW LABEL. # CALL4(REQTYP4"WRT$LAB",DRD$NUM,CART$CSN,PT$Y[0],PT$Z[0], FLAG) ; IF FLAG NQ RESPTYP4"OK4" THEN # WRITE FAILS # BEGIN LBRESP(FLAG,TYP"TYP4"); # PROCESS THE RESPONSE CODE # RETURN; END # * UPDATE SMMAP ENTRY FOR NEW LOCATION OF CARTRIDGE. # P = LOC(PT$CSU$ENT[0]); IF LBARG$PT[0] EQ "P" THEN # ADD CARTRIDGE TO POOL # BEGIN P = NEWLABP; CM$CCOD[0] = LAB$CCOD[0]; CM$CSND[0] = LAB$CSND[0]; # UPDATE VSN IN MAP ENTRY # CALL3(REQTYP3"UPD$MAP",PT$CSU$ENT[0],0,0,FLAG); END IF LBARG$PT[0] EQ "F" THEN # ADD CARTRIDGE TO FAMILY # BEGIN CALL3(REQTYP3"ADD$CART",PT$CSU$ENT[0],0,0,FLAG); END IF FLAG NQ RESPTYP3"OK3" THEN # ADD TO FAMILY FAILS # BEGIN LBRESP(FLAG,TYP"TYP3"); # PROCESS THE RESPONSE CODE # RETURN; END MFLUSH; # FLUSH MAP BUFFER # END # LBADMSC PROCESSING # RETURN; END # LBADMSC # TERM PROC LBCONV(FLAG); # TITLE LBCONV - CONVERT CRACKED PARAMETERS TO INTEGERS. # BEGIN # LBCONV # # ** LBCONV - CONVERT CRACKED PARAMETERS TO INTEGERS. * * THIS PROCEDURE CALLS *XDXB* TO CONVERT THE PARAMETERS * IN DISPLAY CODE TO INTEGER VALUES. * * PROC LBCONV(FLAG) * * ENTRY DIRECTIVE PARAMETERS CRACKED AND * PLACED IN COMMON AREA *ULBPCOM*. * * EXIT ALL THE PARAMETERS CONVERTED AND PLACED * BACK IN *ULBPCOM*. * FLAG, AN ITEM CONTAINING THE ERROR STATUS. * 0, NO ERROR * 1, CONVERSION ERROR * * NOTES PROC *LBCONV* CONVERTS EACH CRACKED * PARAMETER FROM DISPLAY CODE TO INTEGER * VALUE AND REPLACES IT BACK IN ITS * ORIGINAL LOCATION. ANY PARAMETER NOT * SPECIFIED IS SUBSTITUTED WITH ITS * DEFAULT VALUE. # ITEM FLAG I; # ERROR STATUS # # **** PROC LBCONV - XREF LIST BEGIN. # XREF BEGIN FUNC XDXB I; # CONVERT DISPLAY TO INTEGER # END # **** PROC LBCONV - XREF LIST END. # DEF LISTCON #0#; # DO NOT LIST COMDECKS # *CALL COMBFAS *CALL COMTLAB *CALL COMTLBP ITEM TEMPR I; # TEMP ITEM # ITEM TYPE I; # TYPE OF CONVERSION # CONTROL EJECT; TYPE = 1; # CONVERT FROM DISPLAY CODE TO INTEGER VALUE # # * CHECK THE VALUE OF *N*. # IF LBARG$N[0] EQ 0 THEN # N OMITTED # BEGIN LBARG$N[0] = 1; # SET DEFAULT VALUE # END IF LBARG$N[0] NQ 1 THEN # N SPECIFIED # BEGIN FLAG = XDXB(LBARG$N[0],TYPE,TEMPR); IF FLAG NQ 0 THEN # CONVERSION ERROR # BEGIN RETURN; END LBARG$N[0] = TEMPR; # RESET N # END # * CHECK THE VALUE OF *B*. # IF LBARG$B[0] EQ 0 THEN # SET DEFAULT # BEGIN LBARG$B[0] = 600; END IF LBARG$B[0] NQ 600 THEN # *B* IS SPECIFIED # BEGIN FLAG = XDXB(LBARG$B[0],TYPE,TEMPR); IF FLAG NQ 0 THEN # CONVERSION ERROR # BEGIN RETURN; END LBARG$B[0] = TEMPR; # RESET *B* # END # * SET THE VALUE OF *CC*. # IF LBARG$CC[0] NQ 0 THEN BEGIN IF C<0,1>LBARG$CC[0] EQ "A" THEN BEGIN LBARG$CC[0] = 0; END IF C<0,1>LBARG$CC[0] EQ "B" THEN BEGIN LBARG$CC[0] = 15; END END ELSE BEGIN LBARG$CC[0] = -1; END # * CHECK THE VALUE OF *CC*. # IF LBARG$CM[0] EQ 0 THEN BEGIN LBARG$CM[0] = IBMCART; END ELSE BEGIN B<6,6>LBARG$CM[0] = "-"; END # * CHECK THE VALUE OF *GR*. # IF LBARG$GR[0] NQ 7777 THEN # VALUE IS SPECIFIED # BEGIN FLAG = XDXB(LBARG$GR[0],TYPE,TEMPR); IF FLAG NQ 0 THEN # CONVERSION ERROR # BEGIN RETURN; END LBARG$GR[0] = TEMPR; # RESET *GR* # END ELSE # *GR* NOT SPECIFIED # BEGIN LBARG$GR[0] = -1; END # * CHECK THE VALUE OF *YI*. # IF LBARG$YI[0] NQ 0 AND LBARG$YI[0] NQ O"7777" THEN BEGIN FLAG = XDXB(LBARG$YI[0],TYPE,TEMPR); IF FLAG NQ 0 THEN # CONVERSION ERROR # BEGIN RETURN; END LBARG$YI[0] = TEMPR; # RESET *YI* # END ELSE BEGIN IF LBARG$YI[0] EQ 0 THEN # *YI* OMITTED # BEGIN LBARG$YI[0] = -1; # SET DEFAULT VALUE # END END # * CHECK THE VALUE OF *YF*. # IF LBARG$YF[0] NQ 0 ## AND LBARG$YF[0] NQ O"7777" THEN BEGIN FLAG = XDXB(LBARG$YF[0],TYPE,TEMPR); IF FLAG NQ 0 THEN # CONVERSION ERROR # BEGIN RETURN; END LBARG$YF[0] = TEMPR; # RESET *YF* # END ELSE BEGIN IF LBARG$YF[0] EQ 0 THEN # *YF* OMITTED # BEGIN LBARG$YF[0] = -1; # SET DEFAULT VALUE # END END # * CHECK THE VALUE OF *ZI*. # IF LBARG$ZI[0] NQ 0 AND LBARG$ZI[0] NQ O"7777" THEN BEGIN FLAG = XDXB(LBARG$ZI[0],TYPE,TEMPR); IF FLAG NQ 0 THEN # CONVERSION ERROR # BEGIN RETURN; END LBARG$ZI[0] = TEMPR; # RESET *ZI* # END ELSE BEGIN IF LBARG$ZI[0] EQ 0 THEN # *ZI* OMITTED # BEGIN LBARG$ZI[0] = -1; # SET DEFAULT VALUE # END END # * CHECK THE VALUE OF *ZF*. # IF LBARG$ZF[0] NQ 0 AND LBARG$ZF[0] NQ O"7777" THEN BEGIN FLAG = XDXB(LBARG$ZF[0],TYPE,TEMPR); IF FLAG NQ 0 THEN # CONVERSION ERROR # BEGIN RETURN; END LBARG$ZF[0] = TEMPR; # RESET *ZF* # END ELSE BEGIN IF LBARG$ZF[0] EQ 0 THEN # *ZF* OMITTED # BEGIN LBARG$ZF[0] = -1; # SET DEFAULT VALUE # END END # * CHECK THE VALUE OF *SB*. # IF LBARG$SB[0] NQ 0 THEN BEGIN FLAG = XDXB(LBARG$SB[0],TYPE,TEMPR); IF FLAG NQ 0 THEN # CONVERSION ERROR # BEGIN RETURN; END LBARG$SB[0] = TEMPR; # RESET *SB* # END # * CHECK *CN* AND *PK*. # IF LBARG$C[0] EQ 0 AND LBARG$PK[0] EQ 0 THEN BEGIN LBARG$PK[0] = "P"; END # * CHECK *PT*. # IF LBARG$PT[0] EQ 0 THEN BEGIN LBARG$PT[0] = "P"; END # * CHECK *SM*. # IF LBARG$SM[0] EQ 0 THEN BEGIN LBARG$SM[0] = "A"; END RETURN; END # LBCONV # TERM PROC LBERR((ERR$CODE)); # TITLE LBERR - *SSLABEL* ERROR PROCESSOR. # BEGIN # LBERR # # ** LBERR - *SSLABEL* ERROR PROCESSOR. * * THIS PROCEDURE DOES ERROR PROCESSING FOR *SSLABEL* IN * ACCORDANCE WITH THE VALUE OF THE ERROR CODE. * * PROC LBERR((ERR$CODE)) * * ENTRY ERR$CODE = STATUS ITEM INDICATING THE ERROR CODE. * * EXIT ERROR PROCESSING IS COMPLETED. DEPENDING ON ERROR * TYPE, EITHER A RETURN OR AN ABORT OCCURS. * * MESSAGES SEE ARRAY *ERRMSG* FOR THE * DAYFILE MESSAGES. * * NOTES PROC *LBERR* IS A TABLE DRIVEN * ERROR PROCESSOR. A TABLE HAS BEEN * PRESET WITH THE ERROR MESSAGES FOR THE * DIFFERENT ERROR CODES. THE ERROR CODE * CORRESPONDS TO THE ORDINAL OF THE CORRE- * SPONDING ENTRY IN THE TABLE. THE ACTION * TO BE TAKEN ON EACH ERROR CONDITION IS * PRESET AS STATUS VALUES INTO EACH ENTRY. * USING THE ERROR CODE THE CORRESPONDING * ENTRY IN THE TABLE IS FOUND AND THE ERROR * CONDITION IS PROCESSED BY USING A STATUS * SWITCH THAT CORRESPONDS TO THE STATUS * VALUES PRESET IN THE ENTRY. THE MESSAGES * ARE PRINTED OUT IN THE DAYFILE AND ALSO * ON THE REPORT FILE IF ONE IS SPECIFIED. # ITEM ERR$CODE U; # ERROR CODE # # **** PROC LBERR - XREF LIST BEGIN. # XREF BEGIN PROC MESSAGE; # WRITES USER DAYFILE MESSAGE # PROC RESTPFP; # RESTORE USER-S *PFP* AND ABORT OR RETURN # PROC RPCLOSE; # CLOSES OUTPUT PRINT FILE # PROC RPLINE; # WRITES PRINT LINE FOR REPORT # PROC RPSPACE; # WRITES BLANK LINE ON REPORT # FUNC XCDD C(10); # CONVERT ITEMS TO DISPLAY CODE # END # **** PROC LBERR - XREF LIST END. # DEF PROCNAME #"LBERR."#; # PROC NAME # STATUS ACTION # ERROR PROCESSING TO BE DONE # MSG, # DISPLAY ERROR MESSAGE # MSGDETL, # DISPLAY DETAIL ERROR MESSAGE # RETRN, # RETURN TO MAIN LOOP # ABRT, # ABORT SSLABEL # LSTACT; # END OF STATUS LIST # DEF LISTCON #0#; # DO NOT LIST THE COMDECKS # *CALL COMBFAS *CALL COMTERR *CALL COMTLAB *CALL COMTLBP *CALL COMTOUT ITEM DIS$ASN C(20); # CUBES ASSIGNED (DISPLAY CODE) # ITEM DIS$ERR C(20); # ERROR CODE (DISPLAY CODE) # ITEM I I; # LOOP VARIABLE # ITEM STAT U; # ERROR TABLE ENTRY STATUS # # * THIS ARRAY IS FOR DISPLAYING DETAILED MESSAGES. # ARRAY DETAIL [0:0] P(5); # FOR MESSAGES WITH DETAIL NO. # BEGIN ITEM DET$MSG1 C(00,00,40); # ERROR MESSAGE # ITEM DET$NO C(02,00,05); # DETAIL NUMBER # ITEM DET$PRD C(02,30,01); # PERIOD AT END OF MESSAGE # ITEM DET$BLNK C(02,36,14); # BLANK FILL # ITEM DET$ZRO U(04,00,60) = [0]; # ZERO BYTE TERMINATOR # END # * THIS ARRAY IS FOR DISPLAYING DIRECTIVE NUMBERS. # ARRAY DIRECTV [0:0] P(2); BEGIN ITEM DIR$MSG C(00,00,11) = [" DIRECTIVE "]; ITEM DIR$NO C(01,06,03); # DIRECTIVE NUMBER # ITEM DIR$PRD C(01,24,01); # ENDING PERIOD # ITEM DIRZRO U(01,30,30) = [0]; # ZERO BYTE # END # * ARRAY ERRMSG IS AN ERROR TABLE IN WHICH THE ORDINAL OF EACH * ENTRY IS EQUAL TO THE ERROR CODE IT REPRESENTS. EACH ENTRY * CONTAINS THE APPROPRIATE ERROR MESSAGE AND THE STATUS VALUES * WHICH CONTROL ERROR PROCESSING. # ARRAY ERRMSG [0:CODEMAX] S(6); BEGIN ITEM ERRMSSG C(00,00,40) = [ # MESSAGE ENTRY TO BE DISPLAYED # " CATALOG/MAP ATTACH PROBLEM.", " SYNTAX ERROR IN DIRECTIVE.", " SYNTAX ERROR - SSLABEL ABORT.", " CSN NOT FOUND IN SMMAP.", " NO EMPTY CUBE IN FAMILY/POOL.", " NO CARTRIDGE AVAILABLE IN POOL.", " NO EMPTY CARTRIDGES AVAILABLE IN FAMILY.", " NO MANUFACTURER OR SCRATCH LABEL.", " UNEXPECTED SM, Y, Z, FAMILY OR SUBFAM.", " CANNOT FIX CSN FOR GOOD LABEL.", " UNRECOVERABLE READ ERROR.", " UNRECOVERABLE WRITE ERROR.", " EXCESSIVE PARITY ERRORS.", " CSN ALREADY IN SMMAP.", " CARTRIDGE ALREADY IN CUBE.", " CARTRIDGE LABEL ERROR.", " CARTRIDGE ALREADY IN USE.", " STORAGE MODULE IS TURNED OFF.", " CARTRIDGE NOT FOUND.", " CARTRIDGE NOT EMPTY.", " M860 HARDWARE PROBLEM.", " CATALOG/MAP FILE INTERLOCKED.", " NO SUCH SMMAP OR SUBCATALOG.", " CATALOG/MAP NOT OPEN.", " CATALOG LOST BIT MUST BE SET.", " CARTRIDGE PRESENT--LOST BIT SET.", " SUB ALREADY DEFINED.", " CUBES ASSIGNED TO SUB-FAMILY.", " INSUFFICIENT CUBES.", " SELECTED CUBE NOT UNASSIGNED.", " NO EMPTY CUBES.", " SELECTED CUBE NOT EMPTY.", " SELECTED CUBE NOT ASSIGNED AS EXPECTED.", " CARTRIDGE NOT ASSIGNED AS EXPECTED.", " UNRECOGNIZABLE LABEL.", " NO MATCH ON FAMILY/SUBFAMILY.", " INCORRECT CSN.", " ADDCUBE - ONLY 100 LOCATIONS PROCESSED.", " INCORRECT N.", " CSN OPTION VIOLATED.", " PK,PT OPTION VIOLATED.", " LT OPTION NOT SPECIFIED CORRECTLY.", " INCORRECT SM NUMBER.", " Y,Z OPTION VIOLATED.", " INCORRECT SUBFAMILY.", " ON,OF NOT SPECIFIED CORRECTLY.", " INCORRECT DIRECTIVE.", " GR PARAMETER USED INCORRECTLY.", " GR PARAMETER OUT OF RANGE.", " B PARAMETER USED INCORRECTLY.", " B PARAMETER OUT OF RANGE.", " NO EMPTY CARTRIDGES IN GROUP." ]; ITEM ERRZERO U(04,00,60) = [0, CODEMAX(0)]; ITEM ERRSTATW U(05,00,60); # PROCESSING TO BE DONE # # * TYPE OF MESSAGE TO BE PRINTED. # ITEM ERRSTAT1 S:ACTION (05,00,06) = [ 4(S"MSG"), 3(S"MSGDETL"), 11(S"MSG"), 1(S"MSGDETL"), 9(S"MSG"), 5(S"MSGDETL"), 15(S"MSG"), 5(S"MSGDETL") ]; # * ACTION TO BE TAKEN AFTER PRINTING MESSAGE. # ITEM ERRSTAT2 S:ACTION (05,06,06) = [ S"ABRT", S"RETRN", 35(S"ABRT"), 15(S"RETRN"), 1(S"ABRT") ]; END # * ARRAY TO PRINT DAYFILE MESSAGE. # ARRAY MSGBUF [0:0] P(3); BEGIN ITEM MSG$ID C(00,00,15) = [" SSLABEL ERROR "]; ITEM MSG$NO C(01,30,03); # ERROR NUMBER DISPLAYED # ITEM MSGPRD C(01,48,01) = ["."]; ITEM MSGZERO U(02,48,12) = [0]; # ZERO BYTE TERMINATOR # END SWITCH ACT: ACTION # TYPE OF ERROR PROCESSING # REPORT: MSG, # DISPLAY ERROR MESSAGE # DETL$RPT: MSGDETL, # DISPLAY DETAIL ERROR MESSAGE # RTURN: RETRN, # RETURN TO MAIN LOOP # ABT: ABRT; # ABORT *SSLABEL* # CONTROL EJECT; # * CHECK FOR LEGAL ERROR CODE. # IF ERR$CODE LS 0 OR ERR$CODE GR CODEMAX THEN # ERROR CODE OUT OF RANGE # BEGIN LBMSG$PROC[0] = PROCNAME; MESSAGE(LBMSG[0],SYSUDF1); RESTPFP(PFP$ABORT); # RESTORE USER-S *PFP* AND ABORT # END DIR$NO[0] = LBARG$DIRN[0]; DIR$PRD = "."; DIS$ERR = XCDD(ERR$CODE); MSG$NO[0] = C<7,3>DIS$ERR; # * BEAD OUT STATUS VALUES FROM ERROR CODE ENTRY, AND DO * CORRESPONDING PROCESSING. # SLOWFOR I = 0 STEP 6 UNTIL 12 DO BEGIN STAT = BERRSTATW[ERR$CODE]; GOTO ACT[STAT]; REPORT: # REPORT THE ERROR # MESSAGE(ERRMSG[ERR$CODE],SYSUDF1); IF ERR$CODE NQ ERRLIST"SYNTX$ABRT" THEN BEGIN MESSAGE(MSGBUF[0],UDFL1); MESSAGE(DIRECTV[0],UDFL1); RPLINE(OUT$FETP,"*** ERROR",2,9,1); RPLINE(OUT$FETP,MSG$NO[0],12,3,1); RPLINE(OUT$FETP,"DIRECTIVE",19,9,1); RPLINE(OUT$FETP,DIR$NO[0],29,3,0); RPLINE(OUT$FETP,ERRMSSG[ERR$CODE],18,40,1); RPLINE(OUT$FETP,"***",58,3,0); RPSPACE(OUT$FETP,SP"SPACE",1); END TEST I; DETL$RPT: # REPORT THE ERROR IN DETAIL # DIS$ASN = XCDD(NUMDONE); DET$MSG1[0] = ERRMSSG[ERR$CODE]; MESSAGE(MSGBUF[0],UDFL1); MESSAGE(DIRECTV[0],UDFL1); MESSAGE(DETAIL[0],SYSUDF1); DET$MSG1[0] = " NUMBER PROCESSED = "; DET$BLNK[0] = " "; DET$NO[0] = C<5,5>DIS$ASN; DET$PRD[0] = "."; # ADD PERIOD TO END OF MESSAGE # MESSAGE(DETAIL,SYSUDF1); RPLINE(OUT$FETP,"*** ERROR",2,9,1); RPLINE(OUT$FETP,MSG$NO[0],12,3,1); RPLINE(OUT$FETP,"DIRECTIVE",19,9,1); RPLINE(OUT$FETP,DIR$NO[0],29,3,0); RPLINE(OUT$FETP,ERRMSSG[ERR$CODE],18,40,0); RPLINE(OUT$FETP,"NUMBER PROCESSED = ",19,19,1); RPLINE(OUT$FETP,DET$NO[0],38,5,1); RPLINE(OUT$FETP,"***",45,3,0); RPSPACE(OUT$FETP,SP"SPACE",1); TEST I; RTURN: # RETURN TO CALLING PROC # RETURN; ABT: # ABORT PROCESSING # RPCLOSE(OUT$FETP); RESTPFP(PFP$ABORT); # RESTORE USER-S *PFP* AND ABORT # END END # LBERR # TERM PROC LBFLMSC; # TITLE LBFLMSC - MODIFIES THE *INHIBIT* FLAG IN THE FCT. # BEGIN # LBFLMSC # # ** LBFLMSC - MODIFIES THE *INHIBIT* FLAG IN THE FCT. * * THIS PROC UPDATES THE *INHIBIT* FLAG IN THE FCT ENTRY * CORRESPONDING TO THE CSN SPECIFIED. * * PROC LBFLMSC. * * ENTRY CRACKED AND SYNTAX CHECKED DIRECTIVE * PARAMETERS SET UP IN COMMON AREA DEFINED * IN *COMTLBP*. * * EXIT *INHIBIT* FLAG UPDATED OR ERROR CONDITION. * * NOTES PROC *LBFLMSC* SEARCHES THE SMMAP FOR AN ENTRY * WITH A CSN MATCHING THAT SPECIFIED. IF THIS IS * FOUND AND IT IS ASSIGNED TO A FAMILY, THEN THE * *INHIBIT* FLAG IN THE CORRESPONDING *FCT* ENTRY * OR THE FREE CARTRIDGE FLAG IN THE *FCT* IS * MODIFIED. IF *ON* IS SPECIFIED THE FLAG IS SET, * AND IF *OFF* IS SPECIFIED THE FLAG IS CLEARED. # # **** PROC LBFLMSC - XREF LIST BEGIN. # XREF BEGIN PROC CALL3; # ISSUES TYPE 3 CALLSS TO EXEC # PROC LBERR; # *SSLABEL* ERROR PROCESSOR # PROC LBRESP; # RESPONSE CODE PROCESSOR # PROC SERCSU; # SEARCHES THE SMMAP # END # **** PROC LBFLMSC - XREF LIST END. # DEF LISTCON #0#; # DO NOT LIST COMDECKS # *CALL COMBFAS *CALL COMBCPR *CALL COMBMAP *CALL COMTERR *CALL COMTLAB *CALL COMTLBP ITEM CATFLD U; # CATALOG FIELD # ITEM CATVALUE I; # CATALOG VALUE # ITEM FLAG I; # ERROR FLAG # ITEM REQCODE U; # REQUEST CODE # ITEM RESP$CODE U; # RESPONSE CODE FROM EXEC # ITEM SERTYPE S:SERCH$TYPE; # SEARCH TYPE # ITEM SP$VSN C(12); # SPECIFIED CSN # ARRAY PT$CSU$ENT [0:0] P(5); # *PUT* SMMAP ENTRY # BEGIN ITEM PT$MAPENT C(00,00,30); # THREE WORD MAP ENTRY # ITEM PT$Y U(03,00,30); # Y COORDINATE # ITEM PT$Z U(03,30,30); # Z COORDINATE # ITEM PT$GR U(04,00,07); # GROUP # ITEM PT$GRT U(04,07,04); # GROUP ORDINAL # END CONTROL EJECT; SERTYPE = S"CSN$MATCH"; SP$VSN = LBARG$C[0]; # * SEARCH FOR MATCHING VSN. # SERCSU(SERTYPE,0,0,0,SP$VSN,0,0,PT$CSU$ENT[0],FLAG); IF FLAG NQ 0 THEN # VSN NOT FOUND # BEGIN ERRCODE = S"CSN$NOTFND"; LBERR(ERRCODE); # DO ERROR PROCESSING # RETURN; END # * CHECK CARTRIDGE ASSIGNMENT. # P = LOC(PT$CSU$ENT[0]); IF CM$CODE NQ CUBSTAT"SUBFAM" THEN # NOT ASSIGNED TO FAMILY # BEGIN ERRCODE = S"UNX$CR$ASN"; LBERR(ERRCODE); # DO ERROR PROCESSING # RETURN; END # * ISSUE A REQUEST TO EXEC TO UPDATE THE CATALOG *INHIBIT* FLAG. # IF LBARG$ON[0] NQ 0 THEN # *ON* SPECIFIED # BEGIN CATVALUE = 1; END ELSE BEGIN IF LBARG$OF[0] NQ 0 THEN # *OFF* SPECIFIED # BEGIN CATVALUE = 0; END END REQCODE = REQTYP3"UPD$CAT"; IF LBARG$OP[0] EQ "FC" THEN # FREE CARTRIDGE # BEGIN CATFLD = UCF"FREEFL"; END ELSE # INHIBIT ALLOCATION # BEGIN CATFLD = UCF"INHIB"; END # * UPDATE CATALOG. # CALL3(REQCODE,PT$CSU$ENT[0],CATFLD,CATVALUE,RESP$CODE); IF RESP$CODE NQ RESPTYP3"OK3" THEN # UPDATE UNSUCCESSFUL # BEGIN LBRESP(RESP$CODE,TYP"TYP3"); END RETURN; END # LBFLMSC # TERM PROC LBFXVSN; # TITLE LBFXVSN - REPLACES LABEL WITH SCRATCH LABEL. # BEGIN # LBFXVSN # # ** LBFXVSN - REPLACES LABEL WITH A SCRATCH LABEL. * * THIS PROC GETS A CARTRIDGE FROM THE INPUT DRAWER, WRITES A * SCRATCH LABEL ON IT, AND ADDS IT TO THE POOL. * * PROC LBFXVSN. * * ENTRY CRACKED AND SYNTAX CHECKED DIRECTIVE * PARAMETERS SET UP IN COMMON AREA DEFINED * IN *COMTLBP*. * * EXIT CARTRIDGE IN SCRATCH POOL OR ERROR CONDITION. * * NOTES PROC *LBFXVSN* VERIFIES THE PRESENCE OF A CARTRIDGE * IN THE INPUT DRAWER, AND SEARCHES FOR AN * EMPTY CUBE IN THE POOL. EXEC IS CALLED TO BRING * THE CARTRIDGE TO A DRIVE AND READ ITS LABEL. IF * THE LABEL TYPE AGREES WITH THAT SPECIFIED, A NEW * SCRATCH LABEL IS WRITTEN AND THE CARTRIDGE IS ADDED * TO THE POOL. # # **** PROC LBFXVSN - XREF LIST BEGIN. # XREF BEGIN PROC CALL3; # ISSUES TYPE 3 CALLSS TO EXEC # PROC CALL4; # ISSUES TYPE 4 CALLSS TO EXEC # PROC CKLAB; # CHECKS CARTRIDGE LABEL TYPE # PROC CONVSN; # CONVERTS VSN FROM EBCDIC TO DISPLAY CODE # PROC DCEBC; # CONVERTS DISPLAY TO EBCDIC # PROC DLABFLD; # DISPLAY LABEL FIELDS # PROC GENLAB; # GENERATES A NEW LABEL # PROC LBERR; # *SSLABEL* ERROR PROCESSOR # PROC LBRESP; # RESPONSE CODE PROCESSOR # PROC SERCSU; # SEARCHES THE SMMAP # END # **** PROC LBFXVSN - XREF LIST END. # DEF LISTCON #0#; # DO NOT LIST COMDECKS # *CALL COMBFAS *CALL COMBCPR *CALL COMBLBL *CALL COMBMAP *CALL COMTERR *CALL COMTLAB *CALL COMTLBP ITEM CART$CSN C(20); # CARTRIDGE SERIAL NUMBER # ITEM CONFLAG B; # CONVERSION FLAG # ITEM DC$VSN C(8); # *CSN* IN DISPLAY CODE # ITEM ERR$CNT I; # ERROR COUNT # ITEM FLAG I; # ERROR FLAG # ITEM HR$ERR I; # HARD READ ERRORS # ITEM I I; # LOOP VARIABLE # ITEM LAB$TYPE S:LABTYPE; # LABEL TYPE # ITEM LD$CNT I; # LOAD COUNT # ITEM LD$ERR I; # LOAD ERRORS # ITEM PS$CNT I; # PASS COUNT # ITEM REQCODE I; # REQUEST CODE # ITEM RESP$CODE I; # RESPONSE CODE # ITEM SERTYPE S:SERCH$TYPE; # SEARCH TYPE # ITEM SP$CODE I; # SPECIFIED CODE # ITEM SP$FAM C(7); # SPECIFIED FAMILY # ITEM SP$SUB I; # SUBFAMILY # ITEM SP$VSN C(8); # SPECIFIED CARTRIDGE *CSND* # ITEM SP$Y I; # SPECIFIED Y COORDINATE # ITEM SP$Z I; # SPECIFIED Z COORDINATE # ITEM SR$ERR I; # SOFT READ ERRORS # ITEM STR$RD I; # STRIPES READ # ITEM STR$WR I; # STRIPES WRITTEN # ITEM STR$DM I; # STRIPES DEMARKED # ITEM SW$ERR I; # SOFT WRITE ERRORS # ITEM TEMP$VSN C(8); # TEMPORARY *CSN* # ARRAY PT$CSU$ENT [0:0] P(5); # *PUT* SMMAP ENTRY # BEGIN ITEM PT$MAPENT C(00,00,30); # THREE WORD MAP ENTRY # ITEM PT$Y U(03,00,30); # Y COORDINATE # ITEM PT$Z U(03,30,30); # Z COORDINATE # ITEM PT$GR U(04,00,07); # GROUP # ITEM PT$GRT U(04,07,04); # GROUP ORDINAL # END CONTROL EJECT; # * CHECK IF SPECIFIED *CSN* IS ALREADY IN MAP. # SERTYPE = S"CSN$MATCH"; # SEARCH FOR *CSN* # SERCSU(SERTYPE,0,0,0,LBARG$C[0],0,0,PT$CSU$ENT[0],FLAG); IF FLAG EQ 0 # *CSN* ALREADY IN MAP # THEN BEGIN ERRCODE = S"DUPL$CSN"; LBERR(ERRCODE); RETURN; END # * CHECK THAT CARTRIDGE IS PRESENT IN INPUT DRAWER AND SEARCH * SMMAP FOR EMPTY CUBE IN THE POOL. # SERTYPE = S"ASSIGN"; SP$CODE = CUBSTAT"SCRPOOL"; SP$FAM = " "; SP$SUB = 0; SP$VSN = " "; SERCSU(SERTYPE,0,0,SP$CODE,SP$VSN,SP$FAM,SP$SUB,PT$CSU$ENT[0], FLAG); IF FLAG NQ 0 THEN # NO EMPTY CUBE IN POOL # BEGIN ERRCODE = S"NO$EMPCBFP"; LBERR(ERRCODE); # DO ERROR PROCESSING # RETURN; END # * LOAD CARTRIDGE FROM INPUT DRAWER. # SP$Y = 14; SP$Z = 0; REQCODE = REQTYP4"LOAD$CART"; CALL4(REQCODE,DRD$NUM,0,SP$Y,SP$Z,RESP$CODE); IF RESP$CODE NQ 0 THEN # *LOAD* FAILS # BEGIN LBRESP(RESP$CODE,TYP"TYP4"); RETURN; END DRD$NUM = CPR$DRD[0]; # TRANSPORT ID # P = OLDLABP; CKLAB(LAB$TYPE); # CHECK LABEL TYPE # IF LAB$TYPE EQ S"UNR$LAB" THEN BEGIN # UNRECOGNIZABLE LABEL # IF LBARG$ZFM[0] EQ 0 THEN # FAMILY NOT SPECIFIED # BEGIN LD$CNT = 0; SW$ERR = 0; SR$ERR = 0; HR$ERR = 0; STR$RD = 0; STR$WR = 0; STR$DM = 0; END ELSE # FAMILY SPECIFIED # BEGIN REQCODE = REQTYP4"UNLD$CART"; CALL4(REQCODE,0,0,SM$EXIT$TY,SM$TY$Z,RESP$CODE); IF RESP$CODE NQ RESPTYP4"OK4" THEN BEGIN LBRESP(RESP$CODE,TYP"TYP4"); RETURN; END ERRCODE = S"UNREC$LAB"; LBERR(ERRCODE); RETURN; END END # UNRECOGNIZABLE LABEL # ELSE BEGIN # RECOGNIZABLE LABEL # IF LBARG$ZFM[0] NQ 0 THEN BEGIN # FAMILY SPECIFIED # IF LAB$TYPE EQ S"FAM$LAB" AND LAB$FMLY[0] EQ LBARG$FM[0] AND LAB$SF[0] EQ LBARG$SB[0] THEN # MATCHING FAMILY LABEL # BEGIN LD$CNT = LAB$CRLD[0]; LD$ERR = LAB$LDER[0]; SR$ERR = LAB$SRDE[0]; SW$ERR = LAB$SWRE1[0]; B<28,4>SW$ERR = LAB$SWRE[0]; HR$ERR = LAB$HRDE[0]; STR$RD = LAB$STRD[0]; STR$WR = LAB$STWR1[0]; B<36,24>STR$WR = LAB$STWR[0]; STR$DM = LAB$STDM[0]; END ELSE # NO MATCHING FAMILY LABEL # BEGIN DLABFLD; # DISPLAY LABEL FIELDS # REQCODE = REQTYP4"UNLD$CART"; CALL4(REQCODE,0,0,SM$EXIT$TY,SM$TY$Z,RESP$CODE); IF RESP$CODE NQ RESPTYP4"OK4" THEN BEGIN LBRESP(RESP$CODE,TYP"TYP4"); RETURN; END ERRCODE = S"NO$FAMLAB"; LBERR(ERRCODE); RETURN; END END # FAMILY SPECIFIED # ELSE BEGIN # FAMILY NOT SPECIFIED # IF LAB$TYPE EQ S"SCR$LAB" THEN # SCRATCH LABEL # BEGIN LD$CNT = LAB$CRLD[0]; LD$ERR = LAB$LDER[0]; SR$ERR = LAB$SRDE[0]; SW$ERR = LAB$SWRE1[0]; B<28,4>SW$ERR = LAB$SWRE[0]; HR$ERR = LAB$HRDE[0]; STR$RD = LAB$STRD[0]; STR$WR = LAB$STWR1[0]; B<36,24>STR$WR = LAB$STWR[0]; STR$DM = LAB$STDM[0]; END ELSE # FAMILY LABEL # BEGIN REQCODE = REQTYP4"UNLD$CART"; CALL4(REQCODE,0,0,SM$EXIT$TY,SM$TY$Z,RESP$CODE); IF RESP$CODE NQ RESPTYP4"OK4" THEN BEGIN LBRESP(RESP$CODE,TYP"TYP4"); RETURN; END DLABFLD; ERRCODE = S"GOOD$LAB"; LBERR(ERRCODE); RETURN; END END # FAMILY NOT SPECIFIED # END # RECOGNIZABLE LABEL # LAB$TYPE = S"FAM$LAB"; # * CHECK *CSN* PARAMETER FOR MATCH. # CONVSN(TEMP$VSN,1,CONFLAG); IF LBARG$C[0] NQ TEMP$VSN THEN # NO MATCH OF *CSN* # BEGIN ERRCODE = S"ILLEG$C"; LBERR(ERRCODE); RETURN; END # * CONVERT VSN FROM DISPLAY CODE TO EBCDIC. # DC$VSN = LBARG$C[0]; CONVSN(DC$VSN,0,CONFLAG); IF CONFLAG THEN # ILLEGAL CDC CHARACTER # BEGIN ERRCODE = S"ILLEG$C"; LBERR(ERRCODE); RETURN; END # * GENERATE NEW LABEL. # LAB$TYPE = S"SCR$LAB"; GENLAB(LAB$TYPE,PT$CSU$ENT[0],LD$CNT,LD$ERR, SR$ERR,SW$ERR, HR$ERR); IF LBARG$CM[0] NQ IBMCART THEN # CARTRIDGE NOT IBM # BEGIN LAB$CCOD[0] = OTHCART; END ELSE BEGIN LAB$CCOD[0] = IBMCART; END IF LBARG$CM[0] EQ IBMCART THEN # WRITE IBM ON CARTRIDGE # BEGIN B<0,32>LAB$CSN[0] = O"31160552100"; END # NOTE: IF CM EQ B- THEN DO CONVERSION # REQCODE = REQTYP4"WRT$LAB"; CALL4(REQCODE,DRD$NUM,CART$CSN,PT$Y[0],PT$Z[0],RESP$CODE); IF RESP$CODE NQ RESPTYP4"OK4" THEN # WRITE FAILS # BEGIN LBRESP(RESP$CODE,TYP"TYP4"); RETURN; END # * UPDATE SMMAP TO ADD CARTRIDGE TO POOL. # REQCODE = REQTYP3"UPD$MAP"; P = LOC(PT$CSU$ENT[0]); CM$CSND[0] = LBARG$C[0]; CM$CCOD[0] = LAB$CCOD; CALL3(REQCODE,PT$CSU$ENT[0],0,0,RESP$CODE); IF RESP$CODE NQ RESPTYP3"OK3" THEN # UPDATE FAILS # BEGIN LBRESP(RESP$CODE,TYP"TYP3"); RETURN; END # WHICH ERROR CODE # IF RESP$CODE NQ RESPTYP4"OK4" THEN # PUT FAILS # BEGIN LBRESP(RESP$CODE,TYP"TYP4"); END RETURN; END # LBFXVSN # TERM PROC LBHEAD((FETP)); # TITLE LBHEAD - WRITES HEADER LINE ON OUTPUT FILE. # BEGIN # LBHEAD # # ** LBHEAD - WRITES HEADER LINE ON OUTPUT FILE. * * PROC LBHEAD((FETP)) * * ENTRY FETP, AN ITEM CONTAINING THE FWA OF THE FET. * * EXIT HEADER WRITTEN ON OUTPUT FILE. * * NOTES THE REPORT FORMATTER IS USED TO * PRINT THE HEADER LINES. # ITEM FETP I; # FWA OF THE FET # # **** PROC LBHEAD - XREF LIST BEGIN. # XREF BEGIN PROC RPLINEX; # PRINTS A REPORT LINE # END # **** PROC LBHEAD - XREF LIST END. # DEF LISTCON #0#; # DO NOT LIST COMDECKS # *CALL COMBFAS *CALL COMTOUT CONTROL EJECT; # * PRINT HEADER LINE. # RPLINEX(FETP,"SSLABEL REPORT FILE",2,19,0); RPLINEX(FETP," ",1,1,0); # WRITE A BLANK LINE # RETURN; END # LBHEAD # TERM PROC LBLOOP((ARGLIST),ERRFLAG); # TITLE LBLOOP - CRACK AND SYNTAX CHECK *SSLABEL* DIRECTIVES. # BEGIN # LBLOOP # # ** LBLOOP - CRACK AND SYNTAX CHECK *SSLABEL* DIRECTIVES. * * THIS PROCEDURE CRACKS AND SYNTAX CHECKS THE * PARAMETERS SPECIFIED ON *SSLABEL* DIRECTIVE * CALL. * * PROC LBLOOP((ARGLIST),ERRFLAG) * * ENTRY ARGLIST, AN ITEM CONTAINING THE ADDRESS * OF THE ARGUMENT LIST FOR *SSLABEL*. * * EXIT ALL THE DIRECTIVES CRACKED, SYNTAX CHECKED * AND WRITTEN ON A TEMPORARY FILE. * ERRFLAG, AN ITEM CONTAINING THE ERROR STATUS. * FALSE, NO ERROR. * TRUE, SYNTAX ERROR IN ONE OR MORE DIRECTIVES. * * MESSAGES SSLABEL - NO DIRECTIVES. * * NOTES PROC *LBLOOP* SETS UP A LOOP TO READ IN EACH * DIRECTIVE, CRACK THE DIRECTIVE, CONVERT THE CRACKED * PARAMETERS FROM DISPLAY CODE TO INTEGER VALUE * AND TO CHECK FOR THE VALID OPTIONS ON THE * DIRECTIVE CALL. THE CRACKED PARAMETERS ARE * RETURNED IN THE COMMON AREA *ULBPCOM* AND * AFTER CONVERSION ARE PLACED BACK IN THE * SAME LOCATIONS. IF AN ERROR IS ENCOUNTERED * WITH THE DIRECTIVE, A DIRECTIVE ERROR FLAG * IS SET UP. THE DIRECTIVE ALONG WITH THE * CRACKED AND CONVERTED PARAMETERS, DIRECTIVE * NUMBER AND THE DIRECTIVE ERROR STATUS FLAG * IS WRITTEN TO A TEMPORARY FILE. THE TEMPORARY * FILE HAS THE FOLLOWING FORMAT. * EACH DIRECTIVE HAS ITS IMAGE, NUMBER AND * ERROR STATUS AND THE CRACKED PARAMETERS * WRITTEN ON TO IT. IT CONSISTS OF * ONE LOGICAL RECORD FOLLOWED BY AN EOR. * A SYNTAX ERROR IS RETURNED TO THE CALLING * PROCEDURE IF AN ERROR IS ENCOUNTERED WITH * ANY DIRECTIVE. # ITEM ARGLIST I; # ADDRESS OF ARGUMENT LIST # ITEM ERRFLAG B; # ERROR FLAG # # **** PROC LBLOOP - XREF LIST BEGIN. # XREF BEGIN PROC BZFILL; # BLANK OR ZERO FILLS A BUFFER # PROC LBCONV; # CONVERT PARAMETERS TO INTEGERS # PROC LBERR; # *SSLABEL* ERROR PROCESSOR # PROC LBOPT; # CHECKS FOR VALID OPTIONS # PROC LOFPROC; # LIST OF FILES PROCESSOR # PROC MESSAGE; # DISPLAYS MESSAGES # PROC READC; # READS IN A CODED LINE # PROC RESTPFP; # RESTORE USER-S *PFP* AND ABORT OR RETURN # PROC RETERN; # RETURNS A FILE # PROC REWIND; # REWINDS A FILE # PROC RPLINE; # PRINTS A REPORT LINE # PROC RPSPACE; # PRINTS A BLANK LINE # PROC WRITER; # WRITES EOR ON A FILE # PROC WRITEW; # DATA TRANSFER ROUTINE # PROC XARG; # CRACK PARAMETER LIST # FUNC XCDD C(10); # CONVERT INTEGERS TO DISPLAY # PROC ZFILL; # ZERO FILLS A BUFFER # PROC ZSETFET; # SETS UP A CIO FET # END # **** PROC LBLOOP - XREF LIST END. # DEF WBUFL #8#; # LENGTH OF WORKING BUFFER # DEF LISTCON #0#; # DO NOT LIST THE COMDECKS # *CALL COMBFAS *CALL COMBBZF *CALL COMTERR *CALL COMTLAB *CALL COMTLBP *CALL COMTOUT ITEM BUFP I; # FIRST WORD ADDRESS OF BUFFER # ITEM COMMENT B = FALSE; # INDICATES A COMMENT # ITEM DIRNUM I; # DIRECTIVE NUMBER # ITEM EOR B = FALSE; # EOR STATUS ON A FILE # ITEM FETP I; # FIRST WORD ADDRESS OF FET # ITEM FLAG I; # ERROR FLAG # ITEM TEMP C(10); # TEMPORARY ITEM # ARRAY LBIN$WBUF [0:0] S(WBUFL); # WORKING BUFFER # BEGIN ITEM LBINW$DIR C(00,00,80); # *SSLABEL* DIRECTIVE IMAGE # END CONTROL EJECT; DIRNUM = 0; # INITIALIZE DIRECTIVE NUMBER # # * SET UP FET FOR TEMPORARY FILE. # FETP = LOC(SCR$FET[0]); BUFP = LOC(SCR$BUF[0]); ZSETFET(FETP,SCR,BUFP,BUFL,SFETL); LOFPROC(SCR); # ADD LFN TO LIST OF FILES # # * SET UP A LOOP TO * 1. READ A DIRECTIVE. * 2. CRACK THE DIRECTIVE. * 3. CONVERT PARAMETERS. * 4. CHECK FOR VALID OPTIONS. * 5. WRITE THE DIRECTIVE TO A TEMPORARY FILE. # RETERN(SCR$FET[0],RCL); # RETURN THE TEMPORARY FILE # FASTFOR DUMMY = 0 STEP 1 WHILE NOT EOR DO BEGIN # CRACK AND SYNTAX CHECK DIRECTIVES # ZFILL(LBIN$WBUF[0],WBUFL); # ZERO FILL WORKING BUFFER # READC(LBIN$FET[0],LBIN$WBUF[0],WBUFL,FLAG); IF FLAG NQ 0 THEN # NO MORE DIRECTIVES # BEGIN EOR = TRUE; TEST DUMMY; END # * CHECK FOR A COMMENT. # IF C<0,1>LBINW$DIR[0] EQ "*" THEN # A COMMENT # BEGIN COMMENT = TRUE; TEMP = " "; END ELSE # A DIRECTIVE # BEGIN COMMENT = FALSE; DIRNUM = DIRNUM + 1; TEMP = XCDD(DIRNUM); # WRITE DIRECTIVE NUMBER # TEMP = C<7,3>TEMP; END # * WRITE THE DIRECTIVE NUMBER AND THE DIRECTIVE * IMAGE TO THE OUTPUT FILE. # BZFILL(LBIN$WBUF[0],TYPFILL"BFILL",80); RPLINE(OUT$FETP,TEMP,2,5,1); RPLINE(OUT$FETP,LBINW$DIR[0],8,80,0); RPSPACE(OUT$FETP,SP"SPACE",1); IF COMMENT THEN BEGIN TEST DUMMY; # READ THE NEXT DIRECTIVE # END # * ZERO FILL THE AREA TO HOLD THE DIRECTIVE * IMAGE AND THE CRACKED PARAMETERS. # ZFILL(LBARG[0],DIRPRML); # * SET UP THE DIRECTIVE IMAGE AND THE DIRECTIVE * NUMBER IN THE AREA TO BE WRITTEN TO THE * TEMPORARY FILE. # LBARG$DIRN[0] = TEMP; LBARG$DIRI[0] = LBINW$DIR[0]; # DIRECTIVE IMAGE # # * CRACK THE DIRECTIVE. # LBARG$GR[0] = 7777; XARG(ARGLIST,LBIN$WBUF[0],FLAG); # OPTION IS *DO NOT SKIP OVER PROGRAM NAME* # IF FLAG NQ 0 THEN # SYNTAX ERROR # BEGIN LBARG$DIRF[0] = TRUE; # SET UP ERROR FLAGS # ERRFLAG = TRUE; END # * IF NO SYNTAX ERROR IN THE DIRECTIVE THEN CONVERT * THE PARAMETERS FROM DISPLAY CODE TO INTEGER VALUE. # IF NOT LBARG$DIRF[0] THEN # NO ERROR IN DIRECTIVE # BEGIN LBCONV(FLAG); # CONVERT PARAMETERS # IF FLAG NQ 0 THEN # CONVERSION ERROR # BEGIN LBARG$DIRF[0] = TRUE; # SET UP ERROR FLAGS # ERRFLAG = TRUE; END END # * IF AN ERROR IS FOUND IN THE DIRECTIVE, REPORT * IT ON THE OUTPUT FILE. # IF LBARG$DIRF[0] THEN # ERROR IN THE DIRECTIVE # BEGIN ERRCODE = S"SYNTX$DIR"; LBERR(ERRCODE); # PROCESS THE ERROR # END # * IF THERE IS NO ERROR IN THE DIRECTIVE, CHECK * FOR ALL THE VALID OPTIONS ON THE DIRECTIVE * CALL. # IF NOT LBARG$DIRF[0] THEN # CHECK FOR VALID OPTIONS # BEGIN LBOPT(FLAG); IF FLAG NQ 0 THEN # VALID OPTIONS VIOLATED # BEGIN LBARG$DIRF[0] = TRUE; # SET UP ERROR FLAGS # ERRFLAG = TRUE; END END # * WRITE THE DIRECTIVE IMAGE ALONG WITH THE DIRECTIVE * NUMBER, DIRECTIVE FLAG AND THE CRACKED PARAMETERS * ON THE TEMPORARY FILE. # WRITEW(SCR$FET[0],LBARG[0],DIRPRML,FLAG); END # CRACK AND SYNTAX CHECK DIRECTIVES # IF DIRNUM EQ 0 THEN # NO DIRECTIVES # BEGIN LBMSG$LINE[0] = " SSLABEL - NO DIRECTIVES."; MESSAGE(LBMSG$BUF[0],SYSUDF1); RESTPFP(PFP$ABORT); # RESTORE USER-S *PFP* AND ABORT # END WRITER(SCR$FET[0],NRCL); REWIND(SCR$FET[0],NRCL); RETURN; # ALL DIRECTIVES CRACKED # END # LBLOOP # TERM PROC LBMAIN; # TITLE LBMAIN - PROCESSES *SSLABEL* DIRECTIVES. # BEGIN # LBMAIN # # ** LBMAIN - PROCESSES *SSLABEL* DIRECTIVES. * * THIS PROCEDURE PROCESSES DIRECTIVES BY CALLING * THE APPROPRIATE DIRECTIVE ROUTINES. * * PROC LBMAIN. * * ENTRY THE TEMPORARY FILE SET UP WITH * THE DIRECTIVE IMAGES ALONG WITH THE * CRACKED PARAMETERS. * * EXIT ALL DIRECTIVES HAVE BEEN PROCESSED. * * MESSAGES FAMILY NOT FOUND. * * NOTES THE CRACKED PARAMETER FILE IS READ (UNTIL EOI) * INTO WORKING STORAGE. FOR EACH DIRECTIVE, THE * DIRECTIVE IMAGE IS WRITTEN ON THE OUTPUT FILE * AND THE SMMAP IS OPENED. IF THIS OPEN FAILS, * OR IF THE SYNTAX ERROR FLAG IS SET FOR THIS * DIRECTIVE, THEN THE ERROR PROCESSOR IS CALLED. * OTHERWISE THE CORRESPONDING DIRECTIVE ROUTINE * IS CALLED. # # **** PROC LBMAIN - XREF LIST BEGIN. # XREF BEGIN PROC SSINIT; # SET UP TABLES AND POINTERS # PROC LBADCSU; # ADD *SM* DIRECTIVE (AC) # PROC LBADCUB; # ADD CUBE (AB) # PROC LBADMSC; # ADD CARTRIDGE (AM) # PROC LBERR; # *SSLABEL* ERROR PROCESSOR # PROC LBFLMSC; # SET/CLEAR FCT INHIB FLAG (IB) # PROC LBFXVSN; # REPAIR LABEL (FX) # PROC LBRESP; # RESPONSE CODE PROCESSOR # PROC LBRMCSU; # REMOVE *SM* DIRECTIVE (RC) # PROC LBRMCUB; # REMOVE CUBE DIRECTIVE (RB) # PROC LBRMMSC; # REMOVE CARTRIDGE (RM) # PROC LBRSMSC; # RESTORE A CARTRIDGE (RS) # PROC LOFPROC; # LIST OF FILES PROCESSOR # PROC MESSAGE; # DISPLAYS MESSAGES # PROC MOPEN; # OPEN SMMAP # PROC READ; # CIO READ MACRO # PROC READW; # CIO READW MACRO # PROC RESTPFP; # RESTORE USER-S *PFP* AND ABORT OR RETURN # PROC RETERN; # RETURN MACRO # PROC RPLINE; # PRINT FORMATTER ROUTINE # PROC RPSPACE; # PRINTS BLANK LINES # PROC SETPFP; # SET FAMILY AND USER INDEX # END # **** PROC LBMAIN - XREF LIST END. # DEF MSG1 #" FAMILY NOT FOUND."#; DEF LISTCON #0#; # DO NOT LIST COMDECKS # *CALL COMBFAS *CALL COMBCMD *CALL COMBCMS *CALL COMBCPR *CALL COMBLBL *CALL COMBPFP *CALL COMBSNS *CALL COMSPFM *CALL COMTERR *CALL COMTLAB *CALL COMTLBP *CALL COMTOUT ITEM J I; # LOOP VARIABLE # ITEM MSTAT S:CMASTAT; # ERROR STATUS # ITEM RDWSTAT I = 0; # ERROR STATUS # ARRAY CMAP$NM [0:0] P(1); # BUILD SMMAP FILE NAME # BEGIN ITEM CMAP$NAME C(00,00,07); # SMMAP FILE NAME # ITEM CMAP$IN C(00,00,05); # FIRST 5 CHARACTERS # ITEM CMAP$ID C(00,30,01); # CSU-ID # ITEM CMAP$Z U(00,36,24) = [0]; # ZERO FILL FILE NAME # END ARRAY DRW$STAT [0:0] S(SNSLEN);; # DRAWER STATUS TABLE # # * BUFFERS TO HOLD THE OLD CARTRIDGE LABEL * AND THE NEW CARTRIDGE LABEL. # ARRAY OLDLABEL [0:0] S(LABLEN);; ARRAY NEWLABEL [0:0] S(LABLEN);; # * SWITCH TO PROCESS ALL THE *SSLABEL* * DIRECTIVES. THE ORDER OF THE SWITCH * LABELS IS THE SAME AS THE DIRECTIVE * NAMES SET UP IN ARRAY *DIR$NAME* * DEFINED IN *COMTLAB*. # SWITCH DIR$ACT # SWITCH TO PROCESS DIRECTIVES # ADDCUBE, # ADD CUBES TO A FAMILY OR POOL # ADDCSU, # ADD A *SM* TO FAMILY CATALOG # ADDMSC, # ADD CARTRIDGES TO FAMILY OR POOL # FIXVSN, # FIX A CARTRIDGE VSN # FLAGFRE, # TURN FREE FLAG ON OR OFF # FLAGMSC, # TURN A FLAG ON OR OFF # RMVCSU, # REMOVE A *SM* FROM FAMILY CATALOG # RMVCUBE, # REMOVE A CUBE FROM A FAMILY OR POOL # RMVMSC, # REMOVE CARTRIDGES FROM FAMILY OR POOL # RSTRMSC; # RESTORE A LOST CARTRIDGE # CONTROL EJECT; # * SET UP THE POINTERS OF THE BASED ARRAYS AND * THE ADDRESSES OF THE BUFFERS. # # DRAWER RELATED # OLDLABP = LOC(OLDLABEL[0]); NEWLABP = LOC(NEWLABEL[0]); CMAP$IN[0] = SMMAP; # * INITIALIZE THE FETS, BUFFERS ,TABLES AND * THE POINTERS FOR THE CATALOG AND THE MAP * ACCESS ROUTINES. # SSINIT; READ(SCR$FET[0],NRCL); # * READ EACH DIRECTIVE AREA FROM THE SCRATCH FILE. # REPEAT WHILE RDWSTAT EQ 0 DO BEGIN # PROCESS DIRECTIVES # READW(SCR$FET[0],LBARG[0],DIRPRML,RDWSTAT); IF RDWSTAT NQ 0 THEN # EOI REACHED # BEGIN TEST DUMMY; END # * WRITE DIRECTIVE NUMBER AND IMAGE TO OUTPUT FILE. # RPLINE(OUT$FETP,LBARG$DIRN[0],2,5,1); RPLINE(OUT$FETP,LBARG$DIRI[0],8,80,0); RPSPACE(OUT$FETP,SP"SPACE",1); IF LBARG$DIRF[0] THEN # CHECK SYNTAX ERROR FLAG # BEGIN RPLINE(OUT$FETP,"*** SYNTAX ERROR",2,16,0); TEST DUMMY; END # * IF *FM* IS NOT SPECIFIED, USE THE DEFAULT FAMILY. # IF (LBARG$ZFM[0] EQ 0 AND LBARG$OP[0] NQ "FX") ## OR LBARG$ZFM[0] EQ -1 THEN BEGIN LBARG$FM[0] = DEF$FAM; END PFP$WRD0[0] = 0; # SET FAMILY AND USER INDEX # PFP$FAM[0] = DEF$FAM; PFP$UI[0] = DEF$UI; PFP$FG1[0] = TRUE; PFP$FG4[0] = TRUE; SETPFP(PFP); IF PFP$STAT[0] NQ 0 THEN # FAMILY NOT FOUND # BEGIN LBMSG$LN[0] = MSG1; MESSAGE(LBMSG[0],SYSUDF1); RESTPFP(PFP$ABORT); # RESTORE USER-S *PFP* AND ABORT # END # * OPEN SMUMAP. # CMAP$ID[0] = LBARG$SM[0]; # SET UP THE *SM* ID # MOPEN(LBARG$SMID[0],CMAP$NAME[0],"RM",MSTAT); IF MSTAT EQ S"NOERR" THEN BEGIN LOFPROC(CMAP$NAME[0]); # ADD LFN TO LIST OF FILES # END PFP$UI[0] = DEF$UI + LBARG$SB[0]; PFP$FAM[0] = LBARG$FM[0]; SETPFP(PFP); IF PFP$STAT[0] NQ 0 AND LBARG$OP[0] NQ "FX" THEN # FAMILY NOT FOUND # BEGIN LBMSG$LN[0] = MSG1; MESSAGE(LBMSG[0],SYSUDF1); RESTPFP(PFP$ABORT); # RESTORE PFP # END # * IF THERE IS ANY ERROR OTHER THAN * *FILE ALREADY OPEN*, PROCESS THE * ERROR STATUS. # IF MSTAT NQ S"NOERR" AND MSTAT NQ S"FOPEN" THEN BEGIN LBRESP(MSTAT,0); TEST DUMMY; END # * PROCESS THE DIRECTIVE. # SLOWFOR J = 0 STEP 1 UNTIL 9 DO BEGIN IF DIR$NM[J] EQ LBARG$OP[0] THEN # FIND MATCHING DIRECTIVE # BEGIN GOTO DIR$ACT[J]; END END ADDCUBE: LBADCUB; TEST DUMMY; ADDCSU: # ADD *SM* TO FAMILY CATALOG # LBADCSU; TEST DUMMY; ADDMSC: # ADD CARTRIDGES TO FAMILY/POOL # LBADMSC; TEST DUMMY; FIXVSN: # FIX CARTRIDGE VSN # LBFXVSN; TEST DUMMY; FLAGFRE: # TURN FREE FLAG ON OR OFF # FLAGMSC: # TURN A FLAG ON OR OFF # LBFLMSC; TEST DUMMY; RMVCSU: # REMOVE *SM* FROM FAMILY CATALOG # LBRMCSU; TEST DUMMY; RMVCUBE: # REMOVE CUBE FROM FAMILY/POOL # LBRMCUB; TEST DUMMY; RMVMSC: # REMOVE FAMILY/POOL CARTRIDGES # LBRMMSC; TEST DUMMY; RSTRMSC: # RESTORE A LOST CARTRIDGE # LBRSMSC; TEST DUMMY; END # PROCESS DIRECTIVES # RETURN; END # LBMAIN # TERM PROC LBOPT(ERRFLAG); # TITLE LBOPT - TESTS FOR VALID *SSLABEL* DIRECTIVES. # BEGIN # LBOPT # # ** LBOPT - TESTS FOR VALID *SSLABEL* DIRECTIVE OPTIONS. * * THIS PROCEDURE CHECKS THE *SSLABEL* DIRECTIVE OPTIONS * SPECIFIED, AND IF AN INVALID OPTION IS FOUND THE * ERROR PROCESSOR IS CALLED WITH THE APPROPRIATE * ERROR CODE. * * PROC LBOPT(ERRFLAG) * * EXIT ALL THE VALID OPTIONS CHECKED OR A VALID * OPTION VIOLATED. * ERRFLAG, AN ITEM CONTAINING THE ERROR STATUS. * 0, NO ERROR. * 1, VALID OPTION VIOLATED. * * NOTES ALL DIRECTIVE OPTIONS ARE TESTED FOR INVALID VALUES. * THE VALID OPTIONS ON *SSLABEL* DIRECTIVE CALLS ARE * 1. *OP* MUST BE A LEGAL DIRECTIVE NAME. * 2. *N* MUST BE 1 IF *CN* IS SPECIFIED. * 3. *CN* MUST BE SPECIFIED WITH *RMVMSC* LOST * OPTION. * 4. *CN* MAY NOT BE SPECIFIED WHEN ANY *PK* * OPTION IS USED. * 5. *CN* MAY NOT BE SPECIFIED WITH *ADDCSU*, * *RMVCSU*, *ADDCUBE* AND *RMVCUBE* DIRECTIVES. * 6. VALID USES OF *PK* ARE * OP=AM - PK=D OR PK=P * OP=RM - PK=P OR PK=F * OP=RB - PK=P OR PK=F OR PK=R * PK=P MAY NOT BE SPECIFIED IF PT=P. * 7. PT=P CANNOT BE SPECIFIED WHEN OP=AM AND * *V* IS SPECIFIED. * 8. VALID USES OF *PT* ARE * OP=AM - PT=P OR PT=F * OP=RM - PT=D OR PT=P * OP=AB - PT=P OR PT=F OR PT=R * 9. VALID USES OF *D* ARE FOR PK=D, OP=RS OR * OP=FX. * 10. *GR* MUST BE BETWEEN 1 AND 20 AND IS * VALID ONLY WITH OP=AM AND OP=RM. * 11. *LS* IS VALID ONLY WITH OP=RM. * 12. *SM* MUST BE IN A TO M RANGE. * 13. *ON* OR *OF* CAN BE SPECIFIED ONLY FOR OP=IB. * 14. *YF* AND *ZF* MUST BOTH BE SPECIFIED IF * EITHER IS SPECIFIED. * 15. *YF* AND *ZF* CAN BE SPECIFIED ONLY IF BOTH * *YI* AND *ZI* ARE SPECIFIED. * 16. *YI* AND *YF* MUST BE BETWEEN 0 TO 21. * 17. *ZI* AND *ZF* MUST BE BETWEEN 0 TO 15. * 18. *YF* MUST BE GREATER THAN OR EQUAL TO * *YI* IF BOTH ARE SPECIFIED. * 19. *ZF* MUST BE GREATER THAN OR EQUAL TO * *ZI* IF BOTH ARE SPECIFIED. * 20. *SB* MUST BE FROM 0 TO 7. * 21. *B* IS VALID ONLY WITH OP=AB. IT MUST * 22. *CC* PARAMETER IS VALID ONLY WITH *AM*, MAY * NOT BE USED WITH ANY OTHER OPTIONS, AND CAN * ONLY BE EQUAL TO 0 OR 15. * BE BETWEEN 0 AND 1931. * ANY VIOLATION OF THE VALID OPTIONS CAUSES A * MESSAGE TO BE PRINTED ON THE REPORT FILE AND * IN THE DAYFILE AND AN ERROR STATUS IS RETURNED * TO THE CALLING PROCEDURE. PROC *LBERR* DOES * ALL THE ERROR PROCESSING. # ITEM ERRFLAG I; # ERROR STATUS # # **** PROC LBOPT - XREF LIST BEGIN. # XREF BEGIN PROC LBERR; # SSLABEL ERROR PROCESSOR # END # **** PROC LBOPT - XREF LIST END. # DEF LISTCON #0#; # DO NOT LIST COMDECKS # *CALL COMBFAS *CALL COMTERR *CALL COMTLAB *CALL COMTLBP ITEM FOUND B; # SEARCH FLAG # ITEM I I; # LOOP VARIABLE # CONTROL EJECT; ERRFLAG = 0; # * TEST SSLABEL DIRECTIVE OPTIONS AND CALL LBERR WITH APPROPRIATE * ERROR CODE IF ERRORS ARE FOUND. * CHECK FOR A LEGAL DIRECTIVE NAME. # FOUND = FALSE; SLOWFOR I = 0 STEP 1 UNTIL 9 DO BEGIN IF LBARG$OP[0] EQ DIR$NM[I] THEN BEGIN FOUND = TRUE; # LEGAL DIRECTIVE NAME # END END IF NOT FOUND THEN BEGIN ERRCODE = S"ILL$DIRCTV"; # "ILLEGAL DIRECTIVE" # LBERR(ERRCODE); ERRFLAG = 1; RETURN; END # * CHECK IF *N* HAS A LEGAL VALUE. # IF LBARG$N[0] LS 1 OR LBARG$N[0] GR 100 THEN BEGIN ERRCODE = S"ILL$N"; # "ILLEGAL N" # LBERR(ERRCODE); ERRFLAG = 1; RETURN; END # * CHECK FOR A LEGAL VALUE OF *PK*. # IF LBARG$PK[0] NQ "P" ## AND LBARG$PK[0] NQ "D" ## AND LBARG$PK[0] NQ "F" ## AND LBARG$PK[0] NQ "R" ## AND LBARG$PK[0] NQ 0 THEN BEGIN ERRCODE = S"PK$PT$VIOL"; # "PK,PT OPTION VIOLATED" # LBERR(ERRCODE); ERRFLAG = 1; RETURN; END # * CHECK FOR A LEGAL VALUE FOR *PT*. # IF LBARG$PT[0] NQ "P" ## AND LBARG$PT[0] NQ "D" ## AND LBARG$PT[0] NQ "F" ## AND LBARG$PT[0] NQ "R" THEN BEGIN ERRCODE = S"PK$PT$VIOL"; # "PK,PT OPTION VIOLATED" # LBERR(ERRCODE); ERRFLAG = 1; RETURN; END # * CHECK IF *CN* IS SPECIFIED CORRECTLY. # IF LBARG$C[0] NQ 0 ## AND (LBARG$OP[0] EQ "AS" OR LBARG$OP[0] EQ "RS" OR LBARG$OP[0] EQ "AB" ## OR LBARG$OP[0] EQ "RB") THEN BEGIN ERRCODE = S"CSN$VIOL"; # "VSN OPTION VIOLATED" # LBERR(ERRCODE); ERRFLAG = 1; RETURN; END # * CHECK IF *CM* PARAMETER IS SPECIFIED CORRECTLY. # IF (LBARG$CM[0] NQ IBMCART ## AND LBARG$C[0] NQ 0) ## OR LBARG$CM[0] NQ IBMCART THEN BEGIN ERRCODE = S"CSN$VIOL"; # *CSN* OPTION VIOLATED # LBERR(ERRCODE); ERRFLAG = 1; RETURN; END # * CHECK *N* OR *PK* IS SPECIFIED WHEN * *V* IS SPECIFIED. # IF LBARG$C[0] NQ 0 ## AND (LBARG$N[0] NQ 1 ## OR LBARG$PK[0] NQ 0) THEN BEGIN ERRCODE = S"CSN$VIOL"; # "VSN OPTION VIOLATED" # LBERR(ERRCODE); ERRFLAG = 1; RETURN; END # * CHECK IF *PT* IS SPECIFIED TO BE *P* * WHEN *V* IS SPECIFIED FOR *AM*. # IF LBARG$C[0] NQ 0 ## AND LBARG$OP[0] EQ "AM" ## AND LBARG$PT[0] EQ "P" THEN BEGIN ERRCODE = S"PK$PT$VIOL"; # "PK,PT OPTION VIOLATED" # LBERR(ERRCODE); ERRFLAG = 1; RETURN; END # * CHECK IF *PK* AND *PT* ARE SPECIFIED * CORRECTLY FOR *AM*. # IF LBARG$OP[0] EQ "AM" ## AND LBARG$CC[0] EQ -1 AND ((LBARG$PK[0] NQ 0 ## AND LBARG$PK[0] NQ "D" ## AND LBARG$PK[0] NQ "P") ## OR (LBARG$PT[0] NQ "P" ## AND LBARG$PT[0] NQ "F")) THEN BEGIN ERRCODE = S"PK$PT$VIOL"; # "PK,PT OPTION VIOLATED" # LBERR(ERRCODE); ERRFLAG = 1; RETURN; END # * CHECK IF *PK* AND *PT* ARE SPECIFIED * CORRECTLY FOR *RM*. # IF LBARG$OP[0] EQ "RM" ## AND ((LBARG$PK[0] NQ 0 ## AND LBARG$PK[0] NQ "P" ## AND LBARG$PK[0] NQ "F") ## OR (LBARG$PT[0] NQ "D" ## AND LBARG$PT[0] NQ "P")) THEN BEGIN ERRCODE = S"PK$PT$VIOL"; # "PK,PT OPTION VIOLATED" # LBERR(ERRCODE); ERRFLAG = 1; RETURN; END # * CHECK IF *PK* IS SPECIFIED CORRECTLY * FOR *RB*. # IF LBARG$OP[0] EQ "RB" ## AND (LBARG$PK[0] NQ "P" ## AND LBARG$PK[0] NQ "F" ## AND LBARG$PK[0] NQ "R") THEN BEGIN ERRCODE = S"PK$PT$VIOL"; # "PK,PT OPTION VIOLATED" # LBERR(ERRCODE); ERRFLAG = 1; RETURN; END # * CHECK IF *PK* AND *PT* ARE BOTH SPECIFIED * TO BE *P* FOR *AM* OR *RM*. # IF (LBARG$PK[0] EQ "P" ## AND LBARG$PT[0] EQ "P") ## AND LBARG$CC[0] EQ -1 ## AND (LBARG$OP[0] EQ "AM" ## OR LBARG$OP[0] EQ "RM") THEN BEGIN ERRCODE = S"PK$PT$VIOL"; # "PK,PT OPTION VIOLATED" # LBERR(ERRCODE); ERRFLAG = 1; RETURN; END # * CHECK IF *PT* IS SPECIFIED CORRECTLY FOR *AB*. # IF LBARG$OP[0] EQ "AB" ## AND ((LBARG$PT[0] EQ "D") ## OR (LBARG$N[0] NQ 1 ## AND LBARG$PT[0] EQ "R")) THEN BEGIN ERRCODE = S"PK$PT$VIOL"; # "PK,PT OPTION VIOLATED" # LBERR(ERRCODE); ERRFLAG = 1; RETURN; END # * CHECK IF *YI*, *ZI* OPTION IS SELECTED FOR *AB*. # IF LBARG$OP[0] EQ "AB" ## AND LBARG$PT[0] EQ "R" ## AND LBARG$YI[0] EQ -1 ## AND LBARG$ZI[0] EQ -1 THEN BEGIN ERRCODE = S"YZ$VIOL"; # "Y,Z OPTION VIOLATED" # LBERR(ERRCODE); ERRFLAG = 1; RETURN; END # * CHECK IF *YI*, *ZI* OPTION IS IMPROPERLY USED FOR *AM*. # IF LBARG$OP[0] EQ "AM" ## AND (LBARG$YI[0] NQ -1 ## OR LBARG$ZI[0] NQ -1) ## AND LBARG$CC[0] EQ -1 THEN BEGIN ERRCODE = S"YZ$VIOL"; # "Y,Z OPTION VIOLATED" # LBERR(ERRCODE); ERRFLAG = 1; RETURN; END # * CHECK IF *LOST OPTION* IS SPECIFIED CORRECTLY. # IF LBARG$LT[0] NQ 0 ## AND (LBARG$OP[0] NQ "RM" ## OR LBARG$C[0] EQ 0) ## THEN BEGIN ERRCODE = S"LT$VIOL"; # "LT OPTION VIOLATED" # LBERR(ERRCODE); ERRFLAG = 1; RETURN; END # * CHECK IF GROUP NUMBER IS LEGAL. # IF ((LBARG$GR[0] GQ 0) ## AND ((LBARG$OP[0] EQ "AS") ## OR (LBARG$OP[0] EQ "AB") ## OR (LBARG$OP[0] EQ "RS") ## OR (LBARG$OP[0] EQ "RB") ## OR (LBARG$OP[0] EQ "FX") ## OR (LBARG$OP[0] EQ "RC") ## OR (LBARG$OP[0] EQ "IB"))) THEN # INCORRECT USE OF GROUP # BEGIN ERRCODE = S"GR$INCORR"; LBERR(ERRCODE); ERRFLAG = 1; RETURN; END IF LBARG$GR[0] GR 20 OR LBARG$GR[0] EQ 0 THEN # GROUP OUT OF RANGE # BEGIN ERRCODE = S"GR$RANGE"; LBERR(ERRCODE); ERRFLAG = 1; RETURN; END # * CHECK IF *PT* IS *P* AND *OP* IS *AM* WITH *GR* SPECIFIED. # IF LBARG$GR[0] GQ 0 AND LBARG$OP[0] EQ "AM" AND LBARG$PT[0] EQ "P " THEN BEGIN ERRCODE = S"GR$INCORR"; LBERR(ERRCODE); ERRFLAG = 1; RETURN; END # * CHECK IF *CN* IS SPECIFIED FOR *IB* AND *FX*. # IF (LBARG$OP[0] EQ "IB" ## OR LBARG$OP[0] EQ "FX") ## AND LBARG$C[0] EQ 0 THEN BEGIN ERRCODE = S"CSN$VIOL"; # VSN OPTION VIOLATED # LBERR(ERRCODE); ERRFLAG = 1; RETURN; END # * CHECK IF *ON* OR *OF* IS SPECIFIED * FOR ANY DIRECTIVE OTHER THAN *IB* OR *FC*. # IF (LBARG$OP[0] NQ "IB" AND LBARG$OP[0] NQ "FC") ## AND(LBARG$ON[0] NQ 0 OR LBARG$OF[0] NQ 0) THEN BEGIN ERRCODE = S"ON$OF$VIOL"; # "ON,OFF NOT SPECIFIED CORRECTLY" # LBERR(ERRCODE); ERRFLAG = 1; RETURN; END # * CHECK IF *ON* OR *OF* ARE SPECIFIED * CORRECTLY FOR *IB* OR *FC*: # IF (LBARG$OP[0] EQ "IB" OR LBARG$OP[0] EQ "FC") ## AND ((LBARG$ON[0] EQ 0 ## AND LBARG$OF[0] EQ 0) ## OR (LBARG$ON[0] NQ 0 ## AND LBARG$OF[0] NQ 0)) THEN BEGIN ERRCODE = S"ON$OF$VIOL"; # "ON,OFF NOT SPECIFIED CORRECTLY" # LBERR(ERRCODE); ERRFLAG = 1; RETURN; END # * CHECK FOR A LEGAL VALUE FOR *CS*. # IF LBARG$SM[0] GR "H" ## OR LBARG$SM[0] LS "A" ## OR LBARG$ZSM[0] NQ 0 THEN BEGIN ERRCODE = S"ILL$SM"; # "ILLEGAL *SM* NUMBER" # LBERR(ERRCODE); ERRFLAG = 1; RETURN; END # * CHECK THE VALUE OF YS AND ZS. # IF LBARG$YI[0] GR MAX$Y ## OR LBARG$YF[0] GR MAX$Y ## OR LBARG$ZI[0] GR MAX$Z ## OR LBARG$ZI[0] EQ Z$NO$CUBE ## OR LBARG$ZF[0] GR MAX$Z ## OR LBARG$ZF[0] EQ Z$NO$CUBE THEN BEGIN ERRCODE = S"YZ$VIOL"; # "Y,Z OPTION VIOLATED" # LBERR(ERRCODE); ERRFLAG = 1; RETURN; END # * CHECK IF *YI*, *ZI*, *YF* AND *ZF* ARE SPECIFIED * CORRECTLY. # IF (LBARG$YI[0] EQ -1 ## AND LBARG$YF[0] GR 0) ## OR (LBARG$ZI[0] EQ -1 ## AND LBARG$ZF[0] GR 0) THEN BEGIN ERRCODE = S"YZ$VIOL"; # "Y,Z OPTION VIOLATED" # LBERR(ERRCODE); ERRFLAG = 1; RETURN; END # * CHECK IF *N* IS SPECIFIED ALONG WITH * *YI* OR *ZI*. # IF (LBARG$YI[0] GQ 0 OR LBARG$ZI[0] GQ 0) AND LBARG$N[0] GR 1 THEN BEGIN ERRCODE = S"YZ$VIOL"; # "Y,Z OPTION VIOLATED" # LBERR(ERRCODE); ERRFLAG = 1; RETURN; END # * CHECK IF *YF* AND *ZF* ARE NOT * SPECIFIED TOGETHER. # IF (LBARG$YF[0] GQ 0 ## AND LBARG$ZF[0] EQ -1) ## OR (LBARG$YF[0] EQ -1 AND LBARG$ZF[0] GQ 0) THEN BEGIN ERRCODE = S"YZ$VIOL"; # "Y,Z OPTION VIOLATED" # LBERR(ERRCODE); ERRFLAG = 1; RETURN; END # * CHECK IF *YF* IS GREATER THAN OR EQUAL * TO *YI* WHEN BOTH ARE SPECIFIED. # IF ((LBARG$YI[0] NQ -1) ## AND (LBARG$YF[0] NQ -1)) ## AND (LBARG$YF[0] LS LBARG$YI[0]) THEN BEGIN ERRCODE = S"YZ$VIOL"; # "Y,Z OPTION VIOLATED" # LBERR(ERRCODE); ERRFLAG = 1; RETURN; END # * CHECK IF *ZF* IS GREATER THAN OR EQUAL * TO *ZI* WHEN BOTH ARE SPECIFIED. # IF ((LBARG$ZI[0] NQ -1) ## AND (LBARG$ZF[0] NQ -1) ) ## AND (LBARG$ZF[0] LS LBARG$ZI[0]) THEN BEGIN ERRCODE = S"YZ$VIOL"; # "Y,Z OPTION VIOLATED" # LBERR(ERRCODE); ERRFLAG = 1; RETURN; END # * CHECK IF *YI* AND *ZI* SPECIFY NON-EXISTANT CUBES WHILE * *YF* AND *ZF* ARE NOT SPECIFIED. # IF (LBARG$YF[0] EQ -1 AND LBARG$ZF[0] EQ -1) AND LBARG$CC[0] EQ -1 THEN # SINGLE CUBE SPECIFIED # BEGIN IF (LBARG$ZI[0] EQ Z$NO$CUBE) ## OR ((LBARG$ZI[0] EQ 0) ## AND ((LBARG$YI[0] EQ 0) ## OR (LBARG$YI[0] EQ 11) ## OR (LBARG$YI[0] EQ 12) ## OR (LBARG$YI[0] EQ 13) ## OR (LBARG$YI[0] EQ 14) ## OR (LBARG$YI[0] EQ 15))) ## OR ((LBARG$ZI[0] EQ 1) ## AND ((LBARG$YI[0] EQ 11) ## OR (LBARG$YI[0] EQ 12) ## OR (LBARG$YI[0] EQ 13) ## OR (LBARG$YI[0] EQ 14) ## OR (LBARG$YI[0] EQ 15))) ## OR ((LBARG$ZI[0] EQ 15) ## AND ((LBARG$YI[0] EQ 0) ## OR (LBARG$YI[0] EQ 11) ## OR (LBARG$YI[0] EQ 21))) ## THEN # IGNORE NON-EXISTANT CUBE # BEGIN ERRCODE = S"YZ$VIOL"; # "Y,Z OPTION VIOLATED" # LBERR(ERRCODE); ERRFLAG =1; RETURN; END END # * CHECK FOR A LEGAL VALUE FOR *SB*. # IF LBARG$SB[0] LS 0 OR LBARG$SB[0] GR 7 THEN BEGIN ERRCODE = S"ILL$SB"; # "ILLEGAL SUBFAMILY" # LBERR(ERRCODE); ERRFLAG = 1; END # * CHECK FOR LEGAL VALUE OF *CC*. # IF (LBARG$CC[0] NQ -1 AND LBARG$OP NQ "AM") OR (LBARG$CC[0] NQ 0 AND LBARG$CC[0] NQ 15 AND LBARG$CC[0] NQ -1) THEN BEGIN ERRCODE = S"ILL$DIRCTV"; LBERR(ERRCODE); ERRFLAG = 1; RETURN; END # * CHECK FOR LEGAL *B* VALUE. # IF (LBARG$B[0] LS 0) OR (LBARG$B[0] GR 1931) ## OR ((LBARG$B[0] NQ 600) ## AND (LBARG$OP[0] NQ "AM")) THEN # *B* INCORRECT # BEGIN ERRCODE = S"B$INCORR"; LBERR(ERRCODE); ERRFLAG = 1; RETURN; END RETURN; # RETURN ERRFLAG = NO ERROR # END # LBOPT # TERM PROC LBRESP((RESP$CODE),(CALLTYP)); # TITLE LBRESP - ACTS UPON RESPONSE CODES FROM EXEC. # BEGIN # LBRESP # # ** LBRESP - ACTS UPON RESPONSE CODES FROM EXEC. * * THIS PROC CHECKS THE RESPONSE CODE RETURNED BY EXEC * AND CALLS *LBERR* WITH THE APPROPRIATE ERROR CODE IF * ANY ERROR OCCURRED. * * PROC LBRESP((RESP$CODE),(CALLTYP)) * * ENTRY RESP$CODE, CODE RETURNED BY EXEC IN RESPONSE * TO A UCP REQUEST, OR BY A CATALOG/MAP * ACCESS ROUTINE. * CALLTYP, TYPE OF CALL. * 0 - CATALOG/MAP ACCESS. * 3 - TYPE 3 UCP REQUEST. * 4 - TYPE 4 UCP REQUEST. * * EXIT PROC *LBERR* CALLED OR RETURN DIRECTLY TO CALLING PROC. * * MESSAGES SSLABEL ABNORMAL, LBRESP. * * NOTES PROC *LBRESP* CHECKS THE VALUE OF *RESP$CODE* AND CALLS * *LBERR* WITH THE APPROPRIATE ERROR CODE IF ANY ERRORS * ARE INDICATED. # ITEM RESP$CODE U; # RESPONSE CODE FROM EXEC # ITEM CALLTYP U; # TYPE OF CALL MADE # # **** PROC LBRESP - XREF LIST BEGIN. # XREF BEGIN PROC LBERR; # *SSLABEL* ERROR PROCESSOR # PROC MESSAGE; # DISPLAYS MESSAGES # PROC RESTPFP; # RESTORE USER-S *PFP* AND ABORT OR RETURN # END # **** PROC LBRESP - XREF LIST END. # DEF PROCNAME #"LBRESP."#; # PROC NAME # DEF LISTCON #0#; # DO NOT LIST COMDECKS # *CALL COMBFAS *CALL COMBCMS *CALL COMBCPR *CALL COMTERR *CALL COMTLAB # * STATUS SWITCH FOR THE RESPONSE CODES * RETURNED BY EXEC IN RESPONSE TO TYPE 3 * CALLSS REQUEST. # SWITCH RESP$ACT3:RESPTYP3 # ACTION ON RESPONSE TO TYPE 3 REQUEST # OK3$ACT:OK3, # REQUEST PROCESSED # INTLCK$ACT:C$M$INTLCK, # CATALOG/MAP INTERLOCKED # NOPEN$ACT:C$M$NOPEN, # CATALOG/MAP NOT OPEN # SUBEX$ACT:SUB$CAT$EX, # SUB CATALOG ALREADY EXISTS # NOSUB$ACT:NO$SUB$CAT, # NO SUCH SUBCATALOG # PFPROB$ACT: PF$PROB; # PERMANENT FILE PROBLEM # # * STATUS SWITCH FOR THE RESPONSE RETURNED BY * EXEC TO A TYPE 4 CALLSS REQUEST. ONLY THE * APPLICABLE RESPONSE CODES ARE LISTED HERE. # SWITCH RESP$ACT4:RESPTYP4 # ACTION ON RESPONSE TO TYPE 4 REQUEST # OK4$ACT:OK4, # REQUEST PROCESSED # CLBERR$ACT:CART$LB$ERR, # CARTRIDGE LABEL ERROR # CUSERR$ACT:CSN$IN$USE, # CARTRIDGE IN USE # SMOFF$ACT:SMA$OFF, # STORAGE MODULE OFF # CEMERR$ACT:CELL$EMP, CFLERR$ACT:CELL$FULL, UNKERR$ACT:UNK$CART, # UNKNOWN LABEL ERROR # URDERR$ACT:UN$RD$ERR, # UNRECOVERABLE READ ERROR # UWTERR$ACT:UN$WRT$ERR, # UNRECOVERABLE WRITE ERROR # MHDERR$ACT:M86$HDW$PR; # M86 HARDWARE PROBLEM # CONTROL EJECT; # * DO PROCESSING APPROPRIATE TO TYPE OF RESPONSE CODE. # IF CALLTYP EQ TYP"TYP3" THEN # TYPE 3 UCP REQUEST # BEGIN GOTO RESP$ACT3[RESP$CODE]; END IF CALLTYP EQ TYP"TYP4" THEN # TYPE 4 UCP REQUEST # BEGIN GOTO RESP$ACT4[RESP$CODE]; END IF CALLTYP NQ 0 THEN # ILLEGAL CALL TYPE # BEGIN LBMSG$PROC[0] = PROCNAME; MESSAGE(LBMSG[0],SYSUDF1); RESTPFP(PFP$ABORT); # RESTORE USER-S *PFP* AND ABORT # END # * ERROR PROCESSING FOR CATALOG/MAP ACCESS. # IF RESP$CODE EQ CMASTAT"INTLK" THEN # CATALOG/MAP INTERLOCKED # BEGIN ERRCODE = S"CAT$MAP$LK"; LBERR(ERRCODE); RETURN; END IF RESP$CODE EQ CMASTAT"ATTERR" THEN # PROCESS ATTACH ERROR # BEGIN ERRCODE = S"PF$PROB"; LBERR(ERRCODE); RETURN; END IF RESP$CODE EQ CMASTAT"NOSUBCAT" THEN # NO SUCH SUBCATALOG # BEGIN ERRCODE = S"NO$CAT$MAP"; LBERR(ERRCODE); RETURN; END IF RESP$CODE NQ CMASTAT"NOERR" AND RESP$CODE NQ CMASTAT"FOPEN" THEN # ERROR OTHER THAN *CATALOG ALREADY OPEN* # BEGIN LBMSG$PROC[0] = PROCNAME; MESSAGE(LBMSG[0],SYSUDF1); RESTPFP(PFP$ABORT); # RESTORE USER-S *PFP* AND ABORT # END # * ERROR PROCESSING FOR TYPE 3 REQUESTS TO EXEC. # OK3$ACT: # NO ERROR # RETURN; INTLCK$ACT: # CATALOG/MAP INTERLOCKED # ERRCODE = S"CAT$MAP$LK"; LBERR(ERRCODE); RETURN; NOPEN$ACT: # CATALOG/MAP NOT OPEN # ERRCODE = S"NOT$OPEN"; LBERR(ERRCODE); RETURN; SUBEX$ACT: # SUB CATALOG ALREADY EXISTS # ERRCODE = S"SM$DEFND"; LBERR(ERRCODE); RETURN; NOSUB$ACT: # NO SUCH SUBCATALOG # ERRCODE = S"NO$CAT$MAP"; LBERR(ERRCODE); RETURN; PFPROB$ACT: # PERMANENT FILE PROBLEM # ERRCODE = S"PF$PROB"; LBERR(ERRCODE); RETURN; # * ERROR PROCESSING FOR TYPE 4 REQUESTS TO EXEC. # OK4$ACT: # NO ERRORS # RETURN; CLBERR$ACT: # CARTRIDGE LABEL ERROR # ERRCODE = S"LAB$ERR"; LBERR(ERRCODE); RETURN; CUSERR$ACT: ERRCODE = S"CAR$IN$USE"; LBERR(ERRCODE); RETURN; CEMERR$ACT: # CARTRIDGE NOT FOUND # ERRCODE = S"CR$NOTFND"; LBERR(ERRCODE); RETURN; CFLERR$ACT: # CELL IS FULL # ERRCODE = S"CELL$FULL"; LBERR(ERRCODE); RETURN; UNKERR$ACT: # UNKNOWN LABEL ERROR # ERRCODE = S"LAB$ERR"; LBERR(ERRCODE); RETURN; URDERR$ACT: # UNRECOVERABLE READ ERROR # ERRCODE = S"UNRECV$RD"; LBERR(ERRCODE); RETURN; UWTERR$ACT: # UNRECOVERABLE WRITE ERROR # ERRCODE = S"UNRECV$WRT"; LBERR(ERRCODE); RETURN; MHDERR$ACT: # MSF HARDWARE PROBLEM # ERRCODE = S"M86$HARDWR"; LBERR(ERRCODE); RETURN; SMOFF$ACT: ERRCODE = S"SM$OFF"; LBERR(ERRCODE); RETURN; END # LBRESP # TERM PROC LBRMCSU; # TITLE LBRMCSU - REMOVE A *SM* FROM A FAMILY CATALOG. # BEGIN # LBRMCSU # # ** LBRMCSU - REMOVE A *SM* FROM A FAMILY CATALOG. * * THIS PROC UPDATES THE CATALOG FOR A FAMILY TO REMOVE * ASSIGNMENT OF A PARTICULAR CSU. * * PROC LBRMCSU. * * ENTRY CRACKED AND SYNTAX CHECKED DIRECTIVE * PARAMETERS SET UP IN COMMON AREA DEFINED * IN *COMTLBP*. * * EXIT *SM* REMOVED FROM FAMILY OR ERROR CONDITION. * * NOTES PROC *LBRMCSU* SEARCHES THE SMMAP FOR THE *SM* * SPECIFIED TO VERIFY THAT NO CUBES ARE ASSIGNED * TO THE FAMILY. A REQUEST IS THEN SENT TO EXEC * TO UPDATE THE CATALOG TO REFLECT THE REMOVAL OF * THE *SM*. # # **** PROC LBRMCSU - XREF LIST BEGIN. # XREF BEGIN PROC CALL3; # ISSUES TYPE 3 CALLSS TO EXEC # PROC LBERR; # *SSLABEL* ERROR PROCESSOR # PROC LBRESP; # PROCESSES RESPONSE FROM EXEC # PROC SERCSU; # SEARCHES THE SMMAP # END # **** PROC LBRMCSU - XREF LIST END. # DEF LISTCON #0#; # DO NOT LIST COMDECKS # *CALL COMBFAS *CALL COMBCPR *CALL COMTERR *CALL COMTLAB *CALL COMTLBP ITEM FLAG I; # ERROR FLAG # ITEM REQCODE U; # REQUEST CODE # ITEM RESP$CODE U; # RESPONSE CODE FROM EXEC # ITEM SERTYPE S:SERCH$TYPE; # SMMAP SEARCH TYPE # ARRAY PK$CSU$ENT [0:0] P(4); # *PICK* SMMAP ENTRY # BEGIN ITEM PK$MAPENT C(00,00,30); # THREE WORD MAP ENTRY # ITEM PK$Y U(03,00,30); # Y COORDINATE # ITEM PK$Z U(03,30,30); # Z COORDINATE # END CONTROL EJECT; # * SEARCH SMMAP FOR CUBES ASSIGNED TO FAMILY AND UPDATE CATALOG. # SERTYPE = S"ASGN$FAM"; SERCSU(SERTYPE,0,0,0,0,LBARG$FM[0],LBARG$SB[0], PK$CSU$ENT[0], FLAG); IF FLAG EQ OK THEN # ENTRY FOUND # BEGIN ERRCODE = S"CB$ASGN$SB"; LBERR(ERRCODE); # DO ERROR PROCESSING # RETURN; END REQCODE = REQTYP3"RMV$CSU"; CALL3(REQCODE,0,0,0,RESP$CODE); # REMOVE *SM* FROM FAMILY # IF RESP$CODE NQ RESPTYP3"OK3" THEN # PROCESS THE RESPONSE # BEGIN LBRESP(RESP$CODE,TYP"TYP3"); END RETURN; END # LBRMCSU # TERM PROC LBRMCUB; # TITLE LBRMCUB - REMOVES CUBES FROM FAMILY/POOL/RESERVED AREA. # BEGIN # LBRMCUB # # ** LBRMCUB - REMOVES CUBES FROM FAMILY/POOL/RESERVED AREA. * * THIS PROC REMOVES ASSIGNED CUBES FROM A FAMILY, POOL, * OR RESERVED AREA OF THE CSU. * * PROC LBRMCUB. * * ENTRY CRACKED AND SYNTAX CHECKED DIRECTIVE * PARAMETERS SET UP IN COMMON AREA DEFINED * IN *COMTLBP*. * * EXIT SPECIFIED NUMBER OR LOCATIONS OF CUBES HAVE * BEEN REMOVED, OR ERROR CONDITION. * * NOTES PROC *LBRMCUB* REMOVES CUBES FROM A FAMILY, * POOL, OR RESERVED AREA BY CHANGING THEIR STATUS * FROM *ASSIGNED* TO *UNASSIGNED*. IF THE *N* * OPTION IS USED THE SMMAP IS SEARCHED FOR EMPTY * CUBES WITH THE APPROPRIATE ASSIGNMENT. IF THE * LOCATION OPTION IS USED, THE SMMAP IS CHECKED * TO ENSURE THAT THE SPECIFIC CUBES ARE EMPTY AND * ASSIGNED AS EXPECTED. A REQUEST IS THEN SENT * TO EXEC TO REMOVE THE CUBES FROM ASSIGNMENT. # # **** PROC LBRMCUB - XREF LIST BEGIN. # XREF BEGIN PROC CALL3; # ISSUES TYPE 3 CALLSS TO EXEC # PROC LBERR; # *SSLABEL* ERROR PROCESSOR # PROC LBRESP; # RESPONSE CODE PROCESSOR # PROC MFLUSH; # FLUSHES MAP BUFFER # PROC SERCSU; # SEARCHES THE SMMAP # PROC SETCORD; # SETS UP Y AND Z COORDINATES # END # **** PROC LBRMCUB - XREF LIST END. # DEF LISTCON #0#; # DO NOT LIST COMDECKS # *CALL COMBFAS *CALL COMBCPR *CALL COMBMAP *CALL COMTERR *CALL COMTLAB *CALL COMTLBP ITEM FLAG I; # ERROR FLAG # ITEM I I; # LOOP VARIABLE # ITEM LOC$OPTION B; # TRUE IF *LOC* OPTION FALSE IF *N* OPTION # ITEM REQCODE U; # RESPONSE CODE FROM EXEC # ITEM RESP$CODE U; # RESPONSE CODE FROM EXEC # ITEM SERTYPE S:SERCH$TYPE; # TYPE OF SEARCH THROUGH SMMAP # ITEM SP$CODE U; # CODE FOR CUBE/CARTRIDGE ASSIGNMENT # ITEM SP$FAM C(7); # SPECIFIED FAMILY NAME # ITEM SP$SUB U; # SPECIFIED SUB FAMILY # ITEM SP$VSN C(8); # SPECIFIED CARTRIDGE *CSND* # ITEM SP$Y U; # Y COORDINATE # ITEM SP$Z U; # Z COORDINATE # ARRAY PK$CSU$ENT [0:0] P(4); # *PICK* SMMAP ENTRY # BEGIN ITEM PK$MAPENT C(00,00,30); # THREE WORD MAP ENTRY # ITEM PK$Y U(03,00,30); # Y COORDINATE # ITEM PK$Z U(03,30,30); # Z COORDINATE # END CONTROL EJECT; # * CHECK FOR *N* OPTION OR *LOC* OPTION. # LOC$OPTION = FALSE; IF LBARG$YI[0] NQ -1 OR LBARG$ZI[0] NQ -1 THEN # *LOC* OPTION SPECIFIED # BEGIN SETCORD; # BUILD Y,Z MATRIX # LOC$OPTION = TRUE; END # * PROCESS EACH OF THE *N* CUBES SPECIFIED. # SP$VSN = " "; SP$FAM = " "; SP$SUB = 0; FASTFOR I = 1 STEP 1 UNTIL LBARG$N[0] DO BEGIN # PROCESS *N* CUBES # IF NOT LOC$OPTION THEN BEGIN # *N* OPTION # SERTYPE = S"ASSIGN"; # SEARCH FOR ASSIGNED CUBE # IF LBARG$PK[0] EQ "F" THEN # REMOVE CUBE FROM FAMILY # BEGIN SP$CODE = CUBSTAT"SUBFAM"; SP$FAM = LBARG$FM[0]; SP$SUB = LBARG$SB[0]; END IF LBARG$PK[0] EQ "P" THEN # REMOVE CUBE FROM POOL # BEGIN SP$CODE = CUBSTAT"SCRPOOL"; END IF LBARG$PK[0] EQ "R" THEN # REMOVE FROM RESERVED AREA # BEGIN SP$CODE = CUBSTAT"ALTCSU"; END END # *N* OPTION # ELSE BEGIN # *LOC* OPTION # SERTYPE = S"LOC"; # LOOK FOR SPECIFIC LOCATION # SP$Y = Y$COORD[I]; SP$Z = Z$COORD[I]; END # *LOC* OPTION # # * SEARCH THE SMMAP FOR THE SPECIFIED ENTRY. # SERCSU(SERTYPE,SP$Y,SP$Z,SP$CODE,SP$VSN,SP$FAM,SP$SUB, PK$CSU$ENT[0],FLAG); IF FLAG NQ OK THEN # NO EMPTY CUBES # BEGIN NUMDONE = I - 1; ERRCODE = S"NO$EMPCB"; LBERR(ERRCODE); RETURN; END # * CHECK CUBE ASSIGNMENT. # P = LOC(PK$CSU$ENT[0]); IF CM$CSND[0] NQ " " THEN # CUBE NOT EMPTY # BEGIN NUMDONE = I - 1; ERRCODE = S"CB$NOT$EMP"; LBERR(ERRCODE); # DO ERROR PROCESSING # RETURN; END IF LBARG$PK[0] EQ "F" ## AND CM$CODE[0] EQ CUBSTAT"SUBFAM" ## AND CM$FMLYNM[0] EQ LBARG$FM[0] ## AND CM$SUB[0] EQ LBARG$SB[0] THEN # REMOVE CUBE FROM FAMILY # BEGIN REQCODE = REQTYP3"RMV$CUBE"; END ELSE BEGIN # REMOVE FROM POOL/RESERVED AREA # IF (LBARG$PK[0] EQ "P" AND CM$CODE[0] EQ CUBSTAT"SCRPOOL") OR (LBARG$PK[0] EQ "R" AND CM$CODE[0] EQ CUBSTAT"ALTCSU") OR (LBARG$PK[0] EQ "R" AND CM$CODE[0] EQ CUBSTAT"SYSUSE") THEN BEGIN REQCODE = REQTYP3"UPD$MAP"; # UPDATE SMMAP ENTRY # CM$CODE[0] = CUBSTAT"UNASGN"; CM$FLAG1[0] = FALSE; # CLEAR ERROR FLAG IN MAP ENTRY # END ELSE # PROCESS ERROR CONDITION # BEGIN NUMDONE = I - 1; ERRCODE = S"UNX$CB$ASN"; LBERR(ERRCODE); # DO ERROR PROCESSING # RETURN; END END # REMOVE FROM POOL/RESERVED AREA # # * ISSUE TYPE 3 CALLSS REQUEST AND DO ERROR PROCESSING IF AN * ERROR STATUS IS RETURNED BY EXEC. # CALL3(REQCODE,PK$CSU$ENT[0],0,0,RESP$CODE); IF RESP$CODE NQ RESPTYP3"OK3" THEN # PROCESS THE RESPONSE # BEGIN LBRESP(RESP$CODE,TYP"TYP3"); RETURN; END MFLUSH; END # PROCESS *N* CUBES # RETURN; END # LBRMCUB # TERM PROC LBRMMSC; # TITLE LBRMMSC - REMOVES CARTRIDGES FROM A FAMILY OR POOL. # BEGIN # LBRMMSC # # ** LBRMMSC - REMOVES CARTRIDGES FROM A FAMILY OR POOL. * * THIS PROC LOCATES AND REMOVES EMPTY CARTRIDGES. * * PROC LBRMMSC. * * ENTRY CRACKED AND SYNTAX CHECKED DIRECTIVE * PARAMETERS SET UP IN COMMON AREA DEFINED * IN *COMTLBP*. * (LB$BUFP) = FWA OF A BUFFER 1101B WORDS LONG. * * EXIT CARTRIDGES REMOVED OR ERROR CONDITION. * * MESSAGES FAMILY NOT FOUND. * CARTRIDGE NOT EMPTY, VSN. * * NOTES PROC *LBRMMSC* OPENS THE CATALOG AND SEARCHES IT * FOR CARTRIDGES FREE IF NO CSN * IS SPECIFIED. IF CSN IS SPECIFIED THE SMMAP IS * SEARCHED FOR A MATCHING CSN. IF THE *LOST* OPTION * IS SPECIFIED, THE CARTRIDGE IS REMOVED FROM THE * FAMILY AFTER VERIFYING THAT IT IS MISSING AND * ASSIGNED TO THE FAMILY. THE CARTRIDGE IS LOADED * AND ITS LABEL IS CHECKED. A NEW SCRATCH LABEL IS * WRITTEN AND THE CARTRIDGE IS UNLOADED TO THE POOL * OR OUTPUT DRAWER, AS SPECIFIED BY *PT*. # # **** PROC LBRMMSC - XREF LIST BEGIN. # XREF BEGIN PROC CALL3; # ISSUES TYPE 3 EXEC CALLSS # PROC CALL4; # ISSUES TYPE 4 EXEC CALLSS # PROC CCLOSE; # CLOSE SFMCAT # PROC CGETFCT; # GETS AN FCT ENTRY # PROC COPEN; # OPENS THE CATALOG # PROC DLABFLD; # DISPLAY CARTRIDGE LABEL FIELDS # PROC GENLAB; # GENERATES A NEW LABEL # PROC LBERR; # *SSLABEL* ERROR PROCESSOR # PROC LBRESP; # RESPONSE CODE PROCESSOR # PROC LOFPROC; # LIST OF FILES PROCESSOR # PROC MCLOSE; # CLOSE SMMAP # PROC MESSAGE; # DISPLAYS MESSAGE # PROC MFLUSH; # FLUSH MAP BUFFER # PROC MOPEN; # OPEN SMMAP # PROC RESTPFP; # RESTORE USER-S *PFP* AND ABORT OR RETURN # PROC SERAST; # SEARCH FOR EMPTY CARTRIDGES # PROC SERCSU; # SEARCHES THE SMMAP # PROC SETPFP; # SET FAMILY AND USER INDEX # FUNC XCOD; # INTEGER TO DISPLAY CONVERSION # END # **** PROC LBRMMSC - XREF LIST END. # DEF LISTCON #0#; # DO NOT LIST COMDECKS # *CALL COMBFAS *CALL COMBCMS *CALL,COMBCMD *CALL COMBCPR *CALL COMBLBL *CALL COMBMAP *CALL COMBMCT *CALL COMBPFP *CALL COMSPFM *CALL COMTERR *CALL COMTLAB *CALL COMTLBP ITEM CART$CSN C(20); # CARTRIDGE SERIAL NUMBER # ITEM ERR$CNT I; # ERROR COUNT # ITEM FCTORD U; # EMPTY CARTRIDGE FCT ORDINAL # ITEM FLAG I; # ERROR FLAG # ITEM HR$ERR I; # HARD READ ERRORS # ITEM I I; # LOOP VARIABLE # ITEM LD$CNT I; # LOAD COUNT # ITEM LD$ERR I; # LOAD ERRORS # ITEM PS$CNT I; # PASS COUNT # ITEM REQCODE I; # REQUEST CODE # ITEM RESP$CODE I; # RESPONSE CODE # ITEM SERTYPE S:SERCH$TYPE; # SEARCH TYPE # ITEM SGROUP I; # SAVE GROUP PARAMETER # ITEM SLOT I; # DRAWER NUMBER # ITEM SP$CODE I; # SPECIFIED CODE # ITEM SP$Y I; # SPECIFIED Y # ITEM SP$Z I; # SPECIFIED Z # ITEM SR$ERR I; # SOFT READ ERRORS # ITEM STR$RD I; # STRIPES READ # ITEM STR$WR I; # STRIPES WRITTEN # ITEM STR$DM I; # STRIPES DEMARKED # ITEM SW$ERR I; # SOFT WRITE ERRORS # ARRAY CMAP$NM [0:0] P(1); # BUILD SMMAP NAME # BEGIN ITEM CMAP$NAME C(00,00,07); # SMMAP FILE NAME # ITEM CMAP$IN C(00,00,05); # FIRST 5 CHARACTERS # ITEM CMAP$ID C(00,30,01); # SM-ID # ITEM CMAP$Z C(00,36,24) = [0]; # ZERO FILL # END ARRAY MSFCATNM [0:0] P(1); # CATALOG NAME # BEGIN ITEM MSFCAT$NM C(00,00,06); # FIRST 6 CHARACTERS # ITEM MSFCAT$LST C(00,36,01); # LAST CHARACTER # END ARRAY PK$CSU$ENT [0:0] P(4); # *PICK* SMMAP ENTRY # BEGIN ITEM PK$MAPENT C(00,00,30); # THREE WORD SMMAP ENTRY # ITEM PK$Y U(03,00,30); # Y COORDINATE # ITEM PK$Z U(03,30,30); # Z COORDINATE # END ARRAY PT$CSU$ENT [0:0] P(5); # *PUT* SMMAP ENTRY # BEGIN ITEM PT$MAPENT C(00,00,30); # THREE WORD MAP ENTRY # ITEM PT$Y U(03,00,30); # Y COORDINATE # ITEM PT$Z U(03,30,30); # Z COORDINATE # ITEM PT$GR U(04,00,07); # GROUP # ITEM PT$GRT U(04,07,04); # GROUP ORDINAL # END CONTROL EJECT; # * INITIALIZE POINTERS AND MISCELLANEOUS ITEMS. # PFP$WRD0[0] = 0; PFP$FG1[0] = TRUE; PFP$FG4[0] = TRUE; P = LB$BUFP; P = LOC(PK$CSU$ENT[0]); SGROUP = LBARG$GR[0]; # * REMOVE EACH OF *N* CARTRIDGES FROM THE FAMILY OR POOL. # SLOWFOR I = 1 STEP 1 UNTIL LBARG$N[0] DO BEGIN # REMOVE CARTRIDGE # LBARG$GR[0] = SGROUP; # * PROCESSING FOR *CSN NOT SPECIFIED*. # P = LOC(PT$CSU$ENT[0]); IF LBARG$C[0] EQ 0 THEN BEGIN # CSN NOT SPECIFIED # IF LBARG$PK[0] EQ "F" THEN BEGIN # SELECT CARTRIDGE FROM FAMILY # # * OPEN CATALOG AND CHECK ERROR STATUS. # PFP$FAM[0] = LBARG$FM[0]; PFP$UI[0] = DEF$UI + LBARG$SB[0]; SETPFP(PFP); IF PFP$STAT[0] NQ 0 THEN # FAMILY NOT FOUND # BEGIN LBMSG$LN[0] = " FAMILY NOT FOUND."; MESSAGE(LBMSG[0],SYSUDF1); RESTPFP(PFP$ABORT); # RESTORE USER-S *PFP* AND ABORT # END MSFCAT$NM[0] = SFMCAT; # SET UP CATALOG NAME # MSFCAT$LST[0] = XCOD(LBARG$SB[0]); COPEN(LBARG$FM[0],LBARG$SB[0],MSFCATNM[0],"RM",TRUE,FLAG); IF FLAG EQ CMASTAT"NOERR" THEN BEGIN LOFPROC(OCT$LFN[1]); # ADD LFN TO LIST OF FILES # END IF FLAG NQ CMASTAT"NOERR" AND FLAG NQ CMASTAT"FOPEN" THEN # ERROR CONDITION OTHER THAN *CATALOG ALREADY OPEN* # BEGIN LBRESP(FLAG,0); RETURN; END # * SEARCH *AST* FOR EMPTY CARTRIDGE. # SERAST(FCTORD,FLAG); IF FLAG NQ OK THEN # NO EMPTY CARTRIDGE FOUND # BEGIN NUMDONE = I - 1; ERRCODE = S"NO$EMP$CR"; LBERR(ERRCODE); # DO ERROR PROCESSING # RETURN; END # * GET FCT ENTRY OF EMPTY CARTRIDGE AND SET LOAD, PASS, * AND ERROR COUNTS FOR NEW LABEL. # CGETFCT(LBARG$FM[0],LBARG$SB[0],LBARG$SMID[0],FCTORD, LB$BUFP,0,FLAG); IF FLAG NQ OK THEN # PROCESS ERROR STATUS # BEGIN LBRESP(FLAG,0); RETURN; END LD$CNT = FCT$CRLD[0]; HR$ERR = FCT$HRDE[0]; SW$ERR = FCT$SWRE[0]; SR$ERR = FCT$SRDE[0]; STR$RD = FCT$STRD[0]; STR$WR = FCT$STWR[0]; STR$DM = FCT$STDM[0]; # * GET SMMAP ENTRY. # SERTYPE = S"LOC"; SERCSU(SERTYPE,FCT$Y[0],FCT$Z[0],0,0,0,0, PK$CSU$ENT[0], FLAG); CCLOSE(LBARG$FM[0],LBARG$SB[0],0,FLAG); END # SELECT CARTRIDGE FROM FAMILY # IF LBARG$PK[0] EQ "P" THEN BEGIN # SELECT CARTRIDGE FROM POOL # SERTYPE = S"CART$POOL"; SERCSU(SERTYPE,0,0,0,0,0,0,PK$CSU$ENT[0],FLAG); IF FLAG NQ OK THEN # POOL EMPTY # BEGIN NUMDONE = I - 1; ERRCODE = S"NO$CR$PL"; LBERR(ERRCODE); # DO ERROR PROCESSING # RETURN; END CMAP$ID[0] = LBARG$SM[0]; CMAP$IN[0] = SMMAP; END # SELECT CARTRIDGE FROM POOL # END # VSN NOT SPECIFIED # # * PROCESSING FOR *VSN SPECIFIED*. # IF LBARG$C[0] NQ 0 THEN BEGIN # VSN SPECIFIED # SERTYPE = S"CSN$MATCH"; # SEARCH FOR VSN # SERCSU(SERTYPE,0,0,0,LBARG$C[0],0,0,PK$CSU$ENT[0],FLAG); IF FLAG NQ 0 THEN # VSN NOT FOUND # BEGIN ERRCODE = S"CSN$NOTFND"; LBERR(ERRCODE); # DO ERROR PROCESSING # RETURN; END # * OPEN CATALOG AND CHECK ERROR STATUS. # IF CM$CODE[0] EQ CUBSTAT"SUBFAM" THEN BEGIN # OPEN CATALOG # PFP$FAM[0] = CM$FMLYNM[0]; PFP$UI[0] = DEF$UI + CM$SUB[0]; SETPFP(PFP); IF PFP$STAT[0] NQ 0 THEN # FAMILY NOT FOUND # BEGIN LBMSG$LN[0] = " FAMILY NOT FOUND."; MESSAGE(LBMSG[0],SYSUDF1); RESTPFP(PFP$ABORT); # RESTORE USER-S *PFP* AND ABORT # END MSFCAT$NM[0] = SFMCAT; # SET UP CATALOG NAME # MSFCAT$LST[0] = XCOD(CM$SUB[0]); COPEN(CM$FMLYNM[0],CM$SUB[0],MSFCATNM[0],"RM",TRUE,FLAG); IF FLAG EQ CMASTAT"NOERR" THEN BEGIN LOFPROC(OCT$LFN[1]); # ADD LFN TO LIST OF FILES # END IF FLAG NQ CMASTAT"NOERR" AND FLAG NQ CMASTAT"FOPEN" THEN # ERROR CONDITION OTHER THAN *CATALOG ALREADY OPEN* # BEGIN LBRESP(FLAG,0); RETURN; END END # OPEN CATALOG # END # VSN SPECIFIED # # * *LOST* OPTION PROCESSING. # IF LBARG$LT[0] NQ 0 THEN BEGIN # *LOST* OPTION SPECIFIED # IF CM$CODE[0] NQ CUBSTAT"SUBFAM" THEN # NOT A FAMILY CARTRIDGE # BEGIN ERRCODE = S"UNX$CR$ASN"; LBERR(ERRCODE); RETURN; END # * GET FCT ENTRY FOR SPECIFIED CARTRIDGE. # CGETFCT(CM$FMLYNM[0],CM$SUB[0],LBARG$SMID[0],CM$FCTORD[0], LB$BUFP,0,FLAG); IF FLAG NQ OK THEN # PROCESS ERROR STATUS # BEGIN LBRESP(FLAG,0); RETURN; END IF NOT FCT$LCF[0] THEN # FCT *LOST* FLAG NOT SET # BEGIN ERRCODE = S"LOST$NSET"; LBERR(ERRCODE); # DO ERROR PROCESSING # RETURN; END REQCODE = REQTYP4"LOAD$CART"; CALL4(REQCODE,DRD$NUM,CART$CSN,PK$Y[0],PK$Z[0],RESP$CODE); IF RESP$CODE EQ RESPTYP4"CELL$EMP" THEN BEGIN # REMOVE LOST CARTRIDGE FROM FAMILY # REQCODE = REQTYP3"RMV$CART"; CALL3(REQCODE,PK$CSU$ENT,0,0,RESP$CODE); IF RESP$CODE EQ RESPTYP3"MSC$NEMPTY" THEN BEGIN LBMSG$LINE[0] = " CARTRIDGE NOT EMPTY, ."; LBMSG$CSN[0] = CM$CSND[0]; MESSAGE(LBMSG$BUF[0],SYSUDF1); TEST I; END IF RESP$CODE NQ RESPTYP3"OK3" THEN BEGIN LBRESP(RESP$CODE,TYP"TYP3"); END RETURN; END # REMOVE LOST CARTRIDGE FROM FAMILY # ELSE BEGIN # PROCESS ERROR STATUS # IF RESP$CODE EQ RESPTYP4"OK4" THEN BEGIN REQCODE = REQTYP4"UNLD$CART"; CALL4(REQCODE,0,0,PK$Y[0],PK$Z[0],RESP$CODE); IF RESP$CODE NQ RESPTYP4"OK4" THEN BEGIN LBRESP(RESP$CODE,TYP"TYP4"); RETURN; END ERRCODE = S"LOST$SET"; LBERR(ERRCODE); RETURN; END ELSE # PROCESS DETAIL STATUS # BEGIN LBRESP(RESP$CODE,TYP"TYP4"); RETURN; END END # PROCESS ERROR STATUS # END # *LOST* OPTION SPECIFIED # # * CHECK CARTRIDGE ASSIGNMENT AND *PT* OPTION. # IF CM$CODE[0] EQ CUBSTAT"SCRPOOL" AND LBARG$PT[0] EQ "P" THEN # IGNORE THE CARTRIDGE # BEGIN TEST I; END # * FIND EMPTY OUTPUT DRAWER OR CUBE IN POOL. # IF LBARG$PT[0] EQ "D" THEN BEGIN # FIND EMPTY OUTPUT DRAWER # P = LOC(PT$CSU$ENT[0]); PT$Y[0] = 12; PT$Z[0] = 0; CM$FCTORD[0] = 0; CM$FMLYNM[0] = ""; END # FIND EMPTY OUTPUT DRAWER # ELSE BEGIN # FIND EMPTY CUBE IN POOL # SERTYPE = S"ASSIGN"; SP$CODE = CUBSTAT"SCRPOOL"; SERCSU(SERTYPE,0,0,SP$CODE,"","",0,PT$CSU$ENT[0],FLAG); IF FLAG NQ 0 THEN # NO EMPTY CUBES IN FAMILY/POOL # BEGIN NUMDONE = I - 1; ERRCODE = S"NO$EMPCBFP"; LBERR(ERRCODE); # DO ERROR PROCESSING # RETURN; END END # FIND EMPTY CUBE IN POOL # # * GET CARTRIDGE AND CHECK ITS LABEL. # REQCODE = REQTYP4"LOAD$CART"; CALL4(REQCODE,DRD$NUM,CART$CSN,PK$Y[0],PK$Z[0],RESP$CODE); IF RESP$CODE NQ RESPTYP4"OK4" ## THEN BEGIN # LOAD FAILS # IF RESP$CODE EQ RESPTYP4"CELL$EMP" THEN BEGIN # SET UP ERROR FLAGS # P = LOC(PK$CSU$ENT[0]); IF CM$CODE[0] EQ CUBSTAT"SCRPOOL" THEN # SET ERROR FLAG IN SMMAP ENTRY # BEGIN CM$FLAG1[0] = TRUE; CALL3(REQTYP3"UPD$MAP",PK$CSU$ENT[0],0,0,FLAG); END ELSE # SET LOST FLAG IN CATALOG ENTRY # BEGIN CALL3(REQTYP3"UPD$CAT",PK$CSU$ENT[0],UCF"LOST",1,FLAG); END NUMDONE = I - 1; ERRCODE = S"CR$NOTFND"; # CARTRIDGE NOT FOUND # LBERR(ERRCODE); IF FLAG NQ RESPTYP3"OK3" THEN BEGIN LBRESP(FLAG,TYP"TYP3"); RETURN; END RETURN; END # SET UP ERROR FLAGS # ELSE # PROCESS RESPONSE CODE # BEGIN LBRESP(RESP$CODE,TYP"TYP4"); IF RESP$CODE EQ RESPTYP4"CART$LB$ERR" ## OR RESP$CODE EQ RESPTYP4"UNK$CART" THEN # UNLOAD CARTRIDGE TO EXIT TRAY # BEGIN CALL4(REQTYP4"UNLD$CART",0,0,SM$EXIT$TY,SM$TY$Z, ## RESP$CODE); END RETURN; END END # LOAD FAILS # P = LOC(PK$CSU$ENT[0]); P = OLDLABP; # * VERIFY VSN, Y, Z IN THE LABEL. # IF LAB$CSND[0] NQ CM$CSND[0] ## AND(LAB$Y[0] NQ PK$Y[0] OR LAB$Z[0] NQ PK$Z[0]) THEN BEGIN # TEST Y,Z # REQCODE = REQTYP4"UNLD$CART"; CALL4(REQCODE,0,0,SM$EXIT$TY,SM$TY$Z,RESP$CODE); IF RESP$CODE NQ RESPTYP4"OK4" THEN BEGIN LBRESP(RESP$CODE,TYP"TYP4"); RETURN; END ERRCODE = S"M86$HARDWR"; # MSF HARDWARE PROBLEM # LBERR(ERRCODE); RETURN; END # TEST Y,Z # IF CM$CODE[0] EQ CUBSTAT"SCRPOOL" THEN # CARTRIDGE FROM POOL # BEGIN LD$CNT = LAB$CRLD[0]; # USE OLD LOAD/PASS/ERROR COUNTS # LD$ERR = LAB$LDER[0]; SR$ERR = LAB$SRDE[0]; SW$ERR = LAB$SWRE1[0]; B<28,4>SW$ERR = LAB$SWRE[0]; HR$ERR = LAB$HRDE[0]; STR$RD = LAB$STRD[0]; STR$WR = LAB$STWR1[0]; B<36,24>STR$WR = LAB$STWR[0]; STR$DM = LAB$STDM[0]; END # * CHECK IF CSU, Y, Z, FAMILY, AND SUBFAMILY DO NOT * AGREE IN OLDLABEL AND SMMAP ENTRY. # IF LAB$SMID[0] NQ LBARG$SMID[0] OR LAB$Y[0] NQ PK$Y[0] OR LAB$Z[0] NQ PK$Z[0] OR LAB$FMLY[0] NQ CM$FMLYNM[0] OR LAB$SF[0] NQ CM$SUB[0] THEN BEGIN # SET UP ERROR FLAGS # IF CM$CODE[0] EQ CUBSTAT"SCRPOOL" THEN # SET ERROR FLAG IN SMMAP ENTRY # BEGIN CM$FLAG1[0] = TRUE; CALL3(REQTYP3"UPD$MAP",PK$CSU$ENT[0],0,0,FLAG); END ELSE # SET LOST FLAG IN CATALOG ENTRY # BEGIN CALL3(REQTYP3"UPD$CAT",PK$CSU$ENT[0],UCF"LOST",1,FLAG); END IF FLAG NQ RESPTYP3"OK3" THEN BEGIN LBRESP(FLAG,TYP"TYP3"); REQCODE = REQTYP4"UNLD$CART"; CALL4(REQCODE,0,0,SM$EXIT$TY,SM$TY$Z,RESP$CODE); IF RESP$CODE NQ RESPTYP4"OK4" THEN BEGIN LBRESP(RESP$CODE,TYP"TYP4"); RETURN; END RETURN; END DLABFLD; REQCODE = REQTYP4"UNLD$CART"; CALL4(REQCODE,0,0,SM$EXIT$TY,SM$TY$Z,RESP$CODE); IF RESP$CODE NQ RESPTYP4"OK4" THEN BEGIN LBRESP(RESP$CODE,TYP"TYP4"); RETURN; END ERRCODE = S"UNXP$CYZFS"; LBERR(ERRCODE); # DO ERROR PROCESSING # RETURN; END # SET UP ERROR FLAGS # # * GENERATE LABEL AND UPDATE SMUMAP. # GENLAB(LABTYPE"SCR$LAB",PT$CSU$ENT[0],LD$CNT,LD$ERR, ## SR$ERR,SW$ERR,HR$ERR,STR$RD,STR$WR,STR$DM); P = NEWLABP; IF B<0,8>LAB$CSN[0] NQ X"C9" ## OR B<8,8>LAB$CSN[0] NQ X"C2" OR B<16,8>LAB$CSN[0] NQ X"D4" THEN # CARTRIDGE IS NOT IBM # BEGIN LAB$CCOD[0] = OTHCART; END ELSE BEGIN LAB$CCOD[0] = IBMCART; END LAB$CRLD[0] = LAB$CRLD[0] + 1; # UPDATE LOAD/PASS COUNTS # IF LBARG$PT[0] EQ "D" THEN # CLEAR CSU, Y, Z FIELDS # BEGIN LAB$SMID[0] = 0; LAB$Y[0] = 12; # SET TO CAS EXIT # LAB$Z[0] = 0; END P= LOC(PK$CSU$ENT[0]); IF CM$CODE[0] EQ CUBSTAT"SUBFAM" THEN # ASSIGNED TO FAMILY # BEGIN REQCODE = REQTYP3"RMV$CART"; END ELSE # ASSIGNED TO POOL # BEGIN REQCODE = REQTYP3"UPD$MAP"; CM$CSND[0] = " "; # REMOVE VSN FROM SMMAP ENTRY # CM$CCOD[0] = " "; CM$FLAG1[0] = FALSE; # CLEAR ERROR FLAG IN MAP ENTRY # END CALL3(REQCODE,PK$CSU$ENT[0],0,0,RESP$CODE); IF RESP$CODE NQ RESPTYP3"OK3" THEN # FAMILY/POOL REMOVAL FAILS # BEGIN # PROCESS ERROR RESPONSE # IF RESP$CODE NQ RESPTYP3"MSC$NEMPTY" THEN BEGIN LBRESP(RESP$CODE,TYP"TYP3"); REQCODE = REQTYP4"UNLD$CART"; CALL4(REQCODE,0,0,SM$EXIT$TY,SM$TY$Z,RESP$CODE); IF RESP$CODE NQ RESPTYP4"OK4" THEN BEGIN LBRESP(RESP$CODE,TYP"TYP4"); RETURN; END RETURN; END ELSE BEGIN # PROCESS CARTRIDGE NOT EMPTY # # * UNLOAD CARTRIDGE BACK AT ORIGINAL LOCATION. # CALL4(REQTYP4"UNLD$CART",DRD$NUM,CART$CSN,PK$Y[0], ## PK$Z[0],RESP$CODE); IF RESP$CODE NQ RESPTYP4"OK4" THEN BEGIN LBRESP(RESP$CODE,TYP"TYP4"); RETURN; END ERRCODE = S"CR$NTEMPT"; LBERR(ERRCODE); END # PROCESS CARTRIDGE NOT EMPTY # END # PROCESS ERROR RESPONSE # # * WRITE NEW LABEL AND PUT CARTRIDGE IN NEW LOCATION. # REQCODE = REQTYP4"WRT$LAB"; CALL4(REQCODE,DRD$NUM,CART$CSN,PT$Y,PT$Z,RESP$CODE); IF RESP$CODE NQ RESPTYP4"OK4" THEN # *WRITE* FAILS # BEGIN LBRESP(RESP$CODE,TYP"TYP4"); RETURN; END IF LBARG$PT[0] EQ "P" THEN BEGIN # ADD CARTRIDGE TO POOL # REQCODE = REQTYP3"UPD$MAP"; P = LOC(PT$CSU$ENT[0]); CM$CSND[0] = LAB$CSND[0]; CM$CCOD[0] = LAB$CCOD[0]; # * ADD CARTRIDGE TO POOL. # CALL3(REQCODE,PT$CSU$ENT[0],0,0,RESP$CODE); IF RESP$CODE NQ RESPTYP3"OK3" THEN # MAP UPDATE FAILS # BEGIN LBRESP(RESP$CODE,TYP"TYP3"); RETURN; END END # ADD CARTRIDGE TO POOL # MFLUSH; # FLUSH MAP BUFFER # END RETURN; END # LBRMMSC # TERM PROC LBRSMSC; # TITLE LBRSMSC - RESTORES A CARTRIDGE TO THE CSU. # BEGIN # LBRSMSC # # ** LBRSMSC - RESTORES A CARTRIDGE TO THE CSU. * * THIS PROC GETS A CARTRIDGE FROM THE INPUT DRAWER AND RETURNS * IT TO ITS ASSIGNED LOCATION. * * PROC LBRSMSC. * * ENTRY CRACKED AND SYNTAX CHECKED DIRECTIVE * PARAMETERS SET UP IN COMMON AREA DEFINED * IN *COMTLBP*. * * EXIT CARTRIDGE RESTORED OR ERROR CONDITION. * * NOTES PROC *LBRSMSC* CHECKS THAT THERE IS A CARTRIDGE IN * AN INPUT DRAWER AS SPECIFIED, AND CALLS EXEC TO * BRING THE CARTRIDGE TO A DRIVE AND READ ITS LABEL. * IF THE LABEL HAS THE CORRECT *SM* NUMBER, AND IF * A SMMAP ENTRY IS FOUND WITH MATCHING VSN, FAMILY, * SUBFAMILY, AND COORDINATES, THEN EXEC IS CALLED TO * REPLACE THE CARTRIDGE AND UPDATE THE CATALOG. # # **** PROC LBRSMSC - XREF LIST BEGIN. # XREF BEGIN PROC CALL3; # ISSUES TYPE 3 CALLSS TO EXEC # PROC CALL4; # ISSUES TYPE 4 CALLSS TO EXEC # PROC DLABFLD; # DISPLAY CARTRIDGE LABEL FIELDS # PROC LBERR; # *SSLABEL* ERROR PROCESSOR # PROC LBRESP; # RESPONSE CODE PROCESSOR # PROC SERCSU; # SEARCHES SMMAP # END # **** PROC LBRSMSC - XREF LIST END. # DEF LISTCON #0#; # DO NOT LIST COMDECKS # *CALL COMBFAS *CALL COMBCPR *CALL COMBLBL *CALL COMBMAP *CALL COMTERR *CALL COMTLAB *CALL COMTLBP ITEM CART$CSN C(20); # CARTRIDGE SERIAL NUMBER # ITEM CATFLD U; # CATALOG FIELD # ITEM CATVALUE I; # CATALOG VALUE # ITEM FLAG I; # ERROR FLAG # ITEM I I; # INDUCTION VARIABLE # ITEM REQCODE I; # REQUEST CODE # ITEM RESP$CODE I; # RESPONSE CODE # ITEM SERTYPE S:SERCH$TYPE; # SEARCH TYPE # ITEM SLOT I; # DRAWER NUMBER # ITEM SP$VSN C(8); # SPECIFIED *CSN* # ITEM SP$Y I; # SPECIFIED Y # ITEM SP$Z I; # SPECIFIED Z # ARRAY PT$CSU$ENT [0:0] P(5); # *PUT* SMMAP ENTRY # BEGIN ITEM PT$MAPENT C(00,00,30); # THREE WORD MAP ENTRY # ITEM PT$Y U(03,00,30); # Y COORDINATE # ITEM PT$Z U(03,30,30); # Z COORDINATE # ITEM PT$GR U(04,00,07); # GROUP # ITEM PT$GRT U(04,07,04); # GROUP ORDINAL # END BASED ARRAY TEMP$LAB [0:0] P(1); BEGIN ITEM TEMP$LABW U(00,00,60); END CONTROL EJECT; # * FIND CARTRIDGE IN SPECIFIED INPUT DRAWER AND LOAD IT. # REQCODE = REQTYP4"LOAD$CART"; PT$Y[0] = 14; PT$Z[0] = 0; CALL4(REQCODE,DRD$NUM,CART$CSN,PT$Y[0],PT$Z[0],RESP$CODE); IF RESP$CODE NQ RESPTYP4"OK4" ## THEN # LOAD FAILS # BEGIN LBRESP(RESP$CODE,TYP"TYP4"); RETURN; END DRD$NUM = CPR$DRD[0]; # SET UP TRANSPORT ID # P = OLDLABP; # * COMPARE THE CSU-ID, FAMILY AND THE SUBFAMILY IN THE LABEL * AGAINST THE USER SPECIFIED VALUES. # IF LAB$SMID[0] NQ LBARG$SM[0] THEN BEGIN DLABFLD; # DISPLAY LABEL FIELDS # REQCODE = REQTYP4"UNLD$CART"; CALL4(REQCODE,0,0,SM$EXIT$TY,SM$TY$Z,RESP$CODE); IF RESP$CODE NQ RESPTYP4"OK4" THEN BEGIN LBRESP(RESP$CODE,TYP"TYP4"); RETURN; END ERRCODE = S"UNXP$CYZFS"; LBERR(ERRCODE); # DO ERROR PROCESSING # RETURN; END SERTYPE = S"CSN$MATCH"; SP$VSN = LAB$CSND[0]; # SEARCH SMMAP FOR VSN MATCH # SERCSU(SERTYPE,0,0,0,SP$VSN,0,0,PT$CSU$ENT[0],FLAG); IF FLAG NQ OK THEN # VSN NOT FOUND # BEGIN DLABFLD; # DISPLAY LABEL FIELDS # REQCODE = REQTYP4"UNLD$CART"; CALL4(REQCODE,0,0,SM$EXIT$TY,SM$TY$Z,RESP$CODE); IF RESP$CODE NQ RESPTYP4"OK4" THEN BEGIN LBRESP(RESP$CODE,TYP"TYP4"); RETURN; END ERRCODE = S"CSN$NOTFND"; LBERR(ERRCODE); # DO ERROR PROCESSING # RETURN; END P = LOC(PT$CSU$ENT[0]); # * CHECK TO SEE IF LABEL AND MAP ENTRY DIFFER ON * Y, Z, FAMILY, OR SUBFAMILY. # IF LAB$Y[0] NQ PT$Y[0] ## OR LAB$Z[0] NQ PT$Z[0] ## OR LAB$FMLY[0] NQ CM$FMLYNM[0] ## OR LAB$SF[0] NQ CM$SUB[0] THEN BEGIN REQCODE = REQTYP4"UNLD$CART"; CALL4(REQCODE,0,0,SM$EXIT$TY,SM$TY$Z,RESP$CODE); IF RESP$CODE NQ RESPTYP4"OK4" THEN BEGIN LBRESP(RESP$CODE,TYP"TYP4"); RETURN; END DLABFLD; # DISPLAY LABEL FIELDS # ERRCODE = S"UNXP$CYZFS"; LBERR(ERRCODE); # DO ERROR PROCESSING # RETURN; END # * CLEAR *LOST* FLAG IN THE CATALOG IF THE CARTRIDGE IS TO BE * RESTORED TO THE FAMILY OR CLEAR SMMAP ERROR FLAG IF THE * CARTRIDGE IS TO BE RESTORED TO THE POOL AND RETURN THE * CARTRIDGE TO ITS ASSIGNED LOCATION. # IF CM$CODE[0] EQ CUBSTAT"SUBFAM" THEN BEGIN # CLEAR *LOST* FLAG # REQCODE = REQTYP3"UPD$CAT"; CATFLD = UCF"LOST"; CATVALUE = 0; # CLEAR *LOST* FLAG IN CATALOG # CALL3(REQCODE,PT$CSU$ENT[0],CATFLD,CATVALUE,RESP$CODE); END # CLEAR *LOST* FLAG # ELSE BEGIN # CLEAR SMMAP ERROR FLAG # P = LOC(PT$CSU$ENT[0]); CM$FLAG1[0] = FALSE; REQCODE = REQTYP3"UPD$MAP"; CALL3(REQCODE,PT$CSU$ENT[0],0,0,FLAG); END # CLEAR SMMAP ERROR FLAG # IF RESP$CODE NQ RESPTYP3"OK3" THEN # UPDATE CATALOG/MAP FAILED # BEGIN REQCODE = REQTYP4"UNLD$CART"; CALL4(REQCODE,0,0,SM$EXIT$TY,SM$TY$Z,RESP$CODE); IF RESP$CODE NQ RESPTYP4"OK4" THEN BEGIN LBRESP(RESP$CODE,TYP"TYP4"); RETURN; END DLABFLD; # DISPLAY LABEL FIELDS # LBRESP(RESP$CODE,TYP"TYP3"); RETURN; END # * PUT CARTRIDGE IN ASSIGNED LOCATION. # P = OLDLABP; P = NEWLABP; SLOWFOR I = 0 STEP 1 UNTIL LABLEN-1 DO # MOVE LABEL TO NEW BUFFER # BEGIN TEMP$LABW[I] = LAB$W1[I]; END REQCODE = REQTYP4"UNLD$CART"; CALL4(REQCODE,DRD$NUM,CART$CSN,PT$Y[0],PT$Z[0],RESP$CODE); IF RESP$CODE NQ RESPTYP4"OK4" THEN # PUT FAILS # BEGIN DLABFLD; # DISPLAY LABEL FIELDS # LBRESP(RESP$CODE,TYP"TYP4"); END RETURN; END # LBRSMSC # TERM PROC LBSTCLR; # TITLE LBSTCLR - STORES A *CE* CARTRIDGE IN 0,0 OR 0,15. # BEGIN # LBSTCLR # # ** LBSTCLR - STORES A *CE* CARTRIDGE IN 0,0 OR 0,15. * * THIS PROC STORES A SPECIAL CARTRIDGE IN ONE OF TWO SPECIFIC * LOCATIONS. * * PROC LBSTCLR. * * ENTRY (LBARG$CC) = IF EQUAL TO 0, STORE CARTRIDGE FROM * DRAWER TO LOCATION 0,0. * IF EQUAL TO 15, STORE INTO 0,15. * * EXIT CARTRIDGE IN LOCATION SPECIFIED. * # DEF LISTCON #0#; # DO NOT DEF LIST COMDECKS # # **** PROC LBSTCLR - XREF LIST BEGIN. # XREF BEGIN PROC CALL4; # MAKE TYPE 4 REQUESTS # PROC CKLAB; # CHECK LABEL # PROC GENLAB; # GENERATE CARTRIDGE LABEL # PROC LBERR; # PROCESS ERROR RESPONSE # PROC LBRESP; # PROCESS ERROR FROM EXEC # PROC SERCSU; # SEARCH SMMAP # END # **** PROC LBSTCLR - XREF LIST END. # *CALL COMBFAS *CALL COMBCMD *CALL COMBCPR *CALL COMBLBL *CALL COMBMAP *CALL COMTERR *CALL COMTLAB *CALL COMTLBP ITEM FLAG U; # RESPONSE FLAG # ITEM Y U; # Y COORDINATE # ITEM Z U; # Z COORDINATE # ITEM SERTYPE S:SERCH$TYPE; # TYPE OF SERACH # ARRAY PT$CSU$ENT [0:0] P(4); # *PUT* SMMAP ENTRY # BEGIN ITEM PT$MAPENT C(00,00,30); # THREE WORD MAP ENTRY # ITEM PT$Y U(03,00,30); # Y COORDINATE # ITEM PT$Z U(03,30,30); # Z COORDINATE # END CONTROL EJECT; # * LOAD CARTRIDGE FROM INPUT DRAWER AND READ LABEL. # Y = SM$ENT$TY; Z = SM$TY$Z; CALL4(REQTYP4"LOAD$CART",0,0,Y,Z,FLAG); IF FLAG NQ RESPTYP4"OK4" ## AND FLAG NQ RESPTYP4"UNK$CART" ## AND FLAG NQ RESPTYP4"CART$LB$ERR" THEN BEGIN CALL4(REQTYP4"UNLD$CART",0,0,SM$EXIT$TY,Z,FLAG); IF FLAG NQ RESPTYP4"OK4" THEN BEGIN LBRESP(FLAG,TYP"TYP4"); END ERRCODE = S"M86$HARDWR"; LBERR(ERRCODE); RETURN; END # * SERACH SMMAP FOR DUPLICATE *CSN*. # SERTYPE = S"CSN$MATCH"; SERCSU(SERTYPE,0,0,0,LAB$CSND[0],0,0,PT$CSU$ENT[0],FLAG); IF FLAG EQ 0 THEN # *CSN* IN MAP # BEGIN CALL4(REQTYP4"UNLD$CART",0,0,SM$EXIT$TY,SM$TY$Z,FLAG); IF FLAG NQ RESPTYP4"OK4" THEN BEGIN LBRESP(FLAG,TYP"TYP4"); RETURN; END ERRCODE = S"DUPL$CSN"; LBERR(ERRCODE); RETURN; END # * PUT CARTRIDGE BACK TO DRAWER IF LABEL IS FROM FAMILY OR POOL. # P = OLDLABP; CKLAB(FLAG); IF FLAG EQ LABTYPE"FAM$LAB" ## THEN BEGIN ERRCODE = S"GOOD$LAB"; LBERR(ERRCODE); RETURN; END # * GENERATE NEW LABEL. # P = LOC(PT$CSU$ENT[0]); PT$Y[0] = 0; PT$Z[0] = LBARG$CC[0]; CM$SUB[0] = 0; CM$FMLYNM[0] = " "; GENLAB(LABTYPE"SCR$LAB",PT$CSU$ENT[0],0,0,0,0,0,0); LAB$CLF[0] = 2; LAB$RCORD[0] = 6652; # * STORE CARTRIDGE. # CALL4(REQTYP4"WRT$LAB",0,0,PT$Y[0],PT$Z[0],FLAG); IF FLAG NQ RESPTYP4"OK4" THEN BEGIN LBRESP(FLAG,TYP"TYP4"); RETURN; END END TERM PROC SERAST(FCTORD,FLAG); # TITLE SERAST - SEARCHES THE AST FOR AN EMPTY CARTRIDGE. # BEGIN # SERAST # # ** SERAST - SEARCHES THE AST FOR AN EMPTY CARTRIDGE. * * THIS PROC READS THE *AST* AND IFNDS THE FIRST EMPTY * CARTRIDGE IN A SPECIFIED GROUP. * * PROC SERAST(FCTORD,FLAG) * * ENTRY (LB$BUFP) = FWA OF A BUFFER 1101B WORDS LONG. * (GROUP) = IF GROUP = 0 THEN THE GROUP PARAMETER * IS IGNORED. OTHERWISE, SELECT FROM THE * SPECIFIED GROUP. * * EXIT (FCTORD) = FCT ORDINAL OF EMPTY CARTRIDGE, IF ANY. * FREE, IF ANY. * (FLAG) = ITEM INDICATING RESULT OF SEARCH. * 0, EMPTY CARTRIDGE FOUND. * 1, NO EMPTY CARTRIDGES. * * NOTES PROC *SERAST* READS THE *AST* FOR THE SPECIFIED * SUBFAMILY AND GROUP. THE *AST* IS SEARCHED * THE SPECIFIED SUBFAMILY. THE AST IS SEARCHED * SEQUENTIALLY FOR AN EMPTY CARTRIDGE. IF NO EMPTY * CARTRIDGES EXIST, THEN * FLAG* IS SET TO 1. # # **** PROC SERAST - XREF LIST BEGIN. # XREF BEGIN PROC CRDAST; # READS AVAILABLE STREAM TABLE # PROC LBERR; # *SSLABEL* ERROR PROCESSOR # PROC LBRESP; # RESPONSE CODE PROCESSOR # END # **** PROC SERAST - XREF LIST END. # DEF LISTCON #0#; # DO NOT LIST COMDECKS # *CALL COMBFAS *CALL COMBCMD *CALL COMBMCT *CALL COMTLAB *CALL COMTLBP *CALL COMTERR ITEM FCTORD U; # EMPTY CARTRIDGE FCT ORDINAL # ITEM FLAG I; # ERROR FLAG # ITEM GROUP I; # SPECIFIED GROUP # ITEM I I; # INDUCTION VARIABLE # ITEM START U; # BEGINNING OF SEARCH # ITEM TERMX U; # END OF SEARCH # CONTROL EJECT; # * READ AST. # CRDAST(LBARG$FM[0],LBARG$SB[0],LBARG$SMID[0],ASTBADR,0,FLAG); IF FLAG NQ OK THEN BEGIN LBRESP(FLAG,0); RETURN; END # * SET AST BASED ARRAY POINTER. # P = ASTBADR; # * SEARCH FOR FIRST EMPTY CARTIDGE IN SPECIFIED GROUP. # FLAG = 1; FCTORD = -1; IF LBARG$GR[0] LS 0 THEN # GROUP IS NOT SPECIFIED # BEGIN START = 16; TERMX = MAXORD; END ELSE BEGIN START = LBARG$GR[0] * 16; TERMX = START + 15; END SLOWFOR I = START STEP 1 WHILE (I LQ TERMX) AND (FCTORD EQ -1) DO # SEARCH FOR EMPTY CARTRIDGE # BEGIN IF AST$STAT[I] EQ ASTENSTAT"ASS$CART" ## AND AST$GR[I] NQ 0 ## AND (AST$AULF[I] + AST$AUSF[I] + AST$FLAWS[I] EQ INAVOT) THEN # CARTRIDGE IS FOUND # BEGIN FCTORD = I; FLAG = 0; TEST I; END END RETURN; END # SERAST # TERM PROC SERASTG(GROUP,GRT,FLAG); # TITLE SERASTG - SEARCHES THE AST FOR AN AVAILABLE GROUP ORDINAL. # BEGIN # SERASTG # # ** SERASTG - SEARCHES THE AST FOR AN AVAILABEL GROUP ORDINAL. * * THIS PROC READS THE AST AND FINDS * * PROC SERASTG(GROUP,GRT,FLAG) * * (GROUP) = IF NEGATIVE FIND DEFAULT GROUP AND * ORDINAL, OTHERWISE FIND GROUP ORDINAL * FOR THE SPECIFIED GROUP. * ENTRY (LB$BUFP) = FWA OF A BUFFER 1101B WORDS LONG. * * EXIT * (FLAG) = ITEM INDICATING RESULT OF SEARCH. * (GROUP) = DEFAULT OR SPECIFIED GROUP. * (GRT) = GROUP ORDINAL IF AVAILABLE. * * NOTES PROC *SERAST* READS THE AVAILABLE STREAM TABLE FOR # ITEM FCTORD U; # EMPTY CARTRIDGE FCT ORDINAL # ITEM FLAG I; # ERROR FLAG # ITEM GROUP I; # GROUP # ITEM GRT I; # GROUP ORDINAL # ITEM I I; # INDUCTION VARIABLE # ITEM START U; # BEGINNING OF SEARCH # ITEM TERMX U; # END OF SEARCH # # **** PROC SERAST - XREF LIST BEGIN. # XREF BEGIN PROC COPEN; # OPEN CATALOGS # PROC CCLOSE; # CLOSE SFMCAT # PROC CRDAST; # READS AVAILABLE STREAM TABLE # PROC LBERR; # *SSLABEL* ERROR PROCESSOR # PROC LBRESP; # RESPONSE CODE PROCESSOR # FUNC XCOD; # CONVERT TO DISPLAY CODE # PROC LOFPROC; # LIST OF FILES # END # **** PROC SERAST - XREF LIST END. # DEF LISTCON #0#; # DO NOT LIST COMDECKS # *CALL COMBFAS *CALL COMBCMD *CALL COMBCMS *CALL COMBMCT *CALL COMTLAB *CALL COMTLBP *CALL COMTERR ARRAY MSFCATNM [0:0] P(1); # CATALOG NAME # BEGIN ITEM MSFCAT$NM C(00,00,06); # FIRST SIX CHARACTERS # ITEM MSFCAT$LST C(00,36,01); # LAST CHARACTER # END CONTROL EJECT; # * OPEN CATALOG. # MSFCAT$NM[0] = SFMCAT; MSFCAT$LST[0] = XCOD(LBARG$SB[0]); COPEN(LBARG$FM[0],LBARG$SB[0],MSFCATNM[0],"RM",TRUE,FLAG); IF FLAG EQ CMASTAT"NOERR" THEN BEGIN LOFPROC(OCT$LFN[1]); # ADD LFN TO LIST OF FILES # END IF FLAG NQ CMASTAT"NOERR" AND FLAG NQ CMASTAT"FOPEN" THEN # ERROR CONDITION OTHER THAN CATALOG ALREADY OPEN # BEGIN LBRESP(FLAG,0); RETURN; END # * READ AST. # CRDAST(LBARG$FM[0],LBARG$SB[0],LBARG$SMID[0],ASTBADR,0,FLAG); IF FLAG NQ OK THEN BEGIN LBRESP(FLAG,0); RETURN; END # * SET AST BASED ARRAY POINTER. # P = ASTBADR; CCLOSE(LBARG$FM[0],LBARG$SB[0],0,FLAG); # * FIND DEFAULT GROUP IF GROUP IS NEGATIVE, OR GROUP * ORDINAL IF GROUP IS SPECIFIED. # FLAG = 1; IF GROUP LS 0 THEN BEGIN SLOWFOR I = 16 STEP 1 ## WHILE GROUP LS 0 ## AND I LQ (MAXORD + 15) DO # FIND DEFAULT GROUP # BEGIN IF (AST$STAT[I] NQ ASTENSTAT"ASS$CART") AND (AST$GR[I] EQ 0) THEN # AVAILABLE ENTRY FOUND # BEGIN GROUP = I/16; FLAG = 0; TEST I; END END IF FLAG NQ 0 THEN BEGIN RETURN; END END # * FIND ORDINAL WITHIN GROUP. # GRT = -1; START = GROUP * 16; TERMX = START + 15; SLOWFOR I = START STEP 1 WHILE I LQ TERMX AND (GRT EQ -1) DO # SEARCH GROUP FOR AVAILABLE ORD # BEGIN IF AST$GRT[I] EQ 0 AND AST$STAT[I] NQ ASTENSTAT"ASS$CART" THEN BEGIN GRT = I - (I/16 * 16); FLAG = 0; TEST I; END END RETURN; END # SERAST # TERM PROC SERCSU((SERTYPE),(SP$Y),(SP$Z),(SP$CODE),(SP$VSN),(SP$FAM),## (SP$SUB),PK$CSU$ENT,SERFLAG); # TITLE SERCSU - SEARCHES SMMAP FOR A CUBE OR A CARTRIDGE. # BEGIN # SERCSU # # ** SERCSU - SEARCHES SMMAP FOR A CUBE OR A CARTRIDGE. * * THIS PROC SEARCHES SMMAP FOR A SPECIFIC ENTRY. * * PROC SERCSU((SERTYPE),(SP$Y),(SP$Z),(SP$CODE),(SP$VSN), * (SP$FAM),(SP$SUB),PK$CSU$ENT,SERFLAG) * * ENTRY SERTYPE, A STATUS ITEM SPECIFYING TYPE OF * SEARCH TO BE CONDUCTED. * S"LST$UNAS" SEARCH FOR LAST * UNASSIGNED CUBE. * S"LOC" SEARCH FOR A SPECIFIC * LOCATION (SP$Y,SP$Z). * S"ASSIGN" SEARCH FOR A SPECIFIC * CARTRIDGE OR ANY CUBE * ASSIGNED TO FAMILY OR * POOL. * S"CSN$MATCH" SEARCH FOR A MATCHING * VSN. * S"CART$POOL" SEARCH FOR ANY CARTRIDGE * ASSIGNED TO A POOL. * S"ASGN$FAM" SEARCH FOR ANY ENTRY * ASSIGNED TO A GIVEN * FAMILY. * SP$Y, AN ITEM CONTAINING THE Y COORDINATE. * SP$Z, AN ITEM CONTAINING THE Z COORDINATE. * SP$CODE, A STATUS ITEM CONTAINING THE TYPE * OF ASSIGNMENT OF CUBE OR CARTRIDGE. * SP$VSN, AN ITEM CONTAINING THE VSN. * SP$FAM, AN ITEM CONTAINING THE FAMILY. * SP$SUB, AN ITEM CONTAINING THE SUB FAMILY. * * EXIT SEARCH COMPLETE. * PK$CSU$ENT, AN ARRAY CONTAINING THE SMMAP * ENTRY. * SERFLAG, AN ITEM CONTAINING THE ERROR STATUS. * 0 - ENTRY FOUND. * 1 - ENTRY NOT FOUND. * * MESSAGES SSLABEL ABNORMAL, SERCSU. * * NOTES PROC *SERCSU* SEARCHES THE SMMAP FOR A * SPECIFIC CUBE OR CARTRIDGE DEPENDING ON * *SERTYPE*. THE ORDINAL OF THE SMMAP ENTRY * IS MAPPED BACK INTO THE Y AND Z COORDINATES * WHICH ARE PUT IN THE THIRD WORD ADDED TO THE * TWO WORD SMMAP ENTRY IN *PK$CSU$ENT*. IF * THE SPECIFIC ENTRY IS NOT FOUND, AN ERROR * STATUS IS RETURNED BACK TO THE CALLING PROC. # ITEM SERTYPE U; # SMMAP SEARCH TYPE # ITEM SP$Y I; # SPECIFIED Y COORDINATE OF CUBE/CARTRIDGE # ITEM SP$Z I; # SPECIFIED Z COORDINATE OF CUBE/CARTRIDGE # ITEM SP$CODE U; # CODE FOR CUBE/CARTRIDGE ASSIGNMENT # ITEM SP$VSN C(8); # SPECIFIED *CSN* # ITEM SP$FAM C(7); # SPECIFIED FAMILY TO PROCESS # ITEM SP$SUB U; # SPECIFIED SUBFAMILY # ARRAY PK$CSU$ENT [0:0] P(4); # *PICK* SMMAP ENTRY # BEGIN ITEM PK$MAPENT C(00,00,30); # THREE WORD SMMAP ENTRY # ITEM PK$Y U(03,00,30); # Y COORDINATE # ITEM PK$Z U(03,30,30); # Z COORDINATE # END ITEM SERFLAG I; # ERROR FLAG # # **** PROC SERCSU - XREF LIST BEGIN. # XREF BEGIN PROC MESSAGE; # DISPLAYS MESSAGES # PROC MGETENT; # GETS SMMAP ENTRY # PROC RESTPFP; # RESTORE USER-S *PFP* AND ABORT OR RETURN # END # **** PROC SERCSU - XREF LIST END. # DEF PROCNAME #"SERCSU."#; # PROC NAME # DEF LISTCON #0#; # DO NOT LIST COMDECKS # *CALL COMBFAS *CALL COMBCMS *CALL COMBMAP *CALL COMTLAB *CALL COMTLBP ITEM FLAG I; # ERROR FLAG # ITEM I I; # LOOP VARIABLE # ITEM PK$CSU$ADR I; # ADDRESS OF THE SMMAP ENTRY # SWITCH SEARCH : SERCH$TYPE SER$LSTUN: LST$UNAS, # SEARCH FOR LAST UNASSIGNED CUBE # SER$LOC: LOC, # SEARCH FOR A LOCATION # SER$ASG: ASSIGN, # SEARCH FOR A SPECIFIC CUBE OR CARTRIDGE ASSIGNED TO FAMILY OR POOL # SER$VSN: CSN$MATCH, # SEARCH FOR A VSN # SER$CARPL: CART$POOL, # SEARCH FOR CARTRIDGE IN POOL # SER$ASNFM: ASGN$FAM; # SEARCH FOR AN ENTRY ASSIGNED TO A GIVEN FAMILY # CONTROL EJECT; SERFLAG = 1; # INITIALIZE ERROR FLAG TO AN ERROR CONDITION # # * CHECK *SERTYPE* FOR THE TYPE OF SEARCH TO BE * CONDUCTED AND GO TO THE CORRESPONDING STATUS * SWITCH TO PROCESS IT. # PK$CSU$ADR = LOC(PK$CSU$ENT[0]); P = PK$CSU$ADR; # SMMAP ENTRY FORMAT # GOTO SEARCH[SERTYPE]; # * SEARCH FOR LAST UNASSIGNED CUBE. # SER$LSTUN: SLOWFOR I = MAXORD STEP -1 UNTIL 1 DO BEGIN # SEARCH SMMAP BACKWARDS # MGETENT(LBARG$SMID[0],I,PK$CSU$ADR,FLAG); IF FLAG NQ CMASTAT"NOERR" THEN # ERROR CONDITION # BEGIN GOTO ERROR; # PROCESS THE ERROR # END IF CM$CODE[0] EQ CUBSTAT"UNASGN" THEN # ENTRY IS FOUND # BEGIN GOTO SER$END; END END # SEARCH SMMAP BACKWARDS # RETURN; # ENTRY NOT FOUND # # * SEARCH FOR A LOCATION IN CSU. # SER$LOC: I = MAXORD - SP$Z - (SP$Y * (MAX$Z + 1)); # CALCULATE ORDINAL # MGETENT(LBARG$SMID[0],I,PK$CSU$ADR,FLAG); IF FLAG NQ CMASTAT"NOERR" THEN # ERROR CONDITION # BEGIN GOTO ERROR; # PROCESS THE ERROR # END PK$Y[0] = SP$Y; PK$Z[0] = SP$Z; SERFLAG = 0; # CLEAR ERROR STATUS # RETURN; # * SEARCH FOR A SPECIFIC CARTRIDGE. # SER$ASG: SLOWFOR I = 1 STEP 1 UNTIL MAXORD DO BEGIN # SEARCH SMMAP # MGETENT(LBARG$SMID[0],I,PK$CSU$ADR,FLAG); IF FLAG NQ CMASTAT"NOERR" THEN # ERROR CONDITION # BEGIN GOTO ERROR; # PROCESS THE ERROR # END # * CHECK FAMILY, SUBFAMILY, * ASSIGNMENT, AND VSN. # IF (CM$FMLYNM[0] EQ SP$FAM) ## AND (CM$SUB[0] EQ SP$SUB) ## AND (CM$CODE[0] EQ SP$CODE) ## AND (CM$CSND[0] EQ SP$VSN) THEN BEGIN GOTO SER$END; # ENTRY FOUND # END END # SEARCH SMMAP # RETURN; # ENTRY NOT FOUND # # * SEARCH FOR A MATCHING VSN. # SER$VSN: SLOWFOR I = 1 STEP 1 UNTIL MAXORD DO BEGIN # SEARCH SMMAP # MGETENT(LBARG$SMID[0],I,PK$CSU$ADR,FLAG); IF FLAG NQ CMASTAT"NOERR" THEN # ABNORMAL ERROR CONDITION # BEGIN GOTO ERROR; # PROCESS THE ERROR # END IF CM$CSND[0] EQ SP$VSN THEN # VSN MATCH FOUND # BEGIN GOTO SER$END; END END # SEARCH SMMAP # RETURN; # ENTRY NOT FOUND # # * SEARCH FOR A CARTRIDGE IN POOL. # SER$CARPL: SLOWFOR I = 1 STEP 1 UNTIL MAXORD DO BEGIN # SEARCH SMMAP # MGETENT(LBARG$SMID[0],I,PK$CSU$ADR,FLAG); IF FLAG NQ CMASTAT"NOERR" THEN # ERROR CONDITION # BEGIN GOTO ERROR; # PROCESS THE ERROR # END IF CM$CODE[0] EQ CUBSTAT"SCRPOOL" ## AND CM$CSND[0] NQ " " ## AND NOT CM$FLAG1[0] THEN # POOL CARTRIDGE FOUND # BEGIN GOTO SER$END; END END # SEARCH SMMAP # RETURN; # ENTRY NOT FOUND # # * SEARCH FOR AN ENTRY ASSIGNED TO A GIVEN FAMILY. # SER$ASNFM: SLOWFOR I = 1 STEP 1 UNTIL MAXORD DO BEGIN # SEARCH SMMAP # MGETENT(LBARG$SMID[0],I,PK$CSU$ADR,FLAG); IF FLAG NQ CMASTAT"NOERR" THEN # ERROR CONDITION # BEGIN GOTO ERROR; # PROCESS THE ERROR # END IF CM$FMLYNM[0] EQ SP$FAM ## AND CM$SUB[0] EQ SP$SUB THEN # ENTRY FOUND # BEGIN SERFLAG = 0; # CLEAR ERROR STATUS # RETURN; END END # SEARCH SMMAP # RETURN; # ENTRY NOT FOUND # # * SET UP Y AND Z COORDINATES. # SER$END: PK$Y[0] = (MAXORD - I)/(MAX$Z + 1); PK$Z[0] = MAXORD - I - (MAX$Z + 1) * PK$Y[0]; SERFLAG = 0; RETURN; # * PROCESS THE ERROR ENCOUNTERED WHILE * SEARCHING THE SMUMAP. # ERROR: LBMSG$PROC[0] = PROCNAME; MESSAGE(LBMSG[0],SYSUDF1); RESTPFP(PFP$ABORT); # RESTORE USER-S *PFP* AND ABORT # END # SERCSU # TERM PROC SETCORD; # TITLE SETCORD - SETS Y,Z COORDINATES OF CUBES. # BEGIN # SETCORD # # ** SETCORD - SETS Y,Z COORDINATES OF CUBES. * * THIS PROC SETS UP THE Y AND Z COORDINATE POSITIONS OF THE * CUBES SPECIFIED, IN A TABLE *YZCOORD*. IT ALSO RETURNS THE * NUMBER OF CUBES SITUATED WITHIN A SPECFIED AREA IN THE CSU. * * PROC SETCORD. * * ENTRY LBARG$YI, AN ITEM CONTAINING FIRST Y COORDINATE * OR -1. * LBARG$ZI, AN ITEM CONTAINING FIRST Z COORDINATE * OR -1. * LBARG$YF, AN ITEM CONTAINING SECOND Y COORDINATE * OR -1. * LBARG$ZF, AN ITEM CONTAINING SECOND Z COORDINATE * OR -1. * * EXIT YZCOORD, AN ARRAY IN COMMON CONTAINING THE Y, Z * COORDINATES OF ALL THE CUBES. * LBARG$N, AN ITEM IN COMMON CONTAINING * NUMBER OF CUBES. * * NOTES PROC *SETCORD* SETS UP THE Y AND Z COORDINATES OF * ALL THE CUBES SITUATED IN THE AREA OF THE *SM* * SPECIFIED BZ *YI*, *YF*, *ZI* AND *ZF*, IN THE * ARRAY *YZCOORD*. IT ALSO CALCULATES THE NUMBER OF * CUBES INVOLVED. IF MORE THAN *MAXNUM CUBE * LOCATIONS ARE SPECIFIED, AN INFORMATIVE MESSAGE * IS PLACED IN THE DAYFILE AND THE REPORT FILE * AND ONLY *MAXNUM* CUBES ARE PROCESSED. # # **** PROC SETCORD - XREF LIST BEGIN. # XREF BEGIN PROC LBERR; # *SSLABEL* ERROR PROCESSOR # END # **** PROC SETCORD - XREF LIST END. # DEF LISTCON #0#; # DO NOT LIST COMDECKS # *CALL COMBFAS *CALL COMTERR *CALL COMTLAB *CALL COMTLBP ITEM I I; # LOOP VARIABLE # ITEM J I; # LOOP VARIABLE # ITEM K I; # COUNTER FOR NUMBER OF CUBES # CONTROL EJECT; # * CHECK TO SEE IF A COLUMN OF CUBES, A ROW OF CUBES, * A RECTANGLE OF CUBES OR A SINGLE CUBE LOCATION IS * SPECIFIED. * IF *YI* ALONE IS SPECIFIED, SELECT A COLUMN * OF CUBES AT *YI*. # IF (LBARG$YI[0] NQ -1) AND (LBARG$ZI[0] EQ -1) THEN BEGIN LBARG$YF[0] = LBARG$YI[0]; LBARG$ZI[0] = 0; LBARG$ZF[0] = MAX$Z; # SET LIMIT ON Z COORDINATE # END # * IF *ZI* ALONE IS SPECIFIED, SELECT A ROW * OF CUBES AT *ZI*. # IF (LBARG$YI[0] EQ -1) AND (LBARG$ZI[0] NQ -1) THEN BEGIN LBARG$YI[0] = 0; LBARG$YF[0] = MAX$Y; # SET LIMIT ON Y COORDINATE # LBARG$ZF[0] = LBARG$ZI[0]; END # * IF *YI* AND *ZI* ALONE ARE SPECIFIED, SELECT * THE CUBE AT LOCATION (YI,ZI). # IF (LBARG$YI[0] NQ -1) ## AND (LBARG$ZI[0] NQ -1) ## AND (LBARG$YF[0] EQ -1) THEN BEGIN LBARG$YF[0] = LBARG$YI[0]; LBARG$ZF[0] = LBARG$ZI[0]; END # * SET UP THE COORDINATE POSITIONS IN ARRAY *YZCOORD*. # K = 1; SLOWFOR I = LBARG$YI[0] STEP 1 UNTIL LBARG$YF[0] DO BEGIN SLOWFOR J = LBARG$ZI[0] STEP 1 UNTIL LBARG$ZF[0] DO BEGIN # * SKIP OVER THE COORDINATE POSITIONS WHERE * NO CUBES EXIST. NO CUBES AT: * (0,0), ((Y=6),Y=0,21), (0,15), (11,15), (21,15), * ((Y,Z), Y= 11,15, Z= 0,1). # IF J EQ Z$NO$CUBE THEN # NO CUBES AT THIS LOCATION # BEGIN TEST J; END IF ((J EQ 0) ## AND((I EQ 0) ## OR (I EQ 11) ## OR (I EQ 12) ## OR (I EQ 13) ## OR (I EQ 14) ## OR (I EQ 15))) ## OR ((J EQ 1) ## AND ((I EQ 11) ## OR (I EQ 12) ## OR (I EQ 13) ## OR (I EQ 14) ## OR (I EQ 15))) ## OR ((J EQ 15) ## AND ((I EQ 0) ## OR (I EQ 11) ## OR (I EQ 21))) ## THEN # IGNORE NON-EXISTANT CUBES # BEGIN TEST J; END # * CHECK IF MORE THAN *MAXNUM* CUBE LOCATIONS * ARE SPECIFIED. # IF K GR MAXNUM THEN BEGIN ERRCODE = S"NUM$CUBE"; LBERR(ERRCODE); LBARG$N[0] = K - 1; RETURN; END Y$COORD[K] = I; # SET UP Y AND Z COORDINATES # Z$COORD[K] = J; K = K + 1; END END LBARG$N[0] = K - 1; # SET NUMBER OF CUBES # RETURN; END # SETCORD # TERM