FTN4,L
      SUBROUTINE DGLB1,91711-18108 REV.2001 791120
C 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 
C 
C     SOURCE NAME &DGLB1
C     THIS IS A DUMMY PROGRAM TO PROVIDE THIS SOURCE WITH A NAME
C     THE RELOCATABLE FROM THIS SOURCE IS MERGED INTO 
C     THE LIBRARY %DGLB PART NO. 91711-12002
C     THIS ADDITION MADE 791120   
C 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC/ 
C 
      RETURN
      END 
C 
      SUBROUTINE DID01 (ILU,IADR,IPAS,IBF),91711-1X108 REV.2001 790922
C 
C RUN THE SELF TEST AND STORE RESULT IN IPAS. 
C 
      DIMENSION IBF(20) 
      IT=440B+IADR
      CALL ODPAR(IT)
      IBF(1)=IT 
      IBF(2)=577B 
      IBF(3)=0
      IBF(4)=1004B
      IBF(5)=100677B
C 
C SELF TEST 
C 
      CALL EXEC(1,ILU+2200B,IBF,9,1,0)
C 
C 
C PARRALLEL POLL
C 
  70  CALL EXEC(1,ILU+2200B,IPP,1,6,0)
      ITEP=7-IADR 
      ITP=2**ITEP 
      ITP1=IAND(ITP,IPP)
      IF(ITP1.EQ.0) GO TO 70
C 
C READ SELF TEST RESULT 
C 
      ID=500B+IADR
      CALL ODPAR(ID)
      IBF(1)=ID 
      IBF(2)=100577B
      LEN=-2
      CALL EXEC(1,ILU+2200B,IBF,LEN,2,0)
      IST=IAND(170B,IBF(17))
      IPAS=IST/8
C 
C 
C IF IPAS#0 SEND AN "END" COMMAND TO THE DRIVE. 
C 
C 
      IF(IPAS.EQ.0)GO TO 99 
C 
C 
      CALL XEND(ILU,IADR) 
C 
C 
  99  CONTINUE
      RETURN
      END 
C 
C 
C 
C 
C 
C 
      SUBROUTINE DID05(ILU,IDVID,IPAS,IC,IH,IS,ISTAT) 
     +,91711-1X108 REV.2001 791017
C 
C THIS SUBROUTINE CHECK REQUEST ADDRESS 
C 
      DIMENSION ISTAT(2),ID(5)
C 
      CALL XLGAD(ILU,IDVID,ICYL,IHED,ISCT,IER)
C 
C 
      IF(IER.NE.0)GO TO 45
      IT=IHED+ISCT
      IHS=IH+IS 
      IPAS=0
      IF((ICYL.NE.IC).OR.(IT.NE.IHS))GO TO 25 
      GO TO 35
  25  IPAS=1
C 
      GO TO 35
  45  IPAS=2
      CALL DSTAT(ILU,IDVID,ISTAT,ID,IER)
C 
  35  CONTINUE
      RETURN
      END 
C 
C 
C 
C 
C 
      SUBROUTINE DID07 (ILU,IDVID,IPAS,IADR,IC,IH,IS,ISTAT) 
     +,91711-1X108 REV.2001 791017
C 
C THIS CHECK THE REQUEST SECTOR ADDRESS COMMAND. SEEK TO AN ADDRESS,
C REQUEST SECTOR ADDRESS AND CHECK TO SEE IF IT IS THE CORRECT SECTOR.
C 
      DIMENSION ISTAT(2),ID(5)
C 
C 
      CALL XSEEK(ILU,IDVID,IC,IH,IS,ISTAT(1),ISTAT(2),IER)
      IF(IER.NE.0)GO TO 25
      CALL XSECA(ILU,IDVID,ISCT,IER)
      IF(IER.NE.0)GO TO 25
      IPAS=0
      GO TO 35
  25  IPAS=1
      CALL DSTAT(ILU,IDVID,ISTAT,ID,IER)
  35  CONTINUE
      RETURN
      END 
C 
C 
C 
C 
C 
      SUBROUTINE DID08(ILU,IADR,IPAS,IUN,IBF) 
     +,91711-1X108 REV.2001 791017
C 
C THIS SUBROUTINE CHECK CLEAR BY SEEING IF, AFTER COMPLETION,THE DSJ=2. 
C 
      DIMENSION IBF(20) 
C 
      IDVID=IADR+(256*IUN)
C 
C 
C 
C 
C 
      IT=440B+IADR
      CALL ODPAR(IT)
      IBF(1)=IT 
      IBF(2)=550B 
      IBF(3)=12B
      IBF(4)=1000B+IUN
      IBF(5)=100677B
C 
C CLEAR COMMAND 
C 
      CALL EXEC(2,ILU+2200B,IBF,16,1,0) 
C 
C PARALLEL POL
C 
 80   CALL EXEC(1,ILU+2200B,IPP,1,6,0)
      ITEP=7-IADR 
      ITP=2**ITEP 
      ITP1=IAND(ITP,IPP)
      IF(ITP1.EQ.0)GO TO 80 
C 
C 
C 
C DSJ 
C 
      CALL XDSJ(ILU,IDVID,IDSJ,IER) 
      IPAS=0
      IF(IDSJ.NE.2)IPAS=1 
      RETURN
      END 
C 
C 
C 
C 
C 
      SUBROUTINE DID09 (ILU,IDVID,IPAS,IBF1,ICYL,IHED,ISCT,ISTAT) 
     +,91711-1X108 REV.2001 791017
C 
C CHECKS READ FULL SECTOR AND INDUCING AN ERROR AS  PREPARATION TO
C THE NEXTS TESTS.
C 
      DIMENSION IBF1(160),ISTAT(2),ID(5)
