FTN4,L
      SUBROUTINE WRTRK(LU,LTRK,ISUBC,IXBUF,LOG,IBT),92067-1X546 REV.2001
     X 791101 
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 PROGRAMMING LANGUAGE     *
C*  WITHOUT THE PRIOR WRITTEN CONSENT OF THE HEWLETT-PACKARD     *
C*  COMPANY.                                                     *
C*                                                               *
C*****************************************************************
C 
C     NAME:  WRTRK
C   SOURCE:  92067-18546  
C    RELOC:  PART OF 92067-12003
C     PGMR:  J.S.W
C 
      DIMENSION ISUBC(1),IXBUF(1),ITEMP(6),LINE(60) 
C 
      DATA IPROCT/0/
C 
C 
C 
C 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C 
C  WRITE TRACK- ON-LINE RESTORE,COPY
C 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 
C 
C 
      IRETRY=0
      DO 1 I=1,30 
1     LINE(I)=2H
C 
C 
C  CONVERT LOGICAL TO PHYSICAL TRK ADDRESS
C    CHECK STATUS 
C 
       LSEC=0 
      CALL MXGTA(LU,IDVID,LTRK,LSEC,ICYL,IHD,ISEC,ISUBC)
100   CALL XSTAT(LU,IDVID,ISTAT1,ISTAT2,IER)
      IF(IER.EQ.4) GO TO 950
      IF(ISTAT2.LT.0) GO TO 950 
C 
C LOCK EQT
C 
      IOPT=1
      CALL EQTRQ(IOPT,LU) 
      CALL ABREG(IA,IB) 
      IF(IA.EQ.0) GO TO 150 
      IF(IA.EQ.-1) GO TO 980
      CALL EXEC(2,LOG,15HEQT LOCK FAILED,-15) 
C 
C 
C 
C FILE MASK, SEEK, WRITE
C 
150   MSK=4 
D7000 FORMAT("WRITING CYL,HD,SEC,L=",4I8) 
      CALL XFMSK(LU,IDVID,MSK,IER)
      CALL XSEEK(LU,IDVID,ICYL,IHD,ISEC,ISTAT1,ISTAT2,IER)
      IF(IER.EQ.2) GO TO 100
      IF(IER.EQ.4) GO TO 950
      IF(ISTAT2.LT.0) GO TO 900 
      ISIZE=ISUBC(1)*64 
C 
      CALL XDWRT(LU,IDVID,IXBUF,ISIZE,ISTAT1,ISTAT2,IER)
      IF(IER.EQ.2) GO TO 100
      IF(IER.EQ.4) GO TO 950
C 
C 
C CHECK STATUS: IF S1=26B WRITING ON PROTECTED TRACK
C               IF P BIT  WRITING ON PROTECTED TRACK
C               IF S1 NOT =0 BAD TRACK
      IS1=IAND(ISTAT1,17400B)/256 
      IF(IAND(ISTAT1,20000B).NEQ.0) GO TO 850 
      IF(IS1.EQ.26B) GO TO 800
      IF(IAND(ISTAT1,40000B).NEQ.0) GO TO 800 
      IF(IS1.NEQ.0) GO TO 850 
C NOW CHECK STATUS
C 
400   IF(IAND(IXBUF(16),40000B).EQ.0) GO TO 500 
      CALL EXEC(2,LOG,40H FOLLOWING TRACK NOT SAVED SUCCESSFULLY:,-40)
      IUNIT=IAND(IDVID,77B) 
      CALL EXEC(2,LOG,31H TRACK# CYL  HEAD  UNIT/ADDRESS,-31) 
      CALL XDCAS(LINE(1),3,LTRK)
      CALL XDCAS(LINE( 5),2,ICYL) 
      CALL XDCAS(LINE( 7),2,IHD)
      CALL XDCAS(LINE(10),2,IUNIT)
      CALL EXEC(2,LOG+200B,LINE,-22)
500   CALL XEND(LU,IDVID) 
C 
C UNLOCK EQT
C 
      IOPT=0
      CALL EQTRQ(IOPT,LU) 
      RETURN
C 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C 
C ERROR HANDLING
C 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C 
800   IF (IPROCT.EQ.1) GO TO 400
      CALL EXEC(2,LOG,28H WRITING ON PROTECTED TRACKS,-28)
      IPROCT=1
      GO TO 400 
900   IF(IRETRY.EQ.0)CALL EXEC(2,LOG,10HSEEK ERROR,-10) 
      IRETRY=IRETRY+1 
      IF(IRETRY.GT.10) RETURN 
      GO TO 100 
950   CALL EXEC(2,LOG,15HDRIVE NOT READY,-15) 
      CALL EXEC(2,LOG,48HREADY DISC AND ENTER "GO,<PROG-NAM>" TO CONTINUE,
     X ,-48)
      PAUSE 
      GO TO 100 
C 
C 
850   DO 880 I=1,60 
880   LINE(I)=2H
C 
      IUNIT=IAND(IDVID,77B) 
      CALL XDCAS(LINE( 9),3,LTRK) 
      CALL XDCAS(LINE(13),2,ICYL) 
      CALL XDCAS(LINE(15),2,IHD ) 
      CALL XDCAS(LINE(18),2,IUNIT)
      CALL EXEC(2,LOG,17H DEST. SUBCHANNEL,-17) 
      CALL EXEC(2,LOG,
     X        47H BAD TRACK AT:  TRACK#  CYL  HEAD  UNIT/ADDRESS,-47) 
      CALL EXEC(2,LOG,LINE,-60) 
C 
      IBT=1 
      GO TO 400 
C 
C 
980   CALL EXEC(2,LOG,19HEQT LOCK TABLE FULL,-19) 
      GO TO 500 
      END 
                