FTN,L,C 
C 
      SUBROUTINE REDIR(ISCTR,IDUM,FLAG,IERR)
     & ,92067-1X504 REV.2026 800522 
C * 
C * 
C ******************************************************************* 
C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED.
C * NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR
C * TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN
C * CONSENT OF HEWLETT-PACKARD COMPANY. 
C ******************************************************************* 
C * 
C * 
C *     NAME :  REDIR 
C *     SOURCE: 92067-18504 
C *     RELOC:  92067-16504 
C *     PGMR :  R.D.
C * 
C * 
C * 
C ******************************************************************* 
C * 
C * 
C * 
C * 
C 
C  THIS SUBROUTINE IS CALLED BY READT TO FIX AND RESTORE DIRECTORY
C  ENTRIES WHEN THE SEC/TRK VALUE OF THE MAG TAPE IS NOT THE SAME 
C  AS THAT OF THE DISC. IT CLEARS ALL OPEN FLAGS, AND RESETS
C  THE STARTING SECTOR AND TRACK ADDRESSES FOR EACH DIRECTORY ENTRY.
C  (THE FIRST FILE, THEN, WILL BEGIN AT TRACK 0, SECTOR 0). 
C 
C  THE DIRECTORY ENTRIES ARE WRITTEN USING SECTOR SKIPPING. BECAUSE 
C  OF THIS, THERE IS A TWO SECTOR BLOCK WITH DIRECTORY ENTRIES,THE NEXT 
C  12 SECTORS ARE SKIPPED, 2 SECTORS WITH DIRECTORY ENTRIES,..., ETC. 
C  AS A RESULT, AS EACH BLOCK OF ENTRIES ARE RESET, THEY ARE
C  IMMEDIATELY RESTORED TO THE DISC.
C 
C  THE PARAMETERS ARE:
C 
C     ISCTR - SEC/TRK VALUE OF THE CARTRIDGE ON THE MAG TAPE
C     IDUM  - SEC/TRK VALUE OF THE DISC CARTRIDGE 
C     FLAG  - CATCHES FMGR ERROR FOR USE IN CALLS TO SUB. VVALD 
C     IERR  - ERROR CODE  (AS GAINED FROM SUBROUTINE VVALD) 
C             = 0  NO PROBLEMS   (NORMAL TERMINATION) 
C             = 1  END OF FILE ENCOUNTERED
C             =-1  ABORT MAIN PROGRAM (READT) 
C             =-2  PARITY ERROR 
C 
C 
C 
C  LOCAL VARIABLES USED:
C 
C     ILNTH,JLNTH - WORD/TRK OF MAG TAPE AND DISC 
C     TOTL  - TOTAL LENGTH FROM ALL DIRECTORY ENTRIES (IN SECTORS)
C     SEC   - SECTOR ADDRESS OF BLOCK TO BE WRITTEN TO DISC 
C     DIRTK - CURRENT DIRECTORY TRACK COUNT 
C     SECTR - # SECTORS WRITTEN TO THE DISC 
C     OFSET - FIRST WORD OF JBUF TO BE WRITTEN NEXT 
C     ENTRY - # DIRECTORY ENTRIES FOUND (8 IN EACH BLOCK) 
C     SKIP  - # WORDS TO SKIP FOR SECTOR SKIPPING THRU DIRECTORY TRACK
C     FIRST - =0, FIRST DIRECTORY TRACK FROM THE MAG TAPE 
C 
C 
C  AREAS OF CONCERN IN THE DIRECTORY ENTRIES ARE: 
C 
C     JBUF(1) - STATUS                        A.K.A.  JBUF(N-8) 
C               = 0  LAST DIRECTORY ENTRY 
C     JBUF(5) - STARTING TRACK                A.K.A.  JBUF(N-4) 
C     JBUF(6) - (RIGHT BYTE) STARTING SEC.    A.K.A.  JBUF(N-3) 
C 
C 
C                   *** NOTE ***
C 
C  IN CASES WHERE THE RATIO OF INTEGER VARIABLES ARE COMPUTED, EACH IS
C  FLOATED BEFORE THE OPERATION. THIS IS TO AVOID THE TRUNCATION AFTER
C  EACH INTEGER OPERATION WHICH NORMALLY OCCURS.
C 
C 
      IMPLICIT INTEGER(A-Z) 
      DOUBLE PRECISION TOTL(2)
      DIMENSION JBUF(8192)
      COMMON/COMRD/ ILU,ITAPE,NDIR,IDISC,MTLU,TSIZE,IBUF(8193)
      EQUIVALENCE (JBUF,IBUF(2))
      FIRST=0 
      SEC=0 
      DIRTK=1 
      SKIP=12*64
      ENTRY=1 
      SECTR=0 
      OFSET=1 
      N=9 
      ILNTH=ISCTR*64
      JLNTH=IDUM*64 