C 
C 
C SEEK
C 
      CALL XSEEK(ILU,IDVID,ICYL,IHED,ISCT,ISTAT(1),ISTAT(2),IER)
      IF(IER.NE.0)GO TO 25
      CALL DECST(ISTAT,ID)
      IF(ID(2).NE.37B)GO TO 25
C 
C 
C 
C READ FULL SECTOR
C 
      LEN=138 
      CALL XRDFS(ILU,IDVID,IBF1,LEN,ISTAT(1),ISTAT(2),IER)
C 
      IF(IER.NE.0)GO TO 25
      CALL DECST(ISTAT,ID)
      IF(ID(2).NE.0)GO TO 25
C 
C CHECK CYLINDER, HEAD AND SECTOR COMPETABILITY.
C 
      IF(IBF1(18).NE.ICYL)GO TO 45
      ITEM=IAND(17777B,IBF1(19))
      IF(ITEM.NE.(IHED*256+ISCT))GO TO 45 
      IPAS=0
      GO TO 35
 25   IPAS=1
C 
      GO TO 35
 45   IPAS=2
C 
  35  IBF1(40)=IBF1(40)+5 
      RETURN
      END 
C 
C 
C 
C 
C 
      SUBROUTINE DID10 (ILU,IDVID,IPAS,IBF1,ICYL,IHED,ISCT,ISTAT) 
     +,91711-1X108 REV.2001 791017
C 
C THIS SUBROUTINE WILL WRITE THE FULL SECTOR WAS READ IN "DID09"
C WITH THE ERROR.THIS WILL BE USED IN "DID11" TO VERIFY THE EXISTING ERROR. 
C 
      DIMENSION ISTAT(2),ID(5),IBF1(160)
C 
C 
C SEEK
C 
C 
C 
C 
C 
      CALL XSEEK(ILU,IDVID,ICYL,IHED,ISCT,ISTAT(1),ISTAT(2),IER)
      IF(IER.NE.0)GO TO 25
      CALL DECST(ISTAT,ID)
C 
      IF(ID(2).NE.37B)GO TO 25
C 
C WRITE FULL SECTOR 
C 
      LEN=138 
C 
C 
C 
C 
      CALL XWRFS(ILU,IDVID,IBF1,LEN,ISTAT(1),ISTAT(2),IER)
      IF(IER.NE.0)GO TO 25
C 
C CALL STATUS 
C 
      CALL DECST(ISTAT,ID)
      IF(ID(2).NE.0)GO TO 25
      IPAS=0
      GO TO 35
 25   IPAS=1
 35   CONTINUE
      RETURN
      END 
C 
C 
C 
C 
C 
      SUBROUTINE DID11 (ILU,IDVID,IPAS,ICYL,IHED,ISCT,ISTAT)
     +,91711-1X108 REV.2001 791017
C 
C THIS SUBROUTINE CHECK VERIFY BY VERIFING THE SECTOR WITH THE INDUCED
C DATA ERROR AND SEEING IF THE DATA ERROR WAS DETECTED. 
C 
      DIMENSION ISTAT(2),ID(5)
C 
C 
C SEEK
C 
      CALL XSEEK(ILU,IDVID,ICYL,IHED,ISCT,ISTAT(1),ISTAT(2),IER)
      IF(IER.NE.0)GO TO 25
C 
      CALL DECST(ISTAT,ID)
      IF(ID(2).NE.37B)GO TO 25
C 
C CALL VERIFY 
C 
      CALL XVRFY(ILU,IDVID,1,ISTAT(1),ISTAT(2),IER) 
      IF(IER.EQ.0)GO TO 45
      CALL DECST(ISTAT,ID)
C 
C 
      IF(ID(2).NE.10B)GO TO 45
      IPAS=0
      GO TO 35
 25   IPAS=1
      GO TO 35
 45   IPAS=2
 35   CONTINUE
      RETURN
      END 
C 
C 
C 
C 
C 
      SUBROUTINE DID12 (ILU,IDVID,IPAS,ICYL,IHED,ISCT,IBF1,IBF2,ISTAT)
     +,91711-1X108 REV.2001 791017
C 
C THIS SUBROUTINE CHECK READ BY READING THE SAME SECTOR THAT WAS WRITTEN
C IN "DID10", SEEING IF THE DATA ERROR WAS DETECTED, AND CHECKING THE 
C THE READ DATA AGAINST THE WRITTEN DATA. 
C 
C THE SUBROUTINE WILL BE USED IN TEST 12,13,14. 
C 
C IF IPAS=2, READ WITHOUT OFFSET AND WITH VERIFY. 
C IF IPAS=3, READ WITH OFFSET AND WITH VERIFY.
C IF IPAS=4, READ WITHOUT OFFSET AND  WITHOUT VERIFY. 
C 
C 
      DIMENSION IBF1(160),IBF2(150),ISTAT(2),ID(5)
C 
C 
C SEEK
C 
      CALL XSEEK(ILU,IDVID,ICYL,IHED,ISCT,ISTAT(1),ISTAT(2),IER)
      IF(IER.NE.0)GO TO 45
C 
C 
      CALL DECST(ISTAT,ID)
      IF(ID(2).NE.37B)GO TO 45
C 
C 
      LEN=128 
C 
C 
      IF(IPAS.EQ.3)GO TO 55 
      IF(IPAS.EQ.4)GO TO 65 
C 
C READ WITHOUT OFFSET WITH VERIFY 
C 
      CALL XDRED(ILU,IDVID,IBF2,LEN,ISTAT(1),ISTAT(2),IER)
      GO TO 75
C 
C READ WITH OFFSET
C 
 55   IOFS=45 
      CALL XRDOF(ILU,IDVID,IBF2,LEN,IOFS,ISTAT(1),ISTAT(2),IER) 
      GO TO 75
