FTN4,Q,C
      PROGRAM DTSXX(3,99),92425-16045 REV.2001 791030 
C 
C-------------------------------------------------------- 
C 
C     RELOC.       92425-1X045
C     SOURCE       92425-18045
C 
C     (C) COPYRIGHT HEWLETT-PACKARD COMPANY,1979. 
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$
                                                                                                                                                                                                                                                