FTN4,L,C PROGRAM DBSPA(4,90),92069-16133 REV.1912 790130 C C C****************************************************************** C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED C NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR C TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN C CONSENT OF HEWLETT-PACKARD COMPANY. C****************************************************************** C C C SOURCE: 92069-18133 C RELOC: 92069-16133 C C PRGMR: CEJ C C C****************************************************************** C C C C C DATA BASE SPACE IS A UTILITY PROGRAM FOR IMAGE/1000 WHICH REPORTS THE C STATUS OF ANY DATA SET ACCESSIBLE BY THE USER INITIATING DBSPA. THE C REPORTED BY DBSPA INCLUDES THE CAPACITY OF THE DATA SET AND THE NUMBER C OF FREE RECORDS IN THE DATA SET AS DEFINED BY THE ROOT FILE. THE NUM- C BER OF USED RECORDS WHICH ACTUALLY EXIST IN THE DATA SET, AND THE DIF- C FERENCE BETWEEN THE CAPACITY OF THE DATA SET AND THE SUM OF ITS FREE C AND USED RECORDS. A NON-ZERO DIFFERENCE SHOWN FOR ANY OF THE DATA SETS C MAY INDICATE THAT THE DATA BASE IS CORRUPT AND SOME FORM OF RECOVERY C OF THE DATA BASE SHOULD BE ATTEMPTED. C C THE USER INITIATES DBSPA WITH THE COMMAND: C C :RU,DBSPA[,INPUT[,OUTPUT[,ROOT FILE NAMR[,LEVEL CODE WORD]]]] C C WHERE: C INPUT C IS THE LU OF THE DEVICE TO BE USED FOR ANY FURTHER INPUT NECESSARY C TO DBSPA. DEFAULT IS THE SCHEDULING LU. C C OUTPUT C IS THE LU OF THE DEVICE TO BE USED BY DBSPA FOR OUTPUT. DEFAULT C IS THE INPUT LU, IF INTERACTIVE, ELSE LU 6. C C ROOT FILE NAMR C IS THE FMP NAMR FOR THE ROOT FILE OF THE DATA BASE WHOSE STATUS C IS TO BE REPORTED. NO DEFAULT. C C LEVEL CODE WORD C IS THE USER'S LEVEL CODE WORD FOR THE DATA BASE. NO DEFAULT. C C IF EITHER, OR BOTH, OF THE LATTER TWO PARAMETERS ARE OMITTED, DBSPA C WILL EXPECT THEM FROM THE INPUT DEVICE. IF THE INPUT DEVICE IS INTER- C ACTIVE, DBSPA WILL PROMPT THE USER FOR INPUT WITH: C C /DBSPA: ROOT FILE NAMR? C C AND/OR C C /DBSPA: LEVEL CODE WORD? C C ANY ERRORS ENCOUNTERED BY DBSPA WILL BE LOGGED ON THE INPUT DEVICE, C IF INTERACTIVE, ELSE LU 1. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C SAMPLE OUTPUT. C CCCCC C C GOOD STATUS: C CCCCC C C IMAGE/1000 DATA BASE SPACE UTILITY C C DATA SET NAME CAPACITY FREE RECORDS RECORDS USED DIFFERENCE C ------------- -------- ------------ ------------ ---------- C C GOOD 1001 984 17 0 C BAD 1001 984 17 0 C UGLY 50 40 10 0 C C END DBSPA C CCCCC C C POSSIBLY BAD STATUS: C CCCCC C C IMAGE/1000 DATA BASE SPACE UTILITY C C DATA SET NAME CAPACITY FREE RECORDS RECORDS USED DIFFERENCE C ------------- -------- ------------ ------------ ---------- C C GOOD 1001 985 17 -1 C BAD 1001 984 16 1 C UGLY 50 40 10 0 C C DATA BASE MAY NOT BE GOOD C C END DBSPA C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C DIMENSION IBUF(350),IBASE(11),LEVEL(3),ISTAT(10) DIMENSION URECS(50),DIFF(50),IOUTB(36) DIMENSION IHED1(36),IHED2(36),IWARN(13),IEND(5) DIMENSION IOERR(15),LKERR(17),IGTER(20),IOPER(15) DIMENSION IDSER(25) C INTEGER OUTLU LOGICAL IFTTY C COMMON IBUF,NSETS,IBASE COMMON LOGLN,LEVEL,INLU,OUTLU,LULOG COMMON IOUTB C EQUIVALENCE (IDUM,LEVEL),(NAME,IOUTB(3)) C DATA MAXLN/-80/,IOUTL/-72/,IBLNK/2H / DATA IHED1/2H D,2HAT,2HA ,2HSE,2HT ,2HNA,2HME,2H ,2H ,2HCA, 2 2HPA,2HCI,2HTY,2H ,2H ,2HFR,2HEE,2H R,2HEC,2HOR, 3 2HDS,2H ,2H ,2HRE,2HCO,2HRD,2HS ,2HUS,2HED,2H , 4 2H ,2HDI,2HFF,2HER,2HEN,2HCE/ DATA IHED2/2H -,2H--,2H--,2H--,2H--,2H--,2H--,2H ,2H ,2H--, 2 2H--,2H--,2H--,2H ,2H ,2H--,2H--,2H--,2H--,2H--, 3 2H--,2H ,2H ,2H--,2H--,2H--,2H--,2H--,2H--,2H , 4 2H ,2H--,2H--,2H--,2H--,2H--/ DATA IWARN/2H D,2HAT,2HA ,2HBA,2HSE,2H M,2HAY,2H N,2HOT, 2 2H B,2HE ,2HGO,2HOD/ DATA IWRNL/13/ DATA IEND/2H E,2HND,2H D,2HBS,2HPA/ DATA IENDL/5/ DATA IOERR/2H/D,2HBS,2HPA,2H -,2H E,2HRR,2HOR,2H O,2HN ,2HOU, 2 2HTP,2HUT,2H: ,2H ,2H / DATA IOELN/15/ DATA LKERR/2H/D,2HBS,2HPA,2H -,2H U,2HNA,2HBL,2HE ,2HTO,2H L, 2 2HOC,2HK ,2HOU,2HTP,2HUT,2H L,2HU / DATA LKERL/17/ DATA IGTER/2H/D,2HBS,2HPA,2H -,2H E,2HRR,2HOR,2H: ,2H ,2H , 2 2H ,2HON,2H D,2HAT,2HA ,2HSE,2HT ,2H ,2H ,2H / DATA IGTLN/20/ DATA IOPER/2H/D,2HBS,2HPA,2H -,2H E,2HRR,2HOR,2H: ,2H ,2H , 2 2H ,2HON,2H D,2HBO,2HPN/ DATA IOPLN/15/ DATA IDSER/2H/D,2HBS,2HPA,2H -,2H U,2HNA,2HBL,2HE ,2HTO,2H O, 2 2HBT,2HAI,2HN ,2HIN,2HFO,2HRM,2HAT,2HIO,2HN ,2HON, 3 2H D,2HAT,2HA ,2HSE,2HTS/ DATA IDSLN/25/ DATA ICAPC/9/,IFREE/16/,IUSED/24/,IDIF/32/ C C C GET THE SCHEDULING PARAMETERS AND THE LENGTH OF THE PARAMETER STRING C IN POSITIVE BYTES. C CALL GETST(IBUF,MAXLN,LOGLN) C C ASK PARST TO PARSE THE PARAMETERS STRING. IT CAN CONTAIN UP TO FOUR C PARAMETERS WHICH ARE: C 1) INPUT LU C 2) OUTPUT LU C 3) DATA BASE ROOT FILE NAMR C 4) USER'S LEVEL CODE WORD C PARST STORES THESE PARAMETERS RESPECTIVELY IS: C 1) INLU C 2) OUTLU C 3) IBASE C 4) LEVEL C IT WILL DEFAULT THE FIRST TWO IF UNSPECIFIED, AND PROMPT FOR THE LATTER C TWO IF UNSPECIFIED. IN ADDITION, PARST SETS UP THE VARIABLE LULOG TO C CONTAIN THE PROPER LU FOR ERROR MESSAGE LOGGING. IF IT ENCOUNTERS ANY C ERROR, PARST RETURNS A NON-ZERO VALUE IN ISTAT; >0 IF AN ILLEGAL LU C NUMBER SPECIFIED IN RUN STRING; <0 FOR ANY OTHER ERROR. C CALL PARST(ISTAT) IF (ISTAT(1).LT.0) GO TO 900 IF (ISTAT(1).GT.0) GO TO 1000 C C OPEN THE DATA BASE. TRY IT FIRST WITH MODE 1, IF THAT DOESN'T WORK, C TRY IT WITH MODE 8. IF NEITHER WORK, GIVE UP. C MODE=1 10 CALL DBOPN(IBASE,LEVEL,MODE,ISTAT) IF (ISTAT(1).EQ.0) GO TO 25 IF (MODE.EQ.8) GO TO 7000 IF (ISTAT(1).NE.152) GO TO 7000 MODE = 8 GO TO 10 C C GET THE NUMBER OF DATA SETS THE USER HAS ACCESS TO AND ALL THEIR CAPA- C CITIES THROUGH GETSZ. IT RETURNS THIS INFORMATION IN IBUF IN THE FOL- C LOWING FORMAT: C WORD +------------------------------+ C 1 | DOUBLE WORD NUMBER OF FREE | C 2 | RECORDS IN FIRST DATA SET | C -------------------------------- C 3 | FIRST DATA | C 4 | SET'S | C 5 | NAME | C -------------------------------- C 6 | DOUBLEWORD CAPACITY OF | C 7 | FIRST DATA SET | C -------------------------------- C . . C . . C . . C -------------------------------- C N*7-6 | DOUBLEWORD NUMBER OF FREE | C N*7-5 | RECORDS IN NTH DATA SET | C -------------------------------- C N*7-4 | NTH DATA | C N*7-3 | SET'S | C N*7-2 | NAME | C -------------------------------- C N*7-1 | DOUBLEWORD CAPACITY OF | C N*7 | NTH DATA SET | C +------------------------------+ C C WHERE N IS THE NUMBER OF DATA SETS THE USER HAS ACCESS TO. THERE IS C A MAXIMUM OF 50 DATA SETS. GETSZ RETURNS THE NUMBER OF DATA SETS C DESCRIBED IN IBUF IN NSETS. IF IT ENCOUNTERS ANY ERROR, GETSZ RETURNS C A NON-ZERO VALUE IN ISTAT. C 25 CALL GETSZ(ISTAT) IF (ISTAT(1).NE.0) GO TO 5000 IF (NSETS.LE.0) GO TO 5000 C C SET UP A LOOP, FOR EACH DATA SET ACCESSIBLE BY THE USER, TO DETERMINE C THE NUMBER OF USED RECORDS IN THE DATA SET. THIS NUMBER IS DETERMINED C BY DOING SERIAL READS ON THE DATA SET, COUNTING EACH RECORD RETURNED C AS A USED RECORD. C DO 100 I=1,NSETS URECS(I) = 0 50 CALL DBGET(IBASE,IBUF(I*7-4),2,ISTAT,0,IDUM,IDUM) IF (ISTAT(1).EQ.12) GO TO 100 IF (ISTAT(1).NE.0) GO TO 4000 URECS(I) = DAD(URECS(I),DBLEI(1)) GO TO 50 100 CONTINUE C C SET UP A LOOP, FOR EACH DATA SET ACCESSIBLE BY THE USER, TO DETERMINE C THE DIFFERENCE BETWEEN THE CAPACITY OF THE DATA SET AND THE SUM OF THE C NUMBER OF FREE RECORDS PLUS THE NUMBER OF USED RECORDS. IF ANY OF THE C DATA SET RECORDS DO NOT ADD UP, THEN SET A FLAG INDICATING POSSIBLE C CORRUPT DATA BASE. C IFLAG = 0 DO 200 I=1,NSETS DIFF(I) = DSB(IBUF(I*7-1),DAD(IBUF(I*7-6),URECS(I))) IF (DCO(DIFF(I),DBLEI(0))) 60,70,60 60 IFLAG = -1 70 CONTINUE 200 CONTINUE C C SET UP TO PRINT OUT THE ATTAINED INFORMATION. FIRST, FILL THE OUTPUT C BUFFER WITH BLANKS, THEN LOCK THE OUTPUT LU IF IT IS NOT A TTY-LIKE C DEVICE, AND FINALLY, PRINT OUT THE HEADER: C C DATA SET NAME CAPACITY FREE RECORDS RECORDS USED DIFFERENCE C ------------- -------- ------------ ------------ ---------- CALL SFILL(IOUTB,1,-IOUTL,IBLNK) IF (IFTTY(OUTLU)) GO TO 300 CALL LURQ(40001B,OUTLU,1) GO TO 3000 300 CALL EXEC(100002B,OUTLU,IHED1,IOUTL) GO TO 2000 310 CALL EXEC(100002B,OUTLU,IHED2,IOUTL) GO TO 2000 320 CALL EXEC(100002B,OUTLU,IBLNK,1) GO TO 2000 C C LOOP ON EACH DATA SET PRINTNG OUT: C 1) THE DATA SET'S NAME C 2) THE DATA SET'S CAPACITY C 3) THE NUMBER OF FREE RECORDS IN THE DATA SET C 4) THE NUMBER OF USED RECORDS IN THE DATA SET C 5) THE CALCULATED DIFFERENCE C AFTER EACH SET OF FIVE DATA SETS A BLANK LINE IS PRINTED FOR READABILITY. C 330 DO 500 I=1,NSETS C MOVE NAME INTO OUTPUT BUFFER CALL SMOVE(IBUF(I*7-4),1,6,NAME,1) C CONVERT CAPACITY INTO ASCII AND PUT INTO OUTPUT BUFFER. CALL CNVRT(IBUF(I*7-1),ICAPC) C CONVERT FREE RECORDS TO ASCII AND PUT INTO OUTPUT BUFFER. CALL CNVRT(IBUF(I*7-6),IFREE) C CONVERT USED RECORDS TO ASCII AND PUT INTO OUTPUT BUFFER. CALL CNVRT(URECS(I),IUSED) C CONVERT DIFFERENCE TO ASCII AND PUT INTO OUTPUT BUFFER. CALL CNVRT(DIFF(I),IDIF) C WRITE THIS DATA SET'S INFORMATION OUT. CALL EXEC(100002B,OUTLU,IOUTB,IOUTL) GO TO 2000 C AFTER FIFTH DATA SET, IN A ROW, WRITE A BLANK LINE. 400 IF (MOD(I,5).NE.0) GO TO 500 CALL EXEC(100002B,OUTLU,IBLNK,1) GO TO 2000 500 CONTINUE C C DONE WITH ALL DATA SET. IF IFLAG IS NON-ZERO, PRINT THE WARNING: C C DATA BASE MAY NOT BE GOOD - TRY PROGRAM 'RECOV' C IF (IFLAG.EQ.0) GO TO 700 CALL EXEC(100002B,OUTLU,IBLNK,1) GO TO 2000 550 CALL EXEC(100002B,OUTLU,IWARN,IWRNL) GO TO 2000 C C UNLOCK THE OUTPUT DEVICE, CLOSE THE DATA BASE, PRINT THE STOP MESSAGE: C C END DBSPA C C AND TERMINATE. C 700 CALL LURQ(100000B,OUTLU,1) 800 CALL DBCLS(IBASE,IDUM,1,ISTAT) 900 CALL EXEC(2,OUTLU,IBLNK,1) CALL EXEC(2,OUTLU,IEND,IENDL) 1000 STOP C C ERROR HANDLERS. C C OUTPUT ERROR. PRINT MESSAGE: C C /DBSPA - ERROR ON OUTPUT: AABB C WHERE AABB IS THE CONTENTS OF THE A & B REGISTERS FROM THE C EXEC WRITE CALL RESPECTIVELY. C 2000 CALL ABREG(IOERR(14),IOERR(15)) CALL EXEC(100002B,LULOG,IOERR,IOELN) GO TO 2050 2025 GO TO 700 C 2050 CALL EXEC(100002B,1,IOERR,IOELN) GO TO 700 2075 GO TO 700 C C LURQ ERROR. PRINT MESSAGE: C C /DBSPA - UNABLE TO LOCK OUTPUT LU C 3000 CALL EXEC(100002B,LULOG,LKERR,LKERL) GO TO 2000 3010 GO TO 800 C C DBGET ERROR. PRINT MESSAGE: C C /DBSPA - ERROR XXX ON DATA SET YYYYY C WHERE XXX IS THE ERROR CODE PASSED BACK BY DBGET IN ISTAT C AND YYYYY IS THE NAME OF THE DATA SET CURRENTLY BEING READ. C 4000 CALL CNUMD(ISTAT(1),IGTER(8)) DO 4050 J=1,3 IGTER(J+17) = IBUF(I*7-5+J) 4050 CONTINUE CALL EXEC(100002B,LULOG,IGTER,IGTLN) GO TO 2000 4060 GO TO 800 C C NO DATA SET ACCESSIBLE BY USER OR INFORMATION ON SETS UNOBTAINABLE. C PRINT MESSAGE: C C /DBSPA - UNABLE TO OBTAIN INFORMATION ON DATA SET C 5000 CALL EXEC(100002B,LULOG,IDSER,IDSLN) GO TO 2000 5010 GO TO 800 C C DBOPN ERROR. PRINT MESSAGE: C C /DBSPA - ERROR XXX ON DBOPN C WHERE XXX IS THE ERROR CODE PASSED BACK BY DBOPN IN ISTAT. C 7000 CALL CNUMD(ISTAT(1),IOPER(8)) CALL EXEC(100002B,LULOG,IOPER,IOPLN) GO TO 2000 7010 GO TO 900 END C C C SUBROUTINE CNVRT. THIS SUBROUTINE TAKES A DOUBLE WORD INTEGER VALUE C AND CONVERTS IT INTO A 10 CHARACTER ASCII STRING SUPPRESSING LEADING C ZEROES. THE ASCII VALUE IS PUT INTO THE OUTPUT BUFFER FOR DBSPA WITH C THE PROPER SIGN PRECEDING THE FIRST NON-ZERO CHARACTER. NEGATIVE C VALUES ARE PRECEDED BY A NEGATIVE SIGN, POSITIVE WITH A BLANK. C C THE CALLING SEQUENCE FOR CNVRT IS: C C CALL CNVRT(VALUE,INDEX) C C WHERE VALUE C IS THE DOUBLE WORD INTEGER VALUE TO CONVERT C INDEX C IS AN INTEGER INDEX INTO THE OUTPUT BUFFER FOR THE LOCATION AT C WHICH THE CONVERTED STRING IS TO BEGIN C SUBROUTINE CNVRT(VALUE,INDEX) C DIMENSION IOUTB(36),IBUF(350),IBASE(11),LEVEL(3) C INTEGER OUTLU C COMMON IBUF,NSETS,IBASE COMMON LOGLN,LEVEL,INLU,OUTLU,LULOG COMMON IOUTB C C DETERMINE PROPER SIGN FOR ASCII STRING. ALSO, IF THE VALUE IS NEGATIVE, C MAKE IT POSITIVE FOR DCITA. C ISIGN = 40B IF (DCO(VALUE,DBLEI(0))) 10,20,20 10 VALUE = DNG(VALUE) ISIGN = 55B C C ASK DCITA TO DO THE DOUBLE INTEGER TO ASCII CONVERSION AND SET THE C RETURNED VALUE INTO THE PROPER POSITION IN THE OUTPUT BUFFER. THIS C VALUE MAY CONTAIN LEADING ZEROES. C 20 CALL DCITA(VALUE,IOUTB(INDEX)) C C REPLACE ALL LEADING ZEROES WITH BLANKS. C DO 50 I=1,9 CALL SGET(IOUTB(INDEX),I,ICHAR) IF (ICHAR.NE.60B) GO TO 60 CALL SPUT(IOUTB(INDEX),I,40B) 50 CONTINUE I = 9 C C INSERT PROPER SIGN INTO OUTPUT BUFFER. C 60 CALL SPUT(IOUTB(INDEX-1),I+1,ISIGN) RETURN END C C C SUBROUTINE GETSZ. GETSZ BUILDS AN INFORMATION BUFFER FOR DBSPA CON- C SISTING OF THE NAMES OF ALL THE DATA SETS ACCESSIBLE BY THE USER, THEIR C CAPACITIES, AND THE COUNTS OF THEIR FREE RECORDS. THE BUFFER THIS C INFORMATION IS PUT INTO IS IBUF AND THE NUMBER OF DATA SETS DESCRIBED C IN IBUF IS PUT INTO NSETS. THE INFORMATION IN IBUF IS FORMATTED AS C FOLLOWS: C WORD +------------------------------+ C 1 | DOUBLE WORD NUMBER OF FREE | C 2 | RECORDS IN FIRST DATA SET | C -------------------------------- C 3 | FIRST DATA | C 4 | SET'S | C 5 | NAME | C -------------------------------- C 6 | DOUBLEWORD CAPACITY OF | C 7 | FIRST DATA SET | C -------------------------------- C . . C . . C . . C -------------------------------- C N*7-6 | DOUBLEWORD NUMBER OF FREE | C N*7-5 | RECORDS IN NTH DATA SET | C -------------------------------- C N*7-4 | NTH DATA | C N*7-3 | SET'S | C N*7-2 | NAME | C -------------------------------- C N*7-1 | DOUBLEWORD CAPACITY OF | C N*7 | NTH DATA SET | C +------------------------------+ C C WHERE N IS THE NUMBER OF DATA SETS THE USER HAS ACCESS TO. THERE IS C A MAXIMUM OF 50 DATA SETS. C C THE CALLING SEQUENCE FOR GETSZ IS: C C CALL GETSZ(ISTAT) C C WHERE ISTAT C IS AN INTEGER VARIABLE IN WHICH A STATUS CODE IS RETURNED C = 0 IF BUFFER SUCCESSFULLY BUILT C <> 0 IF ANY ERROR IS ENCOUNTERED. C SUBROUTINE GETSZ(ISTAT) C DIMENSION IBUF(350),ISTAT(10),IBASE(11),INFO(17) C COMMON IBUF,NSETS,IBASE C EQUIVALENCE (USED,INFO(14)),(CAPAC,INFO(16)) C NSETS = 0 C C GET THE COUNT OF ALL THE DATA SETS THE USER HAS ACCESS TO AND THEIR C RESPECTIVE DATA SET NUMBERS. C CALL DBINF(IBASE,0,203,ISTAT,IBUF(300)) IF (ISTAT(1).NE.0) GO TO 200 IF (IBUF(300).LE.0) GO TO 200 C C FOR EACH DATA SET IN THE LIST, GET ITS NAME, CAPACITY AND NUMBER OF C USED RECORDS. THEN, BUILD THE NEXT ENTRY IN IBUF DETERMINING THE C NUMBER OF FREE RECORDS BY SUBTRACTING THE NUMBER OF USED RECORDS FROM C THE CAPACITY. C NSETS = IBUF(300) ICNT = 0 DO 100 I=1,NSETS ISNO = IABS(IBUF(300+I)) CALL DBINF(IBASE,ISNO,202,ISTAT,INFO) IF (ISTAT(1).NE.0) GO TO 200 FREE = DSB(CAPAC,USED) CALL SMOVE(FREE,1,4,IBUF(ICNT*7+1),1) CALL SMOVE(INFO,1,6,IBUF(ICNT*7+3),1) CALL SMOVE(CAPAC,1,4,IBUF(ICNT*7+6),1) ICNT = ICNT + 1 100 CONTINUE NSETS = ICNT 200 RETURN END C C C SUBROUTINE PARST. PARST TAKES THE RUN STRING GIVEN DBSPA AND PARSES C IT INTO ITS CONPONENTS. PARST ALSO RESOLVES ANY UNSPECIFIED PARAMETERS C AND DETERMINES THE LU TO USE IN LOGGING ERROR MESSAGES. THE RUN STRING C CAN CONTAIN UP TO FOUR PARAMETERS WHICH ARE AS FOLLOWS: C 1) INPUT LU C 2) OUTPUT LU C 3) DATA BASE ROOT FILE NAMR C 4) USER'S LEVEL CODE WORD C PARST STORES THESE PARAMETERS RESPECTIVELY IS: C 1) INLU C 2) OUTLU C 3) IBASE C 4) LEVEL C IT WILL DEFAULT THE FIRST TWO IF UNSPECIFIED, AND PROMPT FOR THE LATTER C TWO IF UNSPECIFIED. IN ADDITION, PARST SETS UP THE VARIABLE LULOG TO C CONTAIN THE PROPER LU FOR ERROR MESSAGE LOGGING. C C THE CALLING SEQUENCE FOR PARST IS: C C CALL PARST(ISTAT) C C WHERE ISTAT C IS A VARIABLE IN WHICH A STATUS CODE IS RETURNED C = 0 IF PARSE WAS SUCCESSFUL C > 0 IF AN ILLEGAL LU SPECIFIED IN RUN STRING C < 0 IF ANY OTHER ERROR WAS ENCOUNTERED C SUBROUTINE PARST(ISTAT) C DIMENSION IPBUF(10),IBUF(350),IBASE(11),LEVEL(3),IHEDR(18) DIMENSION INERR(15),INMRE(21),IOERR(15),IRFPT(13),ILCWP(13) DIMENSION ILLUE(10) C INTEGER OUTLU LOGICAL IFTTY C COMMON IBUF,NSETS,IBASE COMMON LOGLN,LEVEL,INLU,OUTLU,LULOG C DATA IBLNK/2H / DATA IHEDR/2H I,2HMA,2HGE,2H/1,2H00,2H0 ,2HDA,2HTA,2H B,2HAS, 2 2HE ,2HSP,2HAC,2HE ,2HUT,2HIL,2HIT,2HY / DATA IHEDL/18/ DATA IRFPT/2H/D,2HBS,2HPA,2H: ,2HRO,2HOT,2H F,2HIL,2HE ,2HNA, 2 2HMR,2H? ,2H _/ DATA ILCWP/2H/D,2HBS,2HPA,2H: ,2HLE,2HVE,2HL ,2HCO,2HDE,2H W, 2 2HOR,2HD?,2H _/ DATA IPRML/13/ DATA INMRE/2H/D,2HBS,2HPA,2H -,2H I,2HLL,2HEG,2HAL,2H O,2HR , 2 2HMI,2HSS,2HIN,2HG ,2HRO,2HOT,2H F,2HIL,2HE ,2HNA, 3 2HMR/ DATA INMRL/21/ DATA INERR/2H/D,2HBS,2HPA,2H -,2H E,2HRR,2HOR,2H O,2HN ,2HIN, 2 2HPU,2HT:,2H ,2H ,2H / DATA IOERR/2H/D,2HBS,2HPA,2H -,2H E,2HRR,2HOR,2H O,2HN ,2HOU, 2 2HTP,2HUT,2H: ,2H ,2H / DATA IOELN/15/ DATA ILLUE/2H/D,2HBS,2HPA,2H -,2H I,2HLL,2HEG,2HAL,2H L,2HU./ DATA ILLUL/10/ C C C SET ERROR LOGGING LU TO 1. C LULOG = 1 C C DETERMINE THE INPUT LU FROM THE SCHEDULING STRING. IF UNSPECIFIED, C CALL LOGLU TO GET IT. IF SPECIFIED, MAKE SURE IT'S LEGAL. C ISTRT = 1 IF (NAMR(IPBUF,IBUF,LOGLN,ISTRT)) 20,10 10 IF ((IAND(IPBUF(4),003B).EQ.1).AND.(IPBUF(1).GE.0) & .AND.(IPBUF(1).LE.255B)) GO TO 30 IF (IPBUF(4).NE.0) GO TO 500 20 IPBUF(1) = LOGLU(IDUM) 30 INLU = IPBUF(1) C C DETERMINE OUTPUT LU FROM SCHEDULING STRING. IF UNSPECIFIED, THEN IF C THE INPUT LU IS INTERACTIVE, THEN DEFAULT THE OUTPUT LU TO THE INPUT C LU, ELSE DEFAULT THE OUTPUT LU TO 6. IF SPECIFIED, MAKE SURE ITS LEGAL. C IF (NAMR(IPBUF,IBUF,LOGLN,ISTRT)) 60,50 50 IF ((IAND(IPBUF(4),003B).EQ.1).AND.(IPBUF(1).GE.0) & .AND.(IPBUF(1).LE.255B)) GO TO 70 IF (IPBUF(4).NE.0) GO TO 500 60 IPBUF(1) = 6 IF (IFTTY(INLU)) IPBUF(1) = INLU 70 OUTLU = IPBUF(1) C C DETERMINE THE ERROR LOGGING LU. IF INPUT LU IS INTERACTIVE, THEN THE C LOGGING LU BECOMES THE INPUT LU, ELSE IT REMAINS LU 1. C IF (IFTTY(INLU)) LULOG = INLU C C PRINT OUT THE HEADER: C C IMAGE/1000 DATA BASE SPACE UTILITY C CALL EXEC(100002B,OUTLU,IBLNK,1) GO TO 3000 80 CALL EXEC(100002B,OUTLU,IHEDR,IHEDL) GO TO 3000 85 CALL EXEC(100002B,OUTLU,IBLNK,1) GO TO 3000 C C GET THE DATA BASE ROOT FILE'S NAMR. IF NOT SPECIFIED IN THE RUN STRING, C THEN IF THE INPUT LU IS INTERACTIVE, PROMPT FOR THE NAMR AND READ THE C REPLY, ELSE JUST DO THE READ. C 90 IBASE(1) = IBLNK IF (NAMR(IPBUF,IBUF,LOGLN,ISTRT)) 110,100 100 IF (IAND(IPBUF(4),3).EQ.0) GO TO 110 NCHARS = 0 IF (INAMR(IPBUF,IBASE(2),20,NCHRS)) 1000,150 C 110 IF (IFTTY(INLU)) 120,130 120 CALL EXEC(100002B,INLU,IRFPT,IPRML) GO TO 2000 130 NCHRS = -20 CALL EXEC(100001B,INLU+400B,IBASE(2),NCHRS) GO TO 2000 135 CALL ABREG(IA,IB) IF (IB.NE.0) GO TO 140 IF (IFTTY(INLU)) 120,1000 140 NCHRS = IB 150 CALL SPUT(IBASE(2),NCHRS+1,IBLNK) C C GET THE USER'S LEVEL CODE WORD. IF NOT SPECIFIED IN THE RUN STRING, C THEN IF THE INPUT LU IS INTERACTIVE, PROMPT FOR THE WORD AND READ THE C REPLY, ELSE JUST DO THE READ. C IF (NAMR(IPBUF,IBUF,LOGLN,ISTRT)) 210,200 200 IF (IPBUF(4).EQ.0) GO TO 210 CALL SMOVE(IPBUF,1,6,LEVEL,1) GO TO 300 210 IF (IFTTY(INLU)) 220,230 220 CALL EXEC(100002B,INLU,ILCWP,IPRML) GO TO 2000 230 CALL SFILL(LEVEL,1,6,IBLNK) CALL EXEC(100001B,INLU,LEVEL,3) GO TO 2000 C C SET STATUS WORD TO ZERO UPON SUCCESSFUL COMPLETION AND RETURN. C 300 ISTAT = 0 RETURN C C ERROR HANDLERS. C C ILLEGAL LU IN RUN STRING. PRINT MESSAGE: C C /DBSPA - ILLEGAL LU. C 500 CALL EXEC(100002B,LULOG,ILLUE,ILLUL) GO TO 6000 750 GO TO 6000 C C UNABLE TO OBTAIN ROOT FILE NAMR OR NAMR SPECIFIED IS ILLEGAL. PRINT C MESSAGE: C C /DBSPA - ILLEGAL OR MISSING ROOT FILE NAMR C 1000 CALL EXEC(100002B,LULOG,INMRE,INMRL) GO TO 5000 1500 GO TO 5000 C C ERROR ON I/O CALL TO INPUT DEVICE. PRINT MESSAGE: C C /DBSPA - ERROR ON INPUT AABB C WHERE AABB IS THE CONTENTS OF THE A & B REGISTERS FROM THE C EXEC I/O CALL RESPECTIVELY. C 2000 CALL ABREG(INERR(14),INERR(15)) CALL EXEC(100002B,LULOG,INERR,IOELN) GO TO 5000 2500 GO TO 5000 C C ERROR ON I/O CALL TO OUTPUT DEVICE. PRINT MESSAGE: C C /DBSPA - ERROR ON OUTPUT AABB C WHERE AABB IS AS ABOVE. C 3000 CALL ABREG(IOERR(14),IOERR(15)) CALL EXEC(100002B,LULOG,IOERR,IOELN) GO TO 5000 3500 GO TO 5000 C C SET STATUS WORD TO -1 ON ERROR AND RETURN. C 5000 ISTAT = -1 RETURN 6000 ISTAT = 1 RETURN END END$