C 
C READ WITHOUT VERIFY 
C 
 65   CALL XRDNV(ILU,IDVID,IBF2,LEN,ISTAT(1),ISTAT(2),IER)
C 
C CALL DSJ AND STATUS 
C 
 75   IF(IER.EQ.0)GO TO 25
      CALL DECST(ISTAT,ID)
      IF(ID(2).NE.10B)GO TO 25
C 
C COMPAR DATA 
C 
      K=0 
      DO 1 I=17,144 
      J=I+3 
      IF(IBF2(I)-IBF1(J))67,1,67
  67  K=1 
 1    CONTINUE
      IF(K.NE.0)GO TO 25
      IPAS=0
      GO TO 35
 25   IPAS=1
      GO TO 35
 45   IPAS=2
 35   CONTINUE
      RETURN
      END 
C 
C 
C 
C 
C 
      SUBROUTINE INIT (ILU,IDVID,IPAS,IC1,IH1,IS1,IC2,IH2,IS2,ISPD,ID,
     CIBF1,NSCT,ISTAT),91711-1X108 REV.2001 790922
C 
C 
C 
C THIS SUBROUTINE WILL SEEK TO THE SPECIFIED IC1 IH1 IS1, DOES AN 
C ADDRESS RECORD WITH THE INPUT CYLINDER, INITIALIZE THE TRACK WITH THE 
C INPUT SPD BITS AND CHECK TO SEE THAT THE TRACK WAS INITIALIZED
C PROPERLY. 
C 
C 
      DIMENSION IBF1(160),ISTAT(2),ID(5)
C 
C 
      LEN=128 
C 
C 
C IF IPAS=2 PERFORM ONLY READ AND CHRCK STATUS. 
C 
C 
      IF(IPAS.EQ.2)GO TO 55 
C 
C 
C 
C FILL UP THE BUFFER
C 
      DO 1 I=17,150 
      IBF1(I)=ISPD
  1   CONTINUE
C 
C 
C 
C 
C  INITIALIZE NSCT SECTORS (ALL TRACK)
C 
      DO 2 I=1,NSCT 
      CALL XSEEK(ILU,IDVID,IC1,IH1,IS1,ISTAT(1),ISTAT(2),IER) 
C 
C DSJ 
C 
      IF(IER.NE.0)GO TO 25
      CALL XADRC(ILU,IDVID,IC2,IH2,IS2,IER) 
C 
C DSJ 
C 
      IF(IER.NE.0)GO TO 25
C 
C 
      CALL XINIT(ILU,IDVID,IBF1,LEN,ISPD,ISTAT(1),ISTAT(2),IER) 
C 
C 
C 
C DSJ 
C 
      IF(IER.NE.0)GO TO 25
C 
C GO TO NEXT SECTOR 
C 
      IS1=IS1+1 
      IS2=IS2+1 
 2    CONTINUE
C 
C 
C 
      IS1=0 
  55  CALL XSEEK(ILU,IDVID,IC1,IH1,IS1,ISTAT(1),ISTAT(2),IER) 
C 
C DSJ 
C 
      IF(IER.NE.0)GO TO 25
C 
C 
      CALL XDRED(ILU,IDVID,IBF1,LEN,ISTAT(1),ISTAT(2),IER)
C 
C STATUS
C 
      CALL DECST(ISTAT,ID)
C 
      IF(IPAS.EQ.2)GO TO 65 
C 
C 
      IF(ID(1).NE.ISPD)GO TO 45 
C 
C 
  65  IPAS=0
      GO TO 35
 25   IPAS=1
      GO TO 35
 45   IPAS=2
 35   CONTINUE
      RETURN
      END 
C 
C 
C 
C 
C 
      SUBROUTINE FLMSK (ILU,IDVID,IPAS,IC,IH,IS,IBF1,ID,IMSK,LEN,IER
     +,IADR,ISTAT),91711-1X108 REV.2001 790922
C 
C 
C 
C 
C 
      DIMENSION IBF1(160),ISTAT(2),ID(5)
C 
C 
C 
C THIS SUBROUTINE WILL SET THE RIGHT FILE MASK AND PERFORM READ SECTOR. 
C IPAS  AND STATUS WILL RETURN TO THE MAIN PROGRAM. 
C 
C  SET FILE MASK
C 
      CALL XFMSK(ILU,IDVID,IMSK,IER)
C 
C 
      CALL DSTAT(ILU,IDVID,ISTAT,ID,IER)
      IF(IER.NE.0)GO TO 25
C 
C IF IPAS=2 SKIP THIS SECTION 
C 
      IF(IPAS.EQ.2)GO TO 85 
C SEEK
C 
      CALL XSEEK(ILU,IDVID,IC,IH,IS,ISTAT(1),ISTAT(2),IER)
C 
C DSJ 
C 
      IF(IER.NE.0)GO TO 25
C 
C READ LEN WORDS
C 
C IF IPAS=4 DO A READ FULL SECTOR.
C 
      IF(IPAS.NE.4)GO TO 33 
      CALL XRDFS(ILU,IDVID,IBF1,140,ISTAT(1),ISTAT(2),IER)
      GO TO 44
C 
C IF IPAS#4 DO READ SECTOR
C 
  33  CALL XDRED(ILU,IDVID,IBF1,LEN,ISTAT(1),ISTAT(2),IER)
C 
C CHECK STATUS
C 
  44  CALL DECST(ISTAT,ID)
C 
C 
  85  IPAS=0
      GO TO 35
 25   IPAS=1
 35   CONTINUE
      RETURN
      END 
C 
C 
C 
C 
C 
      SUBROUTINE DSTAT(ILU,IDVID,ISTAT,ID,IER)
     +,91711-1X108 REV.2001 791017
