FTN4,L C PROGRAM DTSXX(3,99),PRE-REL 780522 (DLB) RTE-IV PROGRAM DTSXX(3,99),PRE-REL 780615 (DLB) RTE-IV C C-------------------------------------------------------- C C RELOC. 09570-16652 C SOURCE 09570-18652 C C W A GROVES 13 OCT 76 REV. A C W A GROVES 23 FEB 77 PRE-REL C C (C) COPYRIGHT HEWLETT-PACKARD COMPANY,1976. C ALL RIGHTS RESERVED.THE INFORMATION CONTAINED ON C THIS MEDIUM MAY BE USED WITH ONLY ONE COMPUTER C AT A TIME.IT SHALL NOT OTHERWISE BE RECORDED, C TRANSMITTED,OR STORED IN A RETRIEVAL SYSTEM. C COPYING OR OTHER REPRODUCTION WITHOUT PRIOR WRITTEN C CONSENT OF HEWLETT-PACKARD COMPANY IS PROHIBITED, C EXCEPT THAT ONE COPY MAY BE MADE AND RETAINED FOR ARCHIVE C PURPOSES ONLY. C C --------------- C C THE INFORMATION CONTAINED ON THIS MEDIUM IS PROPRIETARY C TO HEWLETT-PACKARD COMPANY. IT MAY BE USED WITH ONE C COMPUTER ONLY AND IS NOT TO BE DISCLOSED TO ANY THIRD C PARTIES OR REPRODUCED IN ANY FORM EXCEPT THAT IT MAY BE C TRANSFERRED TO ONE BACKUP COMPUTER DURING A COMPUTER C MALFUNCTION OR DURING PREVENTIVE MAINTENANCE. C C-------------------------------------------------------- DIMENSION IOPBF(40),IDCB(528),NMDIR(3),IRBUF(40) DIMENSION IPBUF(10),IRSTR(40),IDCBT(144) DIMENSION IP(5),ILOGOF(3),IPRTN(5),IFMSEQ(10) DATA NMDIR/2H/D,2HIR,2H /,IRSTR/2H::/ DATA IDCRN/-2/,ILOGOF/2HLO,2HGO,2HF / DATA IFMSEQ/2HFM,2HSE,2HQ ,23B,0,-2/ C C DEFINE STATEMENT FUNCTIONS TO DO "GET BYTE" IN FORTRAN C IBYT1(IOF)=IAND(IOPBF(IOF/2+1)/(256-(IAND(IOF,1)*255)),177B) IBYT2(IOF)=IAND(IRBUF(IOF/2+1)/(256-(IAND(IOF,1)*255)),177B) C C DEFINE THE ROUTINE TO GET THE FATHER WAITING BIT C IWAIT(IDMY) = IAND(40000B,KGET(KGET(1717B)+20)) C C GET LOG DEVICE C DUMMY=ABREG(I,J) LOG=ITMLU(I) DUMMY=DUMMY CALL RMPAR(IP) C C PRODUCE THE FMSXX TO EXECUTE THE :TR, COMMAND TO FOLLOW C CALL PUTID(IDCBT,IERR,IFMSEQ,LOG,IRPD) IF (IERR.EQ.0) GO TO 50 WRITE (LOG,11000) IERR,(IFMSEQ(I),I=1,3) 11000 FORMAT (/"/FMGR: ERROR#"I6, +/"/DTSXX COULD NOT PRODUCE "3A2" IDSEGMENT") GO TO 115 C C CLOSE DIRECTORY AFTER EACH RETRY. C 50 CALL CLOSE(IDCB) 100 DO 110 I=1,40 110 IOPBF(I)=2H IXFR=0 IF(IP(3) .EQ. 0) WRITE (LOG,10000) IF (IP(3) .NE. 0) WRITE (LOG,10050) 10000 FORMAT (/"ENTER UUT NAME: _") 10050 FORMAT (/"ENTER SELECTION: _") 111 READ (LOG,10100) IOPBF 10100 FORMAT (40A2) C C DID TERMINAL TIME-OUT? C CALL EXEC(13,LOG,IEQT5,IEQT4) IF(IAND(IEQT4,4000B) .NE. 0) GO TO 111 C C PARSE TO ELIMINATE LEADING SPACES C ISTR=1 IEND=80 CALL NAMR(IPBUF,IOPBF,IEND,ISTR) C C IS FIRST WORD "EX" (EXIT)? C IF (IPBUF .NE. 2HEX) GO TO 120 C C SCHEDULE LOGOFF PROGRAM C IF SCHEDULE ABORTED TERMINATE SELF C IF SON OF ANYBODY, THEN PASS BACK LOGOF FLAG IN 1P C IF (IWAIT(IDMY).NE.0) GO TO 115 C C FATHER IS NOT WAITING, SO DO THE LOGOF THING C CALL EXEC(23+100000B,ILOGOF) GO TO 115 114 I=I 115 IPRTN = -32767 GO TO 9999 C C IF TEST OPERATOR, ONLY TESTING IS PERMITTED. C 120 IF (IP(3) .EQ. 0) GO TO 180 C C VALID XFER FILE? C CALL LOPEN(IDCBT,IERR,IPBUF,1,IPBUF(5),IPBUF(6)) IF (IERR .LT. 0) GO TO 180 CALL CLOSE(IDCBT) C C TYPE 3 OR 4? C IF(IERR .NE. 3 .AND. IERR .NE. 4) GO TO 180 IXFR=1 INSTR=0 C C INVERSE PARSE XFER NAMR. C CALL INAMR(IPBUF,IRSTR(2),78,INSTR) C C IF NAME BEGINS WITH "?" OR "#" SCHEDULE DIRECTLY. C IF (IPBUF/256 .EQ. 77B) GO TO 400 IF (IPBUF/256 .EQ. 43B) GO TO 400 DO 170 I=1,40 170 IOPBF(I)=2H WRITE (LOG,10000) C C GET UUT NAME. C 175 READ(LOG,10100)IOPBF C C DID TERMINAL TIME-OUT? C CALL EXEC(13,LOG,IEQT5,IEQT4) IF (IAND(IEQT4,4000B) .NE. 0) GO TO 175 C C PARSE TO ELIMINATE LEADING SPACES C ISTR=1 IEND=80 CALL NAMR(IPBUF,IOPBF,IEND,ISTR) IF (IPBUF .EQ. 2HEX) GO TO 100 C C OPEN DIRECTORY WITH CARTRIDGE SEARCH FIRST TIME THROUGH C THEREAFTER, USE DEFAULT "CRN" OF FIRST OPEN. C 180 CALL LOPEN(IDCB,IERR,NMDIR,1,0,IDCRN,528) IF (IERR .GE. 0) GO TO 190 WRITE (LOG,10200)IERR 10200 FORMAT (/"/FMGR: ERR#"I6/"DTSXX: COULD NOT OPEN /DIR NAMR") GO TO 100 190 IF (IERR .EQ. 3 .OR. IERR .EQ. 4) GO TO 205 WRITE (LOG,10300) 10300 FORMAT (/"/DTSXX: /DIR MUST BE TYPE 3 OR 4") GO TO 50 C C GET DEFAULT DISC LU FOR UNQUALIFIED NAMR'S C C C START READIND DIRECTORY C 205 CALL READF(IDCB,IERR,IRBUF,40,LEN) IF (LEN .NE. -1) GO TO 208 C C EOF MEANS COULDN'T FIND ENTRY C DO 206 I=79,0,-1 IF (IBYT1(I) .NE. 40B) GO TO 207 206 CONTINUE I=0 207 IF (I .EQ. 79) I=78 I=I+1 J=I/2+1 IF(MOD(I,2) .EQ. 0) IOPBF(J)=IAND(IOPBF(J),377B)+37400B IF(MOD(I,2) .EQ. 1) IOPBF(J)=IAND(IOPBF(J),77400B)+77B C C PUT OUT ENTRY FOLLOWED BY "?" C WRITE (LOG,10100) (IOPBF(K),K=1,J) GO TO 50 208 IF (IERR .GE. 0) GO TO 210 209 WRITE (LOG,10400)IERR 10400 FORMAT (/"/FMGR: ERR#"I6/"/DTSXX: COULD NOT READ /DIR NAMR") GO TO 50 210 IF (LEN .EQ. 0) GO TO 205 C C IGNORE RECORDS STARTING WITH "*" C IF(IBYT2(0) .EQ. 52B) GO TO 205 C C BLANK TRAILING BYTES C THEN TRY TO MATCH RECORDS C DO 215 I=LEN+1,40 215 IRBUF(I)=2H DO 220 I=1,40 IF (IOPBF(I) .NE. IRBUF(I)) GO TO 205 220 CONTINUE C C RECORDS MATCH, GET RUN STRING FOLLOWING UUT NAME C 225 CALL READF(IDCB,IERR,IRBUF,40,LEN) IF(LEN .EQ. -1) GO TO 250 IF(IERR .LT. 0) GO TO 209 IF(IBYT2(0) .EQ. 52B) GO TO 225 C C PARSE STRING FOR TEST SEQUENCE NAMR C ISTR=1 IEND=LEN*2 IF (NAMR(IPBUF,IRBUF,IEND,ISTR)) 250,260 250 WRITE (LOG,10500) 10500 FORMAT (/"/DTSXX: IMPROPER TEST SEQUENCE NAMR IN /DIR") GO TO 50 260 IF(IAND(IPBUF(4),3) .NE. 3) GO TO 250 CALL CLOSE(IDCB) C C IF PROCESSING XFER FILE, SKIP TEST SEQUENCE NAMR. C IF (IXFR .NE. 0) GO TO 300 C C IF NAMR IS UNQUALIFIED, DEFAULT TO /DIR LU C IF (IAND(IPBUF(4),60B)/16 .NE. 0) GO TO 270 IPBUF(4)=IPBUF(4)+40B IPBUF(6)=IDCRN 270 CALL LOPEN(IDCBT,IERR,IPBUF,1,IPBUF(5),IPBUF(6)) IF (IERR .GE. 0) GO TO 280 WRITE (LOG,10600)IERR 10600 FORMAT (/"/FMGR: ERR#"I6/"/DTSXX: COULD NOT OPEN" +" TEST SEQUENCE NAMR") GO TO 100 280 CALL CLOSE (IDCBT) IF (IERR .EQ. 3 .OR. IERR .EQ. 4) GO TO 290 WRITE (LOG,10700) 10700 FORMAT (/"/DTSXX: TEST SEQUENCE NAMR MUST BR TYPE 3 OR 4") GO TO 100 290 INSTR=0 C C INVERSE PARSE TSEQ NAMR INTO C RUN STRING FOR FMSEQ (::TSEQ::-2,PARM1,PARM2 ETC...) C IF (INAMR(IPBUF,IRSTR(2),78,INSTR)) 295,300 295 WRITE (LOG,10750) 10750 FORMAT (/"/DTSXX: RUN STRING TOO LONG IN /DIR") GO TO 100 C C PASS NEXT 10 PARAMETERS INTO RUN-STRING. C 300 DO 360 I=1,10 IF(NAMR(IPBUF,IRBUF,IEND,ISTR))400,350 350 IF(INAMR(IPBUF,IRSTR(2),78,INSTR)) 295,360 360 CONTINUE 400 INSTR=INSTR+1 C C DOES DTSXX HAVE A FATHER? C IF (IWAIT(IDMY).EQ.0) GO TO 500 C C YES, PASS BACK RUN STRING TO FATHER. C CALL EXEC(14,2,IRSTR,-INSTR) IPRTN = 0 GO TO 9999 C C SCHEDULE FMSXX C 500 CALL EXEC(23+100000B,IFMSEQ,LOG,LOG,LOG,4,0,IRSTR,-INSTR) GO TO 8900 C C RELEASE FMSXX'S ID SEGMENT C (UNLESS NOT SET UP BY ME) C 510 IF (IRPD .EQ. 0) CALL IDRPD(IOPBF,IERR) GO TO 100 8900 WRITE (LOG,11200)(IOPBF(I),I=1,3) 11200 FORMAT (/"/DTSXX: ERROR SCHEDULING "3A2) CALL IDRPD(IOPBF,IERR) GO TO 100 9999 CALL PRTN(IPRTN) END END$