FTN4,L
      PROGRAM TXMV0(3,89),91711-16015  REV 1926  790418 
C 
C  DISC MEMORY VERIFICATION PROGRAM.
C 
C 
C     GET INPUT PARAMETERS FROM RUN COMMAND 
C 
C     RU,TXMV0,LIST,TESTLU
C 
C         WHERE  LIST  = LOGICAL UNIT FOR LISTING DEVICE. 
C                        DEFAULT IS TERMINAL CONSOLE (LU=1).
C               TESTLU = DISC LU TO BE TESTED 
C 
C 
C     TEST SYSTEM DISC LOGICAL UNIT.
C 
C     TEST SEQUENCE IS: 
C       1. CREATE A FILE (TXM0X) ON THE LU.  TYPE 1 FILE. 
C       2. IF AN ERROR OCCURS, THE FILE MAY HAVE ALREADY
C          EXISTED.  THIS IS AN ERROR CONDITION. PROGRAM
C          REPORTS ERROR AND STOPS. 
C       3. OPEN THE FILE.  (FILE IS AUTOMATICALLY REWOUND ON OPEN)
C       4. WRITE 3 RECORDS TO THE FILE. 
C       5. READ THE DATA FROM THE FILE AND VERIFY EACH RECORD.
C       6. REPORT ALL ERRORS ON LISTING LU. 
C       7. CLOSE THE FILE AND PURGE FILE. 
C 
C 
      INTEGER PNAME(3)
      INTEGER NAME(3),IDCB(144),IERR,ISIZE(2),ITYPE 
      INTEGER ICR,IPARMS(5),LULIST,LUDISC 
      INTEGER ITEMP,CODE12
      INTEGER NUMREC,IBUF(128,3),TBUF(128),NWORDS 
      INTEGER ISTAT(125)
      INTEGER NERROR
      INTEGER CODE13
      INTEGER I,J,L,LU,OFLAG
      INTEGER EQT4,EQT5,EQTST 
      INTEGER NDTYPE
C     ERROR STATUS WORD DISC EQUIPMENT TYPES 031B AND 032B
      INTEGER M31LEN(8),M32LEN(8) 
      INTEGER M31STR(8),M32STR(8) 
      INTEGER M(125)
C 
C 
      DATA    PNAME/2HTX,2HMV,2H0 / 
      DATA    NAME/2HTX,2HM0,2HX /
      DATA    ISTAT/125*0/
      DATA    NERROR/0/ 
      DATA    ISIZE/3,128/
      DATA    ITYPE/1/
      DATA    IPARMS/5*0/ 
      DATA    CODE13/13/
      DATA    LULIST/1/ 
      DATA    IBUF/128*05252B,128*17777B,128*012525B/ 
      DATA    LUDISC/0/ 
      DATA    M( 1),M( 2),M( 3),M( 4),M( 5)/2HPR,2HOT,2HEC,2HT ,2HSW/ 
      DATA    M( 6),M( 7),M( 8),M( 9),M(10)/2HIT,2HCH,2H S,2HET,2H  / 
      DATA    M(11),M(12),M(13),M(14),M(15)/2HDR,2HIV,2HE ,2HFO,2HRM/ 
      DATA    M(16),M(17),M(18),M(19),M(20)/2HAT,2H S,2HWI,2HTC,2HH / 
      DATA    M(21),M(22)/2HSE,2HT /
      DATA    M(23),M(24),M(25),M(26),M(27)/2HHA,2HRD,2HWA,2HRE,2H F/ 
      DATA    M(28),M(29),M(30)/2HAU,2HLT,2H  / 
      DATA    M(31),M(32),M(33),M(34),M(35)/2HFL,2HAG,2HGE,2HD ,2HTR/ 
      DATA    M(36),M(37),M(38),M(39),M(40)/2HAC,2HK(,2HPR,2HOT,2HEC/ 
      DATA    M(41),M(42),M(43)/2HTE,2HD),2H  / 
      DATA    M(44),M(45),M(46),M(47),M(48)/2HSE,2HEK,2H C,2HHE,2HCK/ 
      DATA    M(49)/2H  / 
      DATA    M(50),M(51),M(52),M(53),M(54)/2HNO,2HT ,2HRE,2HAD,2HY / 
      DATA    M(55),M(56),M(57),M(58),M(59)/2HDE,2HVI,2HCE,2H B,2HUS/ 
      DATA    M(60)/2HY / 
      DATA    M(61),M(62),M(63),M(64),M(65)/2HER,2HRO,2HR ,2HEX,2HIS/ 
      DATA    M(66),M(67)/2HTS,2H  /
      DATA    M(68),M(69),M(70),M(71),M(72)/2HEN,2HD ,2HOF,2H T,2HAP/ 
      DATA    M(73)/2HE / 
      DATA    M(74),M(75),M(76),M(77),M(78)/2HAD,2HDR,2HES,2HS ,2HER/ 
      DATA    M(79),M(80),M(81)/2HRO,2HR ,2H  / 
      DATA    M(82),M(83),M(84),M(85),M(86)/2HDA,2HTA,2H E,2HRR,2HOR/ 
      DATA    M(87)/2H  / 
      DATA    M(88),M(89),M(90),M(91),M(92)/2HUN,2HDE,2HFI,2HNE,2HD / 
      DATA    M(93),M(94),M(95),M(96),M(97)/2H S,2HTA,2HTU,2HS ,2HBI/ 
      DATA    M(98)/2HT / 
      DATA    M(99),M(100),M(101),M(102)/2HDI,2HSC,2H H,2HAR/ 
      DATA    M(103),M(104),M(105),M(106)/2HDW,2HAR,2HE ,2HER/
      DATA    M(107),M(108),M(109),M(110)/2HRO,2HR ,2H  ,2H  /
      DATA    M31LEN/10,12,10,10,10,05,06,07/ 
      DATA    M31STR/01,11,99,99,99,50,55,61/ 
      DATA    M32LEN/11,05,06,10,10,10,10,07/ 
      DATA    M32STR/88,50,68,99,99,99,99,61/ 