C 
C THIS SUBROUTINE WILL CHECK HPIB DISC STATUS AND BREAK IT TO FIVE WORDS
C AS EXPLAIN IN SUBROUTINE DECST. 
C 
      DIMENSION ISTAT(2),ID(5)
      CALL XSTAT(ILU,IDVID,ISTAT(1),ISTAT(2),IER) 
      CALL DECST(ISTAT,ID)
      RETURN
      END 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
      SUBROUTINE  MEST(ID,ILST,IPS1,ISTAT,IW37,IW38,IW45,IW44,IW39, 
     +IW91,IW92,IW46,IW65,IW66,IW93,IW94,IW95,IW47,IW48,IW59) 
     +,91711-1X108 REV.2001 791017
C 
C THIS SUBROUTINE WILL IDENNTIFY THE RIGHT ID(2) AND ID(5) OF THE 
C STATUS WORDS AND SEND THE RIGHT MESSAGE OUT TO THE TERMINAL.
C 
C 
C 
      DIMENSION IW37(17),IW38(12),IW45(19),IW44(14),IW39(19),IW91(22) 
      DIMENSION IW92(20),IW46(15),IW65(14),IW66(14),IW93(17),IW94(19) 
      DIMENSION IW95(19),IW47(16),IW48(18),IW59(24) 
      DIMENSION ID(5),ISTAT(2)
C 
C 
C DEFINE SPACE LINE.
C 
C 
      IW90=2H 
C 
C 
C 
      CALL DECST(ISTAT,ID)
C 
C 
      IF(ID(2).EQ.0)GO TO 290 
      IF(ID(2).EQ.1)GO TO 300 
      IF(ID(2).EQ.3)GO TO 101 
      IF(ID(2).EQ.7)GO TO 103 
      IF(ID(2).EQ.10B)GO TO 104 
      IF(ID(2).EQ.11B)GO TO 105 
      IF(ID(2).EQ.12B)GO TO 106 
      IF(ID(2).EQ.13B)GO TO 107 
      IF(ID(2).EQ.14B)GO TO 108 
      IF(ID(2).EQ.16B)GO TO 109 
      IF(ID(2).EQ.20B)GO TO 310 
      IF(ID(2).EQ.21B)GO TO 111 
      IF(ID(2).EQ.22B)GO TO 112 
      IF(ID(2).EQ.23B)GO TO 113 
      IF(ID(2).EQ.26B)GO TO 114 
      IPS1=0
      GO TO 999 
C 
C 
C 
 290  CALL EXEC(2,200B+ILST,IW37,17)
      CALL EXEC(2,200B+ILST,IW38,12)
      CALL EXEC(2,200B+ILST,IW45,17)
      CALL EXEC(2,200B+ILST,IW44,14)
      CALL EXEC(2,200B+ILST,IW39,19)
      CALL EXEC(2,200B+ILST,IW90,1) 
      IPS1=1
      GO TO 999 
C 
C 
300   CALL EXEC(2,200B+ILST,IW37,17)
      CALL EXEC(2,200B+ILST,IW44,14)
      CALL EXEC(2,200B+ILST,IW91,22)
      CALL EXEC(2,200B+ILST,IW90,1) 
      IPS1=1
      GO TO 999 
C 
C 
 101  CALL EXEC(2,200B+ILST,IW37,17)
      CALL EXEC(2,200B+ILST,IW44,14)
      CALL EXEC(2,200B+ILST,IW90,1) 
      IPS1=1
      GO TO 999 
C 
C 
  103 CALL EXEC(2,200B+ILST,IW38,12)
      CALL EXEC(2,200B+ILST,IW39,19)
      CALL EXEC(2,200B+ILST,IW37,17)
      CALL EXEC(2,200B+ILST,IW44,14)
      CALL EXEC(2,200B+ILST,IW45,17)
      CALL EXEC(2,200B+ILST,IW92,20)
      CALL EXEC(2,200B+ILST,IW90,1) 
      IPS1=1
      GO TO 999 
C 
C 
 104  CALL EXEC(2,200B+ILST,IW92,20)
      CALL EXEC(2,200B+ILST,IW44,14)
      CALL EXEC(2,200B+ILST,IW45,17)
      CALL EXEC(2,200B+ILST,IW46,15)
      CALL EXEC(2,200B+ILST,IW39,19)
      CALL EXEC(2,200B+ILST,IW38,12)
      CALL EXEC(2,200B+ILST,IW37,17)
      CALL EXEC(2,200B+ILST,IW65,14)
      CALL EXEC(2,200B+ILST,IW90,1) 
      IPS1=1
      GO TO 999 
C 
C 
 105  CALL EXEC(2,200B+ILST,IW37,17)
      CALL EXEC(2,200B+ILST,IW45,17)
      CALL EXEC(2,200B+ILST,IW46,15)
      CALL EXEC(2,200B+ILST,IW39,19)
      CALL EXEC(2,200B+ILST,IW44,14)
      CALL EXEC(2,200B+ILST,IW38,12)
      CALL EXEC(2,200B+ILST,IW92,20)
      CALL EXEC(2,200B+ILST,IW90,1) 
      IPS1=1
      GO TO 999 
C 
C 
 106  CALL EXEC(2,200B+ILST,IW44,14)
      CALL EXEC(2,200B+ILST,IW37,17)
      CALL EXEC(2,200B+ILST,IW91,22)
      CALL EXEC(2,200B+ILST,IW90,1) 
      IPS1=1
      GO TO 999 
