FTN4,L,Q
C 
C 
C      DATE:  SEPTEMBER 10,1979 
C      NAME:  TXDSC 
C      SOURCE: 02145-18013
C      RELOC:  02145-16009
C      PGMR: D.E.B. 
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 PROGRAM LANGUAGE 
C  WITHOUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.
C******************************************************************** 
C 
      SUBROUTINE TXDSC(LU,ERR,VALUS), 02145-1X013  REV.2001  800206 
C DISC TEST SUBROUTINE. 
C OPENS A TYPE 8 FILE NAMED *TEST* ON LU, WRITES A RECORD TO IT,
C READS THE RECORD BACK, VERIFIES IT AND PURGES THE FILE
C LU MUST BE A DISC  LU 
C 
C ERR RETURNS WITH AN ERROR NUMBER INDICATING THE TYPE OF FAILURE 
C ERR=0 NO ERROR
C ERR=1 CREATE ERROR
C ERR=2 WRITE ERROR 
C ERR=3 READ ERROR
C ERR > 10 PURGE ERROR AND ERR-10 ERROR.  IE IF ERROR = 12 THEN 
C THERE WAS A PURGE ERROR (10) AND A WRITE ERROR (2) [10+2=12]
C 
C RESULTS ARE LOGGED IN THE BUFFER VALUS IN THE FORMAT OF THE FTEST LOG 
C BUFFER
C 
C  THIS SUBROUTINE IS CALLED BY FTEST, THE L-SERIES FUNCTIONAL
C  TEST PROGRAM 
      IMPLICIT INTEGER(A-Z) 
      INTEGER BUFR(10)
      INTEGER IDCB(144) 
      INTEGER VALUS(64,8) 
      INTEGER BUFW(10)
      INTEGER BR(40)
      INTEGER DSIZE(2)
      INTEGER NAME(3) 
      INTEGER STARS(12),LUNUM(3)
      DATA BUFW/2HAB,2HCD,2HEF,2HGH,2HIJ,2HKL,2HMN,2HOP,2HQR,2HST/
C 
C SET THE RESULT TO FAIL, CHANGE IF ALL TESTS ARE PASSED
C 
      VALUS(LU,2)=5 
      ERR=0 
      DSIZE(1)=0
      DSIZE(2)=8
C 
C CREATE A SCRATCH FILE ON SPECIFIED LU, LOG ERRORS 
C 
      CALL CRETS(IDCB,IERR,NUM,NAME,DSIZE,8,0,0-LU) 
      IF(IERR.EQ.-32) 30,40 
30    ERR=7 
      VALUS(LU,2)=9 
      GOTO 600
C 
40    IF(IERR.LT.0) 50,100
50    ERR=1 
      GOTO 600
C 
C STORE THE CURRENT FILE LOCATION THEN WRITE TEST BUFFER TO FILE, LOG ERRORS
C 
100   CALL LOCF(IDCB,IERR,IREC,ERB,IOFF)
      CALL WRITF(IDCB,IERR,BUFW,10) 
      IF(IERR.LT.0) 150,200 
150   ERR=2 
      GOTO 500
C 
C RESTORE FILE LOCATION AND READ BUFFER FROM FILE, LOG ERRORS 
C 
200   CALL APOSN(IDCB,IERR,IREC,ERB,IOFF) 
      CALL READF(IDCB,IERR,BUFR,10) 
      IF(IERR.LT.0) 250,300 
250   ERR=3 
      GOTO 500
C 
C VERIFY BUFFER WORD BY WORD, LOG ERRORS
C 
300   DO 320 I=1,10 
      IF(BUFR(I).EQ.BUFW(I)) 320,330
320   CONTINUE
      GOTO 500
C 
330   ERR=3 
  
C 
C PURGE FILE, LOG ERRORS
C 
500   CALL PURGE(IDCB,IERR,NAME,0,0-LU) 
      IF(IERR.LT.0) 550,600 
550   ERR=ERR+10
C 
C IF NO ERRORS THEN LOG A NO ERROR CONDITION
C 
600   IF(ERR.EQ.0) 700,900
700   VALUS(LU,2)=3 
C 
900   RETURN
      END