C C N=1 INDICATES LSAVE OR USAVE C N=0 RESTOR C ISTR-- ARRAY CONTAINING THE RUN STRING C IDLU- DISC LU C MTLU- MAG TAPE LU C IVRFY- 1 FOR VERIFY OR DE OPTION C 0 NO VERFIFY OR ASK OK IN RESTOR C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C DO 2 I=1,75 2 ISTR(I)=2H C C C FIRST CHECK DATE CODE OF SYSTEM SOFTWARE IF > THAN 2001 LOG=1 C CALL DATCO(IDATE) IF(IDATE.LT.2001) GO TO 960 C C IPTR=1 CALL EXEC(14,1,ISTR,-80) CALL ABREG(IA,IB) LEN=IB IF(NAMR(IPBUF,ISTR,LEN,IPTR)) 500,10 10 IF(NAMR(IPBUF,ISTR,LEN,IPTR))500,15 15 ISTR(1)=2H ISTR(2)=IAND(ISTR(2),377B)+20000B IF(NAMR(IPBUF,ISTR,LEN,IPTR)) 500,20 20 LOG=0 IF(IAND(IPBUF(4),3).EQ.1) LOG=IPBUF(1) IF(IAND(IPBUF(4),3).EQ.0) LOG=LOGLU(ISESS) IF(LOG.LE.0) GO TO 930 C C SEE IF LOG LU IS IN SESSION AND SEE C IF IT IS DISK LU, IF DISK LU, ILLEGAL C CALL EXEC(13+100000B,LOG,IEQT5) GO TO 930 11 IF(IAND(IEQT5,37400B).EQ.15000B) GO TO 930 C C C PARSE DISK LU C IF(NAMR(IPBUF,ISTR,LEN,IPTR)) 500,30 30 IF(IAND(IPBUF(4),3).NEQ.1) GO TO 700 35 IDLU=IPBUF(1) IF(IDLU.LE.0) GO TO 910 C C C PARSE MTLU C IF(NAMR(IPBUF,ISTR,LEN,IPTR)) 65,40 40 MTLU=0 IF(IAND(IPBUF(4),3).GT.1) GO TO 800 IF(IAND(IPBUF(4),3).EQ.1) MTLU=IPBUF(1) IF (MTLU.LT.0) GO TO 920 IF(IAND(IPBUF(4),3).EQ.0) MTLU=8 IF(MTLU.EQ.0) GO TO 65 IF(NAMR(IPBUF,ISTR,LEN,IPTR)) 75,50 C C 50 IVRFY=0 IF(IAND(IPBUF(4),3).EQ.0) GO TO 80 IF(IPBUF(1).EQ.2HVE) IVRFY=1 IF(IPBUF(1).EQ.2HDE) IVRFY=1 IF(IVRFY.EQ.1.OR.N.EQ.0) GO TO 80 CALL EXEC(2,LOG, X47H ILLEGAL VERIFY PARAMETER- DEFAULT TO NO VERIFY,-47) GO TO 80 C C 65 MTLU=8 C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C CHECK TO SEE IF MT IS ON-LINE ,IF NOT PRINT MESSAGE AND STOPS C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C 75 IVRFY=0 80 IF(MTLU.GE.64) GO TO 800 CALL EXEC(13+100000B,MTLU,IEQT5,ISTAT1,ISTAT2) GO TO 800 81 IF(IAND(IEQT5,37000B)-11000B) 800,88,800 88 IF(IAND(IEQT5,040000B).EQ.40000B) GO TO 890 IF(IAND(ISTAT2,100000B).EQ.100000B) GO TO 890 C C NOW SEE IF MT LU IS LOCKED, IF YES PRINT MESSAGE, IF NOT C SEE IF LOCK IS SUCCESSFUL. C CALL LURQ(140001B,MTLU,1) GO TO 99 89 CALL ABREG(IA,IB) IF(IA.NEQ.0) GO TO 99 C C SEE IF MT ON-LINE C C CALL EXEC(3,600B+MTLU) CALL ABREG(IA,IB) IF(IAND(IA,1).NEQ.1) GO TO 200 CALL EXEC(2,LOG+200B,17HMAG TAPE OFF-LINE,-17) STOP 66 C C MT LU IS LOCKED C 99 CALL EXEC(2,LOG+200B,12HMT LU LOCKED,-12) STOP 66 C C CHECK DISK LU VALIDITY C 200 IF(IDLU.GE.64) GO TO 250 CALL EXEC(13+100000B,IDLU,IEQT5) GO TO 250 220 IDTYPE=IAND(IEQT5,37400B)/256 IF(IDTYPE.GT.31B.AND.IDTYPE.LT.34B) RETURN 250 CALL EXEC(2,LOG+200B,15HILLEGAL DISK LU,-15) STOP 66 C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C GET PARAMETER INTERACTIVELY C C FIRST CHECK IF LOG LU IS SUPPLIED, IF YES INVALID 500 LOG=LOGLU(ISESS) CALL EXEC(2,LOG+200B,17HLOGLU DEFAULT TO_,-17) CALL CNUMD(LOG,IPBUF) CALL EXEC(2,LOG+200B,IPBUF,-6) C C ASK DISK LU C 510 CALL EXEC(2,LOG,8HDISK LU?,-8) CALL REIO(1,LOG+400B,ISTR,-6) CALL ABREG(IA,IB) LEN= IB IPTR=1 C C IF(ISTR(1).EQ.2HEX.OR.ISTR(1).EQ.2HEN.OR.ISTR(1).EQ.2H/E) STOP IF(NAMR(IPBUF,ISTR,LEN,IPTR)) 510,520 C C 520 IF(IPBUF(4).NEQ.1) GO TO 524 IDLU=IPBUF(1) IF(IDLU.LE.0) GO TO 524 C C CHECK IF DISK LU IS VALID C IF(IDLU.GE.64) GO TO 524 CALL EXEC(13+100000B,IDLU,IEQT5) GO TO 524 523 IDTYPE=IAND(IEQT5,37400B)/256 IF(IDTYPE.GT.31B.AND.IDTYPE.LT.34B) GO TO 522 524 CALL EXEC(2,LOG+200B,15HILLEGAL DISK LU,-15) GO TO 510 C C 522 CALL EXEC(2,LOG,18HMT LU? (DEFAULT=8),-18) CALL REIO(1,LOG+400B,ISTR,-6) CALL ABREG(IA,IB) LEN= IB C IF(ISTR(1).EQ.2HEX.OR.ISTR(1).EQ.2HEN.OR.ISTR(1).EQ.2H/E)STOP C ASK MTLU IPTR=1 IF(NAMR(IPBUF,ISTR,LEN,IPTR)) 530,530 C 530 MTLU=8 IF(IAND(IPBUF(4),3).GT.1) GO TO 532 IF(IAND(IPBUF(4),3).EQ.1) MTLU=IPBUF(1) C C C CHECK IF MTLU IS VALID C IF(MTLU.GE.64) GO TO 532 CALL EXEC(13+100000B,MTLU,IEQT5) GO TO 532 531 IDTYPE=IAND(IEQT5,37400B)/256 IF(IDTYPE.GT.22B.AND.IDTYPE.LE.24B) GO TO 533 532 CALL EXEC(2,LOG+200B,13HILLEGAL MT LU,-13) GO TO 522 C C 533 IVRFY=0 IF(N.EQ.0) GO TO 550 534 CALL EXEC(2,LOG,7HVERIFY?,-7) CALL EXEC(1,LOG+400B,ISTR,-2) IF(ISTR(1).EQ.2HVE.OR.ISTR(1).EQ.2HDE.OR.ISTR(1).EQ.2HYE) IVRFY=1 IF(ISTR(1).EQ.2HEN.OR.ISTR(1).EQ.2HEX.OR.ISTR(1).EQ.2H/E) STOP IF(ISTR(1).EQ.2HNO) GO TO 550 IF(IVRFY.EQ.0) GO TO 534 C C 550 DO 600 I=1,50 600 ISTR(I)=2H C C IF SAVE ASK FOR LABEL C THEN CHECK IF MT IS ON LINE C C IF(N.EQ.0) GO TO 80 CALL EXEC(2,LOG,16HFILE ID (LABEL)?,-16) CALL REIO(1,LOG+400B,ISTR(2),-40) GO TO 80 700 CALL EXEC(2,LOG,39H ILLEGAL DISK LU: NON NUMERIC CHARACTER,-39) STOP 66 800 CALL EXEC(2,LOG,14H ILLEGAL MT LU,-14) STOP 66 890 CALL EXEC(2,LOG+200B,13HMAG TAPE DOWN,-13) STOP 66 900 STOP 1 910 CALL EXEC(2,LOG,31H DISK LU MUST BE GREATER THAN 0,-31) STOP 66 920 CALL EXEC(2,LOG,31H MT LU MUST BE GREATER THAN 0 ,-31) STOP 66 930 LOG=LOGLU(ISESS) CALL EXEC(2,LOG,15H ILLEGAL LOG LU,-15) STOP 66 960 CALL EXEC(2,LOG,25H OUTDATED SYSTEM SOFTWARE, -25) STOP 66 END END$ ��

FTN4,L SUBROUTINE XGTPM(ISTR,N,LOG,IDLU,MTLU,IVRFY),92067-1X548 REV.2001 X 791101 C***************************************************************** C* * C* (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * C* RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * C* REPRODUCED OR TRANSLATED TO ANOTHER PROGRAMMING LANGUAGE * C* WITHOUT THE PRIOR WRITTEN CONSENT OF THE HEWLETT-PACKARD * C* COMPANY. * C* * C***************************************************************** C C NAME: XGTPM C SOURCE: 92067-18548 C RELOC: PART OF 92067-12003 C PGMR: J.S.W C DIMENSION ISTR(1),IPBUF(10) C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C GET PARAMETER ROUTINE C C RU,,,,,