C 
C 
 107  CALL EXEC(2,200B+ILST,IW44,14)
      CALL EXEC(2,200B+ILST,IW45,17)
      CALL EXEC(2,200B+ILST,IW46,15)
      CALL EXEC(2,200B+ILST,IW37,17)
      CALL EXEC(2,200B+ILST,IW39,19)
      CALL EXEC(2,200B+ILST,IW38,12)
      CALL EXEC(2,200B+ILST,IW65,14)
      CALL EXEC(2,200B+ILST,IW66,14)
      CALL EXEC(2,200B+ILST,IW90,1) 
      IPS1=1
      GO TO 999 
C 
C 
 108  CALL EXEC(2,200B+ILST,IW37,17)
      CALL EXEC(2,200B+ILST,IW44,14)
      CALL EXEC(2,200B+ILST,IW90,1) 
      IPS1=1
      GO TO 999 
C 
C 
 109  CALL EXEC(2,200B+ILST,IW44,14)
      CALL EXEC(2,200B+ILST,IW91,22)
      CALL EXEC(2,200B+ILST,IW37,17)
      CALL EXEC(2,200B+ILST,IW90,1) 
      IPS1=1
      GO TO 999 
C 
C 
 310  CALL EXEC(2,200B+ILST,IW93,17)
      CALL EXEC(2,200B+ILST,IW37,17)
      CALL EXEC(2,200B+ILST,IW44,14)
      CALL EXEC(2,200B+ILST,IW90,1) 
      IPS1=1
      GO TO 999 
C 
C 
 111  CALL EXEC(2,200B+ILST,IW94,19)
      CALL EXEC(2,200B+ILST,IW37,17)
      CALL EXEC(2,200B+ILST,IW44,14)
      CALL EXEC(2,200B+ILST,IW90,1) 
      IPS1=1
      GO TO 999 
C 
C 
 112  CALL EXEC(2,200B+ILST,IW39,19)
      CALL EXEC(2,200B+ILST,IW92,20)
      CALL EXEC(2,200B+ILST,IW39,19)
      CALL EXEC(2,200B+ILST,IW38,12)
      CALL EXEC(2,200B+ILST,IW45,17)
      CALL EXEC(2,200B+ILST,IW37,17)
      CALL EXEC(2,200B+ILST,IW44,14)
      CALL EXEC(2,200B+ILST,IW65,14)
      CALL EXEC(2,200B+ILST,IW90,1) 
      IPS1=1
      GO TO 999 
C 
C 
 114  CALL EXEC(2,200B+ILST,IW95,19)
      CALL EXEC(2,200B+ILST,IW37,17)
      CALL EXEC(2,200B+ILST,IW44,14)
      CALL EXEC(2,200B+ILST,IW90,1) 
      IPS1=1
      GO TO 999 
C 
C 
 113  IF(ID(5).EQ.1)GO TO 151 
      IF(ID(5).EQ.2)GO TO 151 
      IF(ID(5).EQ.3)GO TO 152 
      IF(ID(5).EQ.5)GO TO 153 
      IF(ID(5).EQ.6)GO TO 154 
      IF(ID(5).EQ.7)GO TO 155 
      IPS1=2
      GO TO 999 
C 
C 
 151  CALL EXEC(2,200B+ILST,IW37,17)
      CALL EXEC(2,200B+ILST,IW45,17)
      CALL EXEC(2,200B+ILST,IW38,12)
      CALL EXEC(2,200B+ILST,IW44,14)
      CALL EXEC(2,200B+ILST,IW39,19)
      CALL EXEC(2,200B+ILST,IW90,1) 
      IPS1=1
      GO TO 999 
 152  CALL EXEC(2,200B+ILST,IW37,17)
      CALL EXEC(2,200B+ILST,IW38,12)
      CALL EXEC(2,200B+ILST,IW39,19)
      CALL EXEC(2,200B+ILST,IW44,14)
      CALL EXEC(2,200B+ILST,IW45,17)
      CALL EXEC(2,200B+ILST,IW90,1) 
      IPS1=1
      GO TO 999 
C 
C 
 153  CALL EXEC(2,200B+ILST,IW59,24)
      CALL EXEC(2,200B+ILST,IW90,1) 
      IPS1=1
      GO TO 999 
C 
C 
 154  CALL EXEC(2,200B+ILST,IW47,16)
      CALL EXEC(2,200B+ILST,IW37,17)
      CALL EXEC(2,200B+ILST,IW44,14)
      CALL EXEC(2,200B+ILST,IW90,1) 
      IPS1=1
      GO TO 999 
C 
C 
 155  CALL EXEC(2,200B+ILST,IW48,18)
      CALL EXEC(2,200B+ILST,IW37,17)
      CALL EXEC(2,200B+ILST,IW44,14)
      CALL EXEC(2,200B+ILST,IW90,1) 
      IPS1=1
C 
C 
  999 CONTINUE
      RETURN
      END 
C 
C 
C 
C 
C 
      SUBROUTINE LOPBK(ILU,IPAS,IADR,IBF),91711-1X108 REV.2001 790922 
C 
C 
C THIS SUB WILL PERFORM LOOP BACK TEST. 
C IPAS=0 IF SUCCED. 
C 
      DIMENSION IBF(35) 
C 
      IT=440B+IADR
      CALL ODPAR(IT)
      IBF(1)=IT 
      IBF(2)=100776B
C 
C FILL UP THE BUFFER
C 
      J=1 
      DO 8 I=17,26
      IBF(I)=2**J 
      J=J+1 
  8   CONTINUE
C 
C WRITE PART OF THE TEST
C 
      CALL EXEC(1,ILU+2200B,IBF,10,4,0) 
C 
C CHANGE THE BUFFER CONTENANT 
C 
      DO 9 I=17,30
      IBF(I)=50 
  9   CONTINUE
C 
C READ PART OF TEST 
C 
      IT=500B+IADR
      CALL ODPAR(IT)
      IBF(1)=IT 
      CALL EXEC(1,ILU+2200B,IBF,8,3,0)