C 
      MNDIR=JBUF(9) 
      TEMP=0
      CNTR=0
C 
C 
C  GET READY TO SET ENTRIES. (4 DIRECTORY ENTRIES/SECTOR) 
C 
10    DO 46 I=1,ISCTR*4 
C 
C  LAST DIRECTORY ENTRY?
C 
C 
C 
C  IF THIS IS THE FIRST TIME THROUGH; SKIP. 
C 
       IF(FIRST.NE.0) GOTO 450
       IF((DIRTK.EQ.1).AND.(N.EQ.9)) GOTO 455 
C 
C  IF IT'S THE FIRST DIRECTORY ENTRY, GO SET TRACK AND SECTOR ADDRESSES 
C  TO ZERO. 
C 
       IF((DIRTK.EQ.1).AND.(N.EQ.25)) GOTO 445
       GOTO 450 
C 
C  FIRST DIRECTORY ENTRY. THIS FILE WILL START AT 0,0.
C 
445    TA=JBUF(5) 
       SA=0 
       TOTL=FLOAT(JBUF(5))*FLOAT(IDUM)
C 
C 
C     INTIALIZE THE PREVIOUS FILE'S TRACK AND SECTOR POINTER
C 
      OLDTA=JBUF(5) 
      OLDSA=0 
      OLDSZ=0 
C 
C  TIME TO CLEAR ALL OPEN FLAGS.
C 
450    DO 45 J=1,7
         JBUF(N+J)=0
45     CONTINUE 
C 
C     IF FILE DIRECTORY ENTRY IS TYPE 0 FILE
C     THEN DON'T COMPUTE TRACK/SECTOR.
C 
      IF(JBUF(N-5).EQ.0)GO TO 455 
C 
C     GRAB CURRENT FILE TRACK AND SECTOR ADRRESSES BEFORE UPDATE
C 
      TA1=JBUF(N-4) 
      SA1=IAND(JBUF(N-3),000377B) 
      SZ1=JBUF(N-2) 
      IF(SZ1.LT.0)SZ1=IABS(SZ1)*128 
C 
C 
C     NOW COMPUTE DIFFERENCE BETWEEN OLD AND CURRENT TRACK AND
C     SECTOR LOCATION 
C 
      DIFTA=TA1-OLDTA 
      DIFSA=SA1-OLDSA 
      SIZE=FLOAT(DIFTA)*FLOAT(ISCTR)+DIFSA
C 
      IF(SIZE.LE.OLDSZ)GO TO 452
      TOTL=(TOTL)-FLOAT(ISEC)+FLOAT(SIZE) 
C 
C     REFIGURE TRACK AND SECTOR BASED ON NEW SIZE 
C 
      TA=(TOTL)/FLOAT(IDUM) 
      SA=(TOTL)-(FLOAT(TA)*FLOAT(IDUM)) 
C 
C  SET CURRENT DIRECTORY ENTRIES. 
C 
452   JBUF(N-4)=TA
      JBUF(N-3)=IAND(JBUF(N-3),177400B) 
      JBUF(N-3)=IOR(JBUF(N-3),SA) 
C 
      OLDTA=TA1 
      OLDSA=SA1 
      OLDSZ=SZ1 
C 
C  CALCULATE STARTING SECTOR AND TRACK FOR NEXT FILE. (DON'T NEED TO
C  INCREMENT, ALWAYS START AT SECTOR ZERO). WATCH OUT FOR POSSIBLE
C  NEGATIVE LENGTH OF FILE. 
C 
       ISEC=JBUF(N-2) 
       IF(ISEC.LT.0) ISEC=IABS(ISEC)*128
       TOTL=(TOTL)+FLOAT(ISEC)
       TA=(TOTL)/FLOAT(IDUM)
       SA=(TOTL)-(FLOAT(TA)*FLOAT(IDUM))
C 
C  CHECK NUMBER OF DIRECTORY ENTRIES WHICH HAVE BEEN RESET. MAY 
C  HAVE TO INCREMENT "N" TO GET THE NEXT DIRECTORY ENTRY DUE TO 
C  SECTOR SKIPPING. 
C 
455    ENTRY=ENTRY+1
       IF(ENTRY.LE.8) GOTO 456