C 
C 
C     GET INPUT PARAMETER FOR LISTING LOGICAL UNIT
      CALL RMPAR(IPARMS)
      LULIST=IPARMS(1)
      IF (IPARMS(1).LE.0) LULIST=LOGLU(IPARMS(1)) 
      LUDISC = IPARMS(2)
      IF ((LUDISC.GT.0).AND.(LUDISC.LT.64)) GO TO 700 
C     INVALUD LU NUMBER SPECIFIED 
      WRITE(LULIST,9795) (PNAME(J),J=1,3) 
 9795 FORMAT(/,2X,3A2,"- LU# SPECIFIED FOR DISC IS ILLEGAL."/ 
     1"          RERUN TEST SPECIFYING AN INTEGER >0 AND <64 FOR LU#.") 
      GO TO 850 
  700 CONTINUE
C 
C     MAIN PROGRAM LOOP 
C 
C     TEST ALL POSSIBLE LU'S ON SYSTEM
      LU = -LUDISC
C     TEST TO SEE IF LU IS ASSIGNED TO A KNOWN DISC TYPE. 
      CALL EXEC(CODE13,LUDISC,EQT5,EQT4,EQTST)
C 
C     IF CHANNEL NUMBER = 0, THIS LU IS NOT ASSIGNED TO ANY DEVICE
      IF (IAND(EQT4,077B).NE.0) GO TO 800 
C 
C     LU IS UNASSIGNED.  DO NOT TEST THIS LU. 
      WRITE(LULIST,5007) (PNAME(J),J=1,3),LUDISC
 5007 FORMAT(/,2X,3A2,"- LU#",I3,": NOT ASSIGNED, NOT TESTED!"/)
      GO TO 9999
C     MAKE SURE DEVICE IS ASSIGNED TO A DISC DEVICE.
  800 NDTYPE = IAND(EQT5,037400B) 
      NDTYPE = NDTYPE / 0400B 
      IF ((NDTYPE.GE.031B).AND.(NDTYPE.LE.033B)) GO TO 900
C     LU NOT ASSIGNED TO A KNOWN DISC TYPE. 
      WRITE(LULIST,5004) (PNAME(J),J=1,3),LUDISC
 5004 FORMAT(/,2X,3A2,"- LU#",I3," IS NOT ASSIGNED TO A DISC."/ 
     1"          RERUN TEST SPECIFYING CORRECT LU#.") 
      GO TO 850 
  900 CONTINUE
C     CHECK DISC STATUS TO VERIFY THAT DISC CAN BE TESTED.
C     IS DISC ONLINE? 
      CALL EXEC(CODE13,LUDISC,EQT5,EQT4,EQTST)
      IF (IAND(EQTST,0100000B).EQ.0) GO TO 925
C 
C     DISC LU IS DOWN 
C 
      WRITE(LULIST,5102) (PNAME(J),J=1,3),LUDISC
      GO TO 850 
C 
C     DISC LU IS UP.  CHECK TO SEE IF CARTRIDGE IS MOUNTED.  GET
C     STATUS OF CARTRIDGES MOUNTED. 
C 
  925 CALL FSTAT(ISTAT) 
      DO 930 J=1,125,4
      IF (LUDISC.EQ.ISTAT(J)) GO TO 940 
      IF (ISTAT(J).EQ.0) GO TO 932
  930 CONTINUE