C 
C CHECK READING DATA
C 
      J=1 
      DO 3 I=17,24
      IB=2**J 
      IF(IBF(I).NE.IB)GO TO 25
      J=J+1 
  3   CONTINUE
C 
      IPAS=0
      GO TO 35
  25  IPAS=1
  35  CONTINUE
      RETURN
      END 
C 
C 
C 
C 
C 
      SUBROUTINE DID35(ILU,IDVID,IPAS,IC,IH,IS,ISTAT,IBF2)
     +,91711-1X108 REV.2001 791017
C 
C THIS SUBROUTINE WILL RESET FILE MASK TO CYL MODE NO AUTO SEEKS
C AND DO A SECTOR WRITE . 
C 
C 
      DIMENSION IBF2(150),ISTAT(2),ID(5)
      CALL XFMSK(ILU,IDVID,2,IER) 
      CALL DSTAT(ILU,IDVID,ISTAT,ID,IER)
      IF(IER.NE.0)GO TO 25
      DO 2 I=1,150
      IBF2(I)=I 
  2   CONTINUE
C 
      CALL XSEEK(ILU,IDVID,IC,IH,IS,ISTAT(1),ISTAT(2),IER)
      IF(IER.NE.0)GO TO 25
C 
C 
      CALL XDWRT(ILU,IDVID,IBF2,128,ISTAT(1),ISTAT(2),IER)
      IF(IER.NE.0)GO TO 25
C 
C 
      IPAS=0
      GO TO 35
  25  IPAS=1
  35  CONTINUE
      RETURN
      END 
C 
C 
C 
C 
C 
      SUBROUTINE DID36 (ILU,IDVID,IPAS,IC,IH,IS,ISTAT,IBF2) 
     +,91711-1X108 REV.2001 791017
C 
C THIS SUBROUTINE WILL READ THE SECTOR WAS WRITTEN IN "DID35" AND CHECK 
C FOR ERROR.
C 
      DIMENSION IBF2(150),ISTAT(2)
C 
      CALL XSEEK(ILU,IDVID,IC,IH,IS,ISTAT1,ISTAT2,IER)
      IF(IER.NE.0)GO TO 25
C 
C 
      CALL XDRED(ILU,IDVID,IBF2,128,ISTAT1,ISTAT2,IER)
      IF(IER.NE.0)GO TO 25
C 
      DO 4 J=17,144 
      IF(IBF2(J).NE.J)GO TO 45
  4   CONTINUE
C 
      IPAS=0
      GO TO 35
  25  IPAS=1
      GO TO 35
  45  IPAS=2
  35  CONTINUE
      RETURN
      END 
C 
C 
C 
C 
C 
      SUBROUTINE DID40 (ILU,IDVID,IPAS,NCYL,ISTAT)
     +,91711-1X108 REV.2001 791017
C 
C THIS SUB WILL CHECK SEEK FOR INCREAMENTAL POWER OF 2. THIS CHECKS FOR 
C BAD BITS IN REGISTERS.
C 
C 
      DIMENSION ISTAT(2),ID(5)
      J=0 
      DO 15 I=1,11
      CALL XSEEK(ILU,IDVID,J,0,0,ISTAT(1),ISTAT(2),IER) 
      IF(IER.NE.0)GO TO 25
C 
C 
      CALL XLGAD(ILU,IDVID,IC,IH,IS,IER)
      CALL DSTAT(ILU,IDVID,ISTAT,ID,IER)
      IF(IER.NE.0)GO TO 25
      IF(IC.NE.J)GO TO 35 
      J=J*2 
      IF(J.EQ.0)J=1 
      IF(J.GT.NCYL)J=NCYL-1 
  15  CONTINUE
      IPAS=0
      GO TO 45
  25  IPAS=1
      GO TO 45
  35  IPAS=2
  45  CONTINUE
      RETURN
      END 
C 
C 
C 
C 
C 
      SUBROUTINE DID45 (ILU,IDVID,IPAS,IC,IH,IS,NSCT,ISTAT,IBF2)
     +,91711-1X108 REV.2001 791017
C 
C THIS SUB CHECK VERIFY FOR INCREASING POWER OF TWO NUMBER OF SECTORS.
C 
C 
      DIMENSION IBF2(150),ISTAT(2),ID(5)
C 
C IF THIS IS A BAD TRACK, SKIP THIS TEST. 
C 
      CALL XSEEK(ILU,IDVID,IC,IH,IS,ISTAT(1),ISTAT(2),IER)
      IF(IER.NE.0)GO TO 25
      CALL XDRED(ILU,IDVID,IBF2,128,ISTAT(1),ISTAT(2),IER)
      CALL DECST(ISTAT,ID)
      IF(IAND(ID(1),1).NE.0)GO TO 35
C 
C 
      J=1 
      DO 5 I=1,7
      CALL XSEEK(ILU,IDVID,IC,IH,IS,ISTAT(1),ISTAT(2),IER)
      IF(IER.NE.0)GO TO 25
      CALL XVRFY(ILU,IDVID,J,ISTAT(1),ISTAT(2),IER) 
      IF(IER.NE.0)GO TO 25
      J=J*2 
      IF(J.GT.NSCT)J=NSCT-1 
  5   CONTINUE
 35   IPAS=0
      GO TO 65
 25   IPAS=1
 65   CONTINUE
      RETURN
      END 
C 
C 
C 
C 
C 
      SUBROUTINE DID50 (ILU,IDVID,IPAS,IADR,IBF)
     +,91711-1X108 REV.2001 791017
C 
C TEST FOR ILLEGAL OPCODE 
C 
      DIMENSION IBF(20),ISTAT(2),ID(5)