C 
C  ALL DONE WITH THIS 2 SECTOR BLOCK OF DIRECTORY ENTRIES RESTORE IT. 
C 
      TEMP=TEMP+1 
C 
       CALL EXEC(2,IDISC+74000B,JBUF(OFSET),128,TSIZE-DIRTK,SEC)
C 
C  MAKE SURE WRITE WAS O.K. 
C 
       CALL ABREG(IA,IB)
       CALL VVALD(IA,IB,-1,128,TSIZE-DIRTK,SEC,0,FLAG,0)
C 
C  UPDATE ALL POINTERS SO CAN GET NEXT SET OF DIRECTORY ENTRIES 
C  IN THE PROPER ORDER. 
C 
       ENTRY=1
       SEC=SEC+14 
       IF(SEC.GE.IDUM) SEC=SEC-IDUM 
       OFSET=OFSET+128+SKIP 
       IF(OFSET.GT.ILNTH) OFSET=OFSET-ILNTH 
       N=N+SKIP 
       IF(N.GT.ILNTH) N=N-ILNTH 
C 
C  CHECK TO SEE IF DISC TRACK FULL. 
C 
       SECTR=SECTR+2
       IF(SECTR.LT.IDUM) GOTO 456 
C 
C  RAN OUT OF DISC TRACK. START A NEW ONE.
C 
       DIRTK=DIRTK+1
       SEC=0
       SECTR=0
C 
C  INCREMENT "N" TO POINT TO NEXT DIRECTORY ENTRY TO BE FOUND ON
C  THE MAG TAPE.
C 
456    N=N+16 
46    CONTINUE
C 
C  IF LOOP ENDS NATURALLY, NEED NEXT DIRECTORY TRACK FROM MAG TAPE. 
C 
      MNDIR=MNDIR+1 
      IF(MNDIR)550,600,600
550   CALL EXEC(1,MTLU,IBUF,ILNTH+1)
      CALL ABREG(IA,IB) 
C 
C  MAKE SURE READ WAS O.K.
C 
      IERR=0
      CALL VVALD(IA,IB,OFSET,128,TSIZE-DIRTK,SEC,ILNTH,FLAG,IERR) 
      IF(IERR.NE.0) GOTO 600
C 
C  RESET NECESSARY POINTERS AND GO AGAIN. 
C 
      OFSET=1 
      N=9 
      FIRST=-1
      GOTO 10 
C 
C  DONE. NOW CLEAR OUT OLD ENTRIES WHICH MAY BE LEFT ON THE DISC. 
C 
600   IF(SECTR.GE.IDUM) GOTO 900
      DO 42 I=1,128 
        JBUF(I)=0 
42    CONTINUE
  
C 
C  WANT TO CLEAR OFF OLD DIRECTORY ENTRIES FROM DISC. 
C 
48      CALL EXEC(2,IDISC+74000B,JBUF,128,TSIZE-DIRTK,SEC)
C 
C  MAKE SURE WRITE WAS O.K. 
C 
        CALL ABREG(IA,IB) 
        CALL VVALD(IA,IB,-1,128,TSIZE-DIRTK,SEC,0,FLAG,0) 
  
        SEC=SEC+14
        IF(SEC.GE.IDUM) SEC=SEC-IDUM
        SECTR=SECTR+2 
        IF(SECTR.LT.IDUM) GOTO 48 
  
C 
C  DID THE NUMBER OF DIRECTORY TRACKS CHANGE? IF YES, UPDATE INFO ALREADY 
C  RESTORED TO THE DISC.
C 
900   IF(DIRTK.EQ.NDIR) RETURN
      CALL EXEC(1,IDISC,JBUF,128,TSIZE-1,0) 
C 
      TEMP=TEMP*2 
C 
910   CNTR=CNTR+1 
C 
C     TEMP HAS TOTAL NUMBER OF SECTORS WRITTEN TO DISC DIRECTORY
C 
      TEMP=TEMP-IDUM
      IF(TEMP.GT.0)GO TO 910
      JBUF(9)=-CNTR 
      JBUF(8)=TSIZE-CNTR
C 
      CALL EXEC (2,IDISC+74000B,JBUF,128,TSIZE-1,0) 
C 
C  MAKE SURE WRITE WAS O.K. 
C 
      CALL ABREG(IA,IB) 
      CALL VVALD(IA,IB,-1,128,TSIZE-1,0,0,FLAG,0) 
      RETURN
      END 
      END$