C 
C     CARTRIDGE IS NOT MOUNTED
C 
  932 WRITE(LULIST,9321) (PNAME(J),J=1,3),LUDISC
 9321 FORMAT(/,2X,3A2,"- LU#",I3,": CARTRIDGE NOT MOUNTED."/
     1"          MOUNT CARTRIDGE AND RERUN TEST.")
C 
C     WRITE ABORT MESSAGE 
C 
  850 CONTINUE
      WRITE(LULIST,8501) (PNAME(J),J=1,3),LUDISC
 8501 FORMAT(/,2X,3A2,"- LU#",I3,":  DISC TEST ABORTED!"/)
      GO TO 9999
C 
C     START DISC TEST.  ALL OPERATIONAL CHECKS HAVE BEEN MADE 
C 
  940 CONTINUE
      WRITE(LULIST,9501) (PNAME(J),J=1,3),LUDISC
 9501 FORMAT(/,2X,3A2,"- LU#",I3,":  DISC TEST RUNNING")
C     TRY CREATING THE TEST FILE TXM0X ON THE DISC.  IF AN ERROR
C     IS RETURNED THEN THE FILE PROBABLY ALREADY EXISTS.  TEST
C     ERROR CODE.  IF NOT AN ERROR FOR FILE PREVIOUSLY DEFINED, 
C     THEN PRINT ERROR MESSAGE. 
C 
C     INITIALIZE FLAG FOR FILE NOT OPENED YET.
      OFLAG = 0 
      CALL CREAT(IDCB,IERR,NAME,ISIZE,ITYPE,0,LU) 
C     CREATE OPENS FILE FOR EXCLUSIVE ACCESS. 
C     IERR > 0 NO ERROR.  EQUALS SIZE OF FILE ALLOCATED.
      IF (IERR.NE.-6) GO TO 950 
C     ERROR = -6.  CARTRIDGE NOT FOUND OR NO ROOM.
C         PROBABLE CAUSE IS CARTRIDGE NO MOUNTED OR CARTRIDGE FULL. 
      WRITE(LULIST,5005) (PNAME(J),J=1,3),LUDISC
 5005 FORMAT(/,2X,3A2,"- LU#",I3,": NO ROOM ON DISC FOR TEST FILE.")
      NERROR = NERROR + 1 
      GO TO 8000
  950 CONTINUE
      IF (IERR.GT.0) GO TO 1000 
      IF (IERR.EQ.-2) GO TO 5060
      IF (IERR.NE.-2) GO TO 5000
C     IERR = -2 FOR FILE ALREADY EXISTS.  OPEN THE FILE FOR 
C     EXCLUSIVE ACCESS. 
      CALL OPEN(IDCB,IERR,NAME,0,0,LU)
      IF (IERR.LT.0) GO TO 5010 
C     VERIFY FILE TYPE = 1
      IF (IERR.NE.1) GO TO 5020 
C     THIS IS THE CORRECT TEST FILE.  OPEN CALLS AUTOMATICALLY
C     REWIND THE FILE.  WRITE, READ, AND VERIFY THREE RECORDS 
C     (384 WORDS) 
 1000 CONTINUE
C     SET OPEN FLAG FOR FILE OPENED.
      OFLAG = 1 
      CALL WRITF(IDCB,IERR,IBUF,384,1)
      IF (IERR.LT.0) GO TO 5050 
      DO 1500 J=1,3 
      CALL READF(IDCB,IERR,TBUF,128,NWORDS,J) 
      IF (IERR.NE.0) GO TO 5030 
      DO 1200 L=1,128 
      IF (TBUF(L).EQ.IBUF(L,J)) GO TO 1200
C     DATA VERIFICATION ERROR 
      WRITE(LULIST,5135) (PNAME(K),K=1,3),LUDISC,(NAME(K),K=1,3)
 5135 FORMAT(/,2X,3A2,"- LU#",I2,": READ/WRITE DATA DOES NOT VERIFY"
     1" ON FILE ",3A2)
      IF (NERROR.GE.6) GO TO 8000 
 1200 CONTINUE
 1500 CONTINUE
C 
C     DATA VERIFIES.  CLOSE FILE. 
      CALL CLOSE(IDCB,IERR) 
      IF (IERR.LT.0) GO TO 5040 
C     TEST COMPLETED SUCCESSFULLY.  WRITE MESSAGE TO LISTING
      CALL PURGE(IDCB,IERR,NAME,0,LU) 
      IF (IERR.LT.0) GO TO 5070 
      GO TO 8000