C 
C 
      IT=440B+IADR
      CALL ODPAR(IT)
      IBF(1)=IT 
      IBF(2)=550B 
C 
C IBF(3) IS THE ILLEGAL OPCODE
C 
      IBF(3)=21B
      IBF(4)=1000B
      IBF(5)=100677B
C 
C 
      CALL EXEC(2,ILU+2200B,IBF,16,1,0) 
C 
C CALL STATUS 
C 
      CALL XSTAT(ILU,IDVID,ISTAT(1),ISTAT(2),IER) 
C 
      IF(IER.NE.0)GO TO 25
      CALL DECST(ISTAT,ID)
      IF(ID(2).NE.1)GO TO 25
      IPAS=0
      GO TO 35
  25  IPAS=1
  35  CONTINUE
      RETURN
      END 
C 
C 
C 
C 
C 
      SUBROUTINE FMSCP(ILU,IDVID,IPAS,IC1,IH1,IS1,IC2,IH2,IS2,NSCT
     +,ISTAT,IBF1),91711-1X108 REV.2001 790922
C 
C THIS SUBROUTINE WILL SEEK TO IC1,IH1 AND IS1=0
C READ FULL SECTOR FOR ONE SECTOR. WRITE FULL SECTOR AT IC2,IH2,IS1=0 
C SEEK TO SAME LOCATION BUT IS2=1,AND READ A SECTOR.CHECK FOR CYL 
C MISCOMPARE STATUS. REINITIALIZE IC2.
C IF IPAS=10B INDUCE AN ERROR AND CHECK FOR STATUS. 
C 
C 
      DIMENSION IBF1(160),ISTAT(2),ID(5)
C 
C 
      CALL XSEEK(ILU,IDVID,IC1,IH1,IS1,ISTAT(1),ISTAT(2),IER) 
      IF(IER.NE.0)GO TO 25
      CALL XRDFS(ILU,IDVID,IBF1,138,ISTAT(1),ISTAT(2),IER)
      IF(IER.NE.0)GO TO 25
      IF(IPAS.NE.10B)GO TO 40 
      IBF1(20)=IBF1(20)+5 
  40  CALL XSEEK(ILU,IDVID,IC2,IH2,IS2,ISTAT(1),ISTAT(2),IER) 
      IF(IER.NE.0)GO TO 25
      CALL XWRFS(ILU,IDVID,IBF1,138,ISTAT(1),ISTAT(2),IER)
      IF(IER.NE.0)GO TO 25
      IF(IPAS.EQ.10B)GO TO 30 
      IS2=IS2+1 
  30  CALL XSEEK(ILU,IDVID,IC2,IH2,IS2,ISTAT(1),ISTAT(2),IER) 
      IF(IER.NE.0)GO TO 25
      CALL XDRED(ILU,IDVID,IBF1,128,ISTAT(1),ISTAT(2),IER)
      CALL DECST(ISTAT,ID)
      IF(ID(2).NE.IPAS)GO TO 45 
      IPAS1=0 
      GO TO 35
  25  IPAS1=1 
      GO TO 35
  45  IPAS=2
  35  CONTINUE
      IS2=0 
      ISPD=0
      CALL INIT(ILU,IDVID,IPAS,IC2,IH2,IS2,IC2,IH2,IS2,ISPD,ID,IBF1,
     +NSCT) 
C 
      IPAS=IPAS1
C 
      RETURN
      END 
C 
C 
C 
C 
C 
      SUBROUTINE DID56(ILU,IDVID,IPAS,IADR,IBF) 
     +,91711-1X108 REV.2001 791017
C 
C THIS SUB WILL SEND A LISTEN  COMMAND WITH AN ILLEGAL SECONDARY. CHECK 
C FOR I/O PROGRAM ERROR STATUS. 
C 
C 
      DIMENSION IBF(20),ISTAT(2),ID(5)
C 
C 
      IT=440B+IADR
      CALL ODPAR(IT)
      IBF(1)=IT 
      IBF(2)=550B 
C 
C  IBF(3) AND IBF(4)  IS ILLEGAL SECONDARIES
C 
      IBF(3)=22B
      IBF(4)=1002B
      IBF(5)=100677B
C 
C SEND IT OUT.
C 
      CALL EXEC(2,ILU+2200B,IBF,5,1,0)
C 
C CALL STATUS 
C 
      CALL XSTAT(ILU,IDVID,ISTAT(1),ISTAT(2),IER) 
      IF(IER.NE.0)GO TO 25
      CALL DECST(ISTAT,ID)
      IF(ID(2).NE.12B)GO TO 25
      IPAS=0
      GO TO 35
  25  IPAS=1
  35  CONTINUE
      RETURN
      END 
C 
C 
C 
C 
C 
C 
      SUBROUTINE DID57 (ILU,IDVID,IPAS,IADR,IBF)
     +,91711-1X108 REV.2001 791017
C 
C  SEND GET COMMAND WITH AN ILLEGAL SECONDARY. CHECK FOR I/O
C  PROGRAM ERROR STATUS.
C 
      DIMENSION IBF(20),ISTAT(2),ID(5)
C 
C 
      IT=440B+IADR
      CALL ODPAR(IT)
      IBF(1)=IT 
      IBF(2)=500B 
C 
C IBF(3) IS ILLEGAL SECONDARY.
C 
      IBF(3)=100740B
C 
C SEND BUFFER OUT.
C 
      CALL EXEC(1,ILU+2200B,IBF,3,1,0)
C 
C CALL STATUS 
C 
      CALL XSTAT(ILU,IDVID,ISTAT(1),ISTAT(2),IER) 
      IF(IER.NE.0)GO TO 25
      CALL DECST(ISTAT,ID)
      IF(ID(2).NE.12B)GO TO 25
      IPAS=0
      GO TO 35
  25  IPAS=1
  35  CONTINUE
      RETURN
      END 
