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," 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