C 
C     ERROR PATHS 
C 
 5000 WRITE(LULIST,5100) (PNAME(J),J=1,3),LUDISC,(NAME(J),J=1,3), 
     1 IERR 
 5100 FORMAT(/,2X,3A2,"- LU#",I3,": ERROR CREATING FILE ",3A2,". "
     1 "ERROR=",I4) 
      GO TO 5500
 5010 WRITE(LULIST,5110) (PNAME(J),J=1,3), LUDISC,(NAME(J),J=1,3),
     1 IERR 
 5110 FORMAT(/,2X,3A2,"- LU#",I3,": ERROR OPENING FILE ",3A2,". " 
     1 "ERROR=",I4) 
      GO TO 5500
 5020 WRITE(LULIST,5120) (PNAME(J),J=1,3),LUDISC,(NAME(J),J=1,3), 
     1 IERR 
 5120 FORMAT(/,2X,3A2,"- LU#",I3,": CREATED FILE ",3A2," IS WRONG"
     1"TYPE. TYPE=",I4) 
      GO TO 5500
 5030 WRITE(LULIST,5130)  (PNAME(J),J=1,3),LUDISC,(NAME(J),J=1,3),
     1 IERR 
 5130 FORMAT(/,2X,3A2,"- LU#",I3,": ERROR READING FILE ",3A2,". " 
     1 "ERROR=",I4) 
      GO TO 5500
 5040 WRITE(LULIST,5140) (PNAME(J),J=1,3),LUDISC,(NAME(J),J=1,3), 
     1 IERR 
 5140 FORMAT(/,2X,3A2,"- LU#",I3,": ERROR CLOSING FILE ",3A2,". " 
     1 "ERROR=",I4) 
      GO TO 5500
 5050 WRITE(LULIST,5150) (PNAME(J),J=1,3),LUDISC,(NAME(J),J=1,3), 
     1 IERR 
 5150 FORMAT(/,2X,3A2,"- LU#",I3,": ERROR WRITING FILE ",3A2,". " 
     1 "ERROR=",I4) 
      GO TO 5500
 5060 WRITE(LULIST,5160) (PNAME(J),J=1,3),LUDISC,(NAME(J),J=1,3), 
     1 IERR 
 5160 FORMAT(/,2X,3A2,"- LU#",I3,": DUPLICATE FILE ",3A2,". " 
     1 "ERROR=",I4) 
      GO TO 5500
 5070 WRITE(LULIST,5170) (PNAME(J),J=1,3),LUDISC,(NAME(J),J=1,3), 
     1 IERR 
 5170 FORMAT(/,2X,3A2,"- LU#",I3,": ERROR PURGING FILE ",3A2,". " 
     1 "ERROR=",I4) 
C 
C     GET ERROR STATUS FROM DEVICE
C 
 5500 CONTINUE
      NERROR = NERROR + 1 
C     GET DEVICE STATUS (I/O STATUS CALL) 
      CALL EXEC(CODE13,LUDISC,EQT5,EQT4,EQTST)
C     CHECK LOGICAL UNIT DECLARED DOWN
      IF (EQTST.LT.0) GO TO 5750
C     PRINT ERROR STATUS DEPENDING UPON DISC TYPE.
      EQT5 = EQT5/2 
      DO 5575  K=7,1,-1 
      IF (IAND(EQT5,1).EQ.0) GO TO 5560 
      IF (NDTYPE-032B) 5510,5520,5560 
C     DISC EQUIPMENT TYPE = 031B
 5510 WRITE(LULIST,5555) (PNAME(J),J=1,3),LUDISC, 
     1 (M(M31STR(K)+J-1), J=1,M31LEN(K))
      GO TO 5560
C     DISC EQUIPMENT TYPE = 032B
 5520 WRITE(LULIST,5555) (PNAME(J),J=1,3),LUDISC, 
     1 (M(M32STR(K)+J-1), J=1,M32LEN(K))
 5555 FORMAT(/,2X,3A2,"- LU#",I3,": ",20A2) 
C     DISC EQUIPMENT TYPE = 033B
 5560 EQT5 = EQT5/2 
 5575 CONTINUE
C     CLEANUP FOR ERROR CONDITIONS.  CLOSE AND PURGE FILE.
      IF (OFLAG.EQ.0) GO TO 5600
      CALL CLOSE(IDCB,IERR) 
      CALL PURGE(IDCB,IERR,NAME,0,LU) 
 5600 GO TO 8000
 5750 WRITE(LULIST,5102) (PNAME(J),J=1,3),LUDISC
 5102 FORMAT(/,2X,3A2,"- LU#",I3,", EQT OR LU FOR TEST DISC"
     1" IS DOWN."/"          UP EQT AND RERUN TEST.") 
C 
C     END OF MAIN PROGRAM LOOP
C 
 8000 CONTINUE
      WRITE(LULIST,9810) (PNAME(J),J=1,3),LUDISC,NERROR 
 9810 FORMAT(/,2X,3A2,"- LU#",I3,":  DISC TEST FINISHED   ",I2, 
     1" ERRORS"/) 
C 
C     TERMINATE PROGRAM 
 9999 CONTINUE
      END 
      END$
                                                                                                                                                                                                  