C 
C 
C 
C 
C 
      SUBROUTINE SKER(ILU,IDVID,IPAS,IC,IH,IS)
     +,91711-1X108 REV.2001 791017
C 
C THIS SUB CHECK IF  BIT OF STATUS WORD 2 IS SET AND IF IDC STATUS IS 
C STAT-2 ERROR. 
C 
C 
      DIMENSION ISTAT(2),ID(5)
C 
      CALL XSEEK(ILU,IDVID,IC,IH,IS,ISTAT(1),ISTAT(2),IER)
      CALL DECST(ISTAT,ID)
      IF(ID(2).NE.23B)GO TO 25
      ID5=IAND(ID(5),4) 
      IF(ID5.EQ.0)GO TO 25
      IPAS=0
      GO TO 35
  25  IPAS=1
  35  CALL XSEEK(ILU,IDVID,5,1,20,ISTAT1,ISTAT2,IER)
      RETURN
      END 
C 
C 
C 
C 
C 
C 
      SUBROUTINE RESTH(ILU,IDVID,IPAS,IC,IH,IS,ID,ISTAT,IBF1) 
     +,91711-1X108 REV.2001 790922
C 
C THIS SUBROUTINE WILL SEEK TO IC,IH,IS . IF IPAS=2 IT
C WILL READ A SECTOR AND WRITE THE SECTOR BACK TO THE SAME
C LOCATION. 
C IF IPAS=3 IT WILL DO THE SAME BUT WITH FULL SECTOR. 
C 
C IF IPAS=4 IT WILL DO INTIALIZATION. 
C 
C 
C 
C 
      DIMENSION ISTAT(2),ID(5),IBF1(160)
C 
C CALEAN UP THE BUFFER
C 
      DO 5 I=1,160
      IBF1(I)=0 
  5   CONTINUE
C 
C 
C 
      CALL XSEEK(ILU,IDVID,IC,IH,IS,ISTAT(1),ISTAT(2),IER)
C 
C 
      IF(IER.NE.0)GO TO 25
C 
      CALL DECST(ISTAT,ID)
C 
C 
      IF(IPAS.EQ.2)GO TO 45 
      IF(IPAS.EQ.3)GO TO 55 
      IF(IPAS.EQ.4)GO TO 75 
      GO TO 35
C 
C 
  45  CALL XDRED(ILU,IDVID,IBF1,128,ISTAT(1),ISTAT(2),IER)
      IF(IER.NE.0)GO TO 25
C 
      CALL XSEEK(ILU,IDVID,IC,IH,IS,ISTAT(1),ISTAT(2),IER)
      IF(IER.NE.0)GO TO 25
      CALL XDWRT(ILU,IDVID,IBF1,128,ISTAT(1),ISTAT(2),IER)
      CALL DECST(ISTAT,ID)
      GO TO 35
C 
C 
  55  CALL XRDFS(ILU,IDVID,IBF1,138,ISTAT(1),ISTAT(2),IER)
      IF(IER.NE.0)GO TO 25
      CALL XSEEK(ILU,IDVID,IC,IH,IS,ISTAT(1),ISTAT(2),IER)
      IF(IER.NE.0)GO TO 25
      CALL XWRFS(ILU,IDVID,IBF1,138,ISTAT(1),ISTAT(2),IER)
      CALL DECST(ISTAT,ID)
      GO TO 35
C 
C 
  75  ISPD=0
      CALL XINIT(ILU,IDVID,IBF1,128,ISPD,ISTAT(1),ISTAT(2),IER) 
      CALL DECST(ISTAT,ID)
  35  IPAS=0
      GO TO 65
  25  IPAS=1
  65  CONTINUE
      RETURN
      END 
C 
C 
C 
C 
C 
C 
      SUBROUTINE INBA(IR),91711-1X108 REV.2001 790922 
C 
C 
C THIS SUB WILL INPUT TWO ASCII CHARACTER AND CONVERT THEM TO 
C BINARRY. THE BINARRY VALUE WILL BE IN IR. 
C 
C 
      CALL EXEC(1,401B,IK,-2) 
      CALL ABREG(IA,IB) 
      IK1=IAND(7B,IK) 
      IK2=IK/32 
      IK2=IAND(70B,IK2) 
      IR=IK1+IK2
      IF(IB.EQ.1)IR=IK2/8 
      RETURN
      END 
C 
C 
C 
C 
C 
C 
      SUBROUTINE INDC(IK,IR),91711-1X108 REV.2001 791105
C 
C     CHANGE MADE 791105 TO CORRECT THE PART NUMBER ONLY
C 
C  THIS SUB WILL INPUT UP-TO FOUR ASCII CHARACTERS AND CONVERT
C  THEM TO BINARRY. THE BINARRY VALUE WILL BE IN IK.
C 
C 
      DIMENSION IR(2) 
C 
C 
      CALL EXEC(1,401B,IR,-4) 
      CALL ABREG(IA,IB) 
C 
C 
      IR1=IAND(77B,IR(2)) 
      IR1=IR1-60B 
C 
      IR2=IR(2)/256 
      IR2=IAND(77B,IR2) 
      IR2=(IR2-60B)*10
C 
      IR3=IAND(77B,IR(1)) 
      IR3=(IR3-60B)*100 
C 
      IR4=IR(1)/256 
      IR4=IAND(77B,IR4) 
      IR4=(IR4-60B)*1000
C 
      IK=IR1+IR2+IR3+IR4
C 
      IF(IB.EQ.3)IK=(IR2+IR3+IR4)/10
      IF(IB.EQ.2)IK=(IR3+IR4)/100 
      IF(IB.EQ.1)IK=IR4/1000
C 
      RETURN
      END 
      END$