$CONTROL MAP,CODE,USLINIT                                               00010000
<<LABSEG - MODULE 86>>                                                  00012000
<< HP32002C MPE SOURCE C.00.00 >>                                       00014000
$COPYRIGHT     "(C) COPYRIGHT HEWLETT-PACKARD CO. 1980. ",            & 00016000
$     "THIS PROGRAM MAY BE USED WITH ONE COMPUTER SYSTEM AT A ",      & 00018000
$     "TIME AND SHALL NOT OTHERWISE BE RECORDED, TRANSMITTED OR ",    & 00020000
$     "STORED IN A RETRIEVAL SYSTEM.  COPYING OR OTHER REPRODUCTION ",& 00022000
$     "OF THIS PROGRAM EXCEPT FOR ARCHIVAL PURPOSES IS PROHIBITED ",  & 00024000
$     "WITHOUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.",& 00026000
$     "LABSEG SEPTEMBER 15, 1982."                                      00028000
$CONTROL USLINIT,CODE,MAP                                               00032000
<< LABSEG - module 86 >>                                       <<02547>>00034000
<< HP32002B MPE Source C.00.00 >>                                       00036000
<<" (C) Copyright Hewlett-Packard Company, 1980.                        00038000
  All rights reserved.  No part of this program may                     00040000
  be photocopied, reproduced, or translated to                          00042000
  another program language without the prior written                    00044000
  consent of Hewlett-Packard Company. "   >>                            00046000
                                                                        00048000
$CONTROL MAIN=LABSEG                                                    00050000
$CONTROL SEGMENT=LABSEG                                                 00052000
                                                                        00054000
BEGIN                                                                   00056000
                                                               <<03581>>00058000
COMMENT                                                        <<03581>>00060000
                                                               <<03581>>00062000
           Fix History since D-MIT                             <<03581>>00064000
                                                               <<03581>>00066000
Fix #      Description of fix                                  <<03581>>00068000
                                                               <<03581>>00070000
                                                               <<03581>>00072000
<<02547>>  New Source                                          <<03581>>00074000
                                                               <<03581>>00076000
<<02563>>  Support for variable density tape drives.           <<03581>>00078000
           Improve error handling for AVR of tapes.            <<03581>>00080000
                                                               <<03581>>00082000
<<02575>>  Parameter of DADDR of CLEANLDEV is now passed       <<03581>>00084000
           by value.                                           <<03581>>00086000
                                                               <<03581>>00088000
<<02616>>  Change to PVOLID.                                   <<03581>>00090000
                                                               <<03581>>00092000
<<02621>>  1) Ensure UVL labels skipped when 1st file on       <<03581>>00094000
              reel is FOPEN'd                                  <<03581>>00096000
           2) Correct SF 86's due to :                         <<03581>>00098000
              a) a REPLY <pin>,0 to a reelswitch request       <<03581>>00100000
                 during a labeled tape RESTORE.                <<03581>>00102000
              b) mounting 2nd or later reel as 1st reel        <<03581>>00104000
                 during a labeled tape RESTORE.                <<03581>>00106000
                                                               <<03581>>00108000
<<02622>>  1) Fix problems with reelswitching when STORE/      <<03581>>00110000
              RESTORE to/from labeled tape.                    <<03581>>00112000
           2) Disallow more than one file opened on a          <<03581>>00114000
              labeled tape concurrently.                       <<03581>>00116000
                                                               <<03581>>00118000
<<02648>>  Correct GOODREEL, add delays for DEVREC, Allow      <<03581>>00120000
           any printing chars in vol label.                    <<03581>>00122000
                                                               <<03581>>00124000
<<02622>>  Add error reporting to ATTACHIO calls.              <<03581>>00126000
                                                               <<03581>>00128000
<<02673>>  Correct system log record, put I/O error messages   <<03581>>00130000
           on console, please return of CCE to mean tape is    <<03581>>00132000
           mounted on a tape drive in PVOLID, don't wait       <<03581>>00134000
           on a DCLOSE in FREEDEVICE for CLEANTAPE.            <<03581>>00136000
                                                               <<03581>>00138000
<<02689>>  1) Allow writes and WTM to occur after TM.          <<03581>>00140000
           2) Clean up after =REPLY <pin>,0 to REELSWITCH      <<03581>>00142000
              request in a more timely manner.                 <<03581>>00144000
                                                               <<03581>>00146000
<<02690>>  Permit override of HDR2 label file characteristics. <<03581>>00148000
           Correct cleanup on process termination.             <<03581>>00150000
           Correct some problems with tape positioning on      <<03581>>00152000
           REELSWITCH.                                         <<03581>>00154000
                                                               <<03581>>00156000
<<02703>>  Allow STORE/RESTORE to return file system error     <<03581>>00158000
           numbers in the event of an error in advancing from  <<03581>>00160000
           one labeled tape to another.                        <<03581>>00162000
                                                               <<03581>>00164000
<<02722>>  1) Make AVR of tapes more forgiving when I/O errors <<03581>>00166000
              occur.                                           <<03581>>00168000
           2) Prevent RECOGNIZE and AVREC from both attempting <<03581>>00170000
              AVR on the same tape (SR#22254).                 <<03581>>00172000
           3) Prevent I/O's from occuring while holding the    <<03581>>00174000
              TLTSIR (SR#22907).                               <<03581>>00176000
           4) Prevent I/O's during FCLOSE of labeled tape after<<03581>>00178000
              a =REPLY <pin>,0.                                <<03581>>00180000
                                                               <<03581>>00182000
<<*cub*>>  1) Support of Labeled Serial Disc for CUB.          <<03581>>00184000
           2) Addition of Tape Trouble codes.                  <<03581>>00186000
           3) Addition of Fix Log.                             <<03581>>00188000
                                                               <<03618>>00190000
(Fix number col. 64/72)                                        <<03618>>00192000
                                                               <<03618>>00194000
          Allowing reelswitch on labeled serial disc.          <<03618>>00196000
                                                               <<03618>>00198000
          CLEANTAPE will deallocate the XDS for SDISC on       <<03634>>00200000
          a volume set that is not a tape.                     <<03634>>00202000
                                                               <<03634>>00204000
          Return an illegal value to a caller of FFILEINFO     <<04612>>00206000
          items (26/33,45)  when a non labeled tape file.      <<04612>>00208000
                                                               <<04612>>00210000
   A problem with the ownership bits for reelswitching         <<04647>>00212000
   labeled serial disc.                                        <<04647>>00214000
                                                               <<04647>>00216000
   Fix a problem that the TLT will not be updated before the   <<04698>>00218000
     ownership bits in the LPDT are set, thus allowing AVR     <<04698>>00220000
     before REELSWITCH has set up everything.                  <<04698>>00222000
                                                               <<04698>>00224000
          Allow use to write over a label if we have           <<04819>>00226000
          operator permission and we have write access.        <<04819>>00228000
                                                               <<04819>>00230000
          When a reelswitch is occuring and the mounted tape   <<04739>>00232000
          is already labeled and not expired and the operator  <<04739>>00234000
          replys N to the OK to write on unexpired volume,     <<04739>>00236000
          then we will set up the tape drive for another tape  <<04739>>00238000
          instead of returning a FWRITE error.                 <<04739>>00240000
                                                               <<04739>>00242000
                                                               <<04740>>00244000
          Update the ANSI standard version from 1 to 3         <<04740>>00246000
                                                               <<04740>>00248000
          one tape mark will be written (for LINUS).           <<04736>>00250000
                                                               <<04736>>00252000
     Fix a problem with the reelswitch reel number on the      <<04872>>00254000
   Fix problem with fixno 4612. TGETINFO also needs to return  <<04873>>00256000
   condition codes for when it's called from OPLOW (for the    <<04873>>00258000
   measurement interface).                                     <<04873>>00260000
                                                               <<04873>>00262000
     third reel on.                                            <<04872>>00264000
                                                               <<04872>>00266000
           Fix up the catalog                                           00268000
                                                                        00270000
                                                               <<04647>>00272000
                                                               <<04647>>00274000
                                                               <<04647>>00276000
;                                                              <<04647>>00278000
<< New source, 1981 Jan 2. >>                                           00280000
                                                                        00282000
   << Definitions for Tape Label Table Logical Device Blocks >>         00284000
                                                                        00286000
EQUATE LTESIZE =26;                                                     00288000
DEFINE                                                                  00290000
 LCB'FLAGS  =LTBUF#,            << state bits >>                        00292000
   LCB'LABTYP =LCB'FLAGS.(4:2)#,  << label type >>                      00294000
   LCB'TAPE   =LCB'FLAGS.(6:1)#,   << Tape device >>           <<03581>>00296000
   LCB'LOCKFLG=LCB'FLAGS.(7:1)#,  << lockword flag 1:53,1 >>            00298000
   LCB'B5000  =LCB'FLAGS.(8:1)#,  << Burroughs tape >>                  00300000
   LCB'HP     =LCB'FLAGS.(9:1)#,  << HP tape >>                         00302000
 LCB'LDEV      =LTBUF(1)#,                                              00304000
 LCB'VCB       =LTBUF(2)#,                                              00306000
 LCB'FLAG2     =LTBUF(3)#,                                              00308000
   LCB'REEL   =LCB'FLAG2#,        << reel nr.  1:27,4 >>                00310000
 LCB'FSEQ      =LTBUF(4)#,      << file seq. nr.  1:31,4 >>             00312000
 LCB'CDATE     =LTBUF(5)#,      << creation date 1:41,6 >>              00314000
 LCB'EXDATE    =LTBUF(6)#,      << expiration date 1:47,6 >>            00316000
 LCB'FNAME     =LTBUFB(14)#,    << file name  1:4,17 >>                 00318000
 LCB'VSETID    =LTBUFB(40)#,    << volume set ID 1:21,6 >>              00320000
 LCB'VOLID     =LTBUFB(46)#;    << volume ID 0:4,6 >>                   00322000
                                                                        00324000
DEFINE BUILDLCB =                                                       00326000
   BYTE ARRAY LTBUFB(*) = LTBUF#;                                       00328000
                                                                        00330000
   << Definitions for Tape Label Table Volume Control Blocks >>         00332000
                                                                        00334000
EQUATE VTESIZE =26;                                                     00336000
DEFINE                                                                  00338000
 VCB'FLAGS  =VTBUF#,            << state bits >>                        00340000
   VCB'ASCII  =VCB'FLAGS.(0:1)#,  << ASCII F-option >>                  00342000
   VCB'FLUSH  =VCB'FLAGS.(1:1)#,  << =REPLY 0 done >>                   00344000
   VCB'DR'WAIT=VCB'FLAGS.(2:1)#,  << DEVREC wait   >>          <<03618>>00346000
   VCB'POSN   =VCB'FLAGS.(3:4)#,  << tape position >>                   00348000
   VCB'WRITE  =VCB'FLAGS.(7:1)#,  << write access >>                    00350000
   VCB'SEQTYP =VCB'FLAGS.(8:2)#,  << sequencing type >>                 00352000
   VCB'LABTYP =VCB'FLAGS.(10:2)#, << label type >>                      00354000
   VCB'LNKWAIT=VCB'FLAGS.(12:1)#, << waiting for link >>                00356000
   VCB'MNTWAIT=VCB'FLAGS.(13:1)#, << waiting for mount >>               00358000
   VCB'RSWAIT =VCB'FLAGS.(14:1)#, << wait for reelswitch >>             00360000
   VCB'INUSE  =VCB'FLAGS.(15:1)#, << this entry in use >>               00362000
 VCB'LDEV      =VTBUF(1)#,                                              00364000
 VCB'PIN       =VTBUF(2)#,                                              00366000
 VCB'FNUM      =VTBUF(3)#,      << FOPEN nr. >>                         00368000
 VCB'FSEQ      =VTBUF(4)#,      << file seq. nr.  1:31,4 >>             00370000
 VCB'FLAG2     =VTBUF(5)#,                                              00372000
   VCB'STORTAP=VCB'FLAG2.(0:1)#,  << STORE tape >>                      00374000
   VCB'RSWDONE=VCB'FLAG2.(1:1)#,  << Reelswitch was done >>             00376000
   VCB'WRITDIR=VCB'FLAG2.(2:1)#,  << next file is directory >>          00378000
   VCB'NEEDVOL=VCB'FLAG2.(3:1)#,    << VOL1 write flag >>      <<03581>>00380000
   VCB'DENSITY=VCB'FLAG2.(4:3)#,  << requested density >>      <<03581>>00382000
   VCB'VSETOPEN=VCB'FLAG2.(7:1)#, << First open of volset >>   <<03581>>00384000
   VCB'REEL   =VCB'FLAG2.(8:8)#,  << reel nr.  1:27,4 >>                00386000
 VCB'EXDATE    =VTBUF(6)#,      << expiration date 1:47,6 >>            00388000
 VCB'FNAME     =VTBUFB(14)#,    << file name  1:4,17 >>                 00390000
 VCB'LOCKWRD   =VTBUFB(32)#,    << lockword  2:15,8 >>                  00392000
 VCB'VSETID    =VTBUFB(40)#,    << volume set ID 1:21,6 >>              00394000
 VCB'VOLID     =VTBUFB(46)#;    << volume ID 0:4,6 >>                   00396000
                                                                        00398000
DEFINE BUILDVCB =                                                       00400000
   BYTE ARRAY VTBUFB(*) =VTBUF;                                         00402000
   LOGICAL INUSE = VTBUF#;                                              00404000
                                                                        00406000
<< VCB'POSN states describe head position on tape. >>                   00408000
                                                                        00410000
EQUATE                                                                  00412000
   LDPNT = 0,     << VOL1 >>                                            00414000
   H1NX  = 1,     << HDR1&2 >>                                          00416000
   AH2   = 3,     << UHLx >>                                            00418000
   AHU   = 4,      << tapemark here >>                                  00420000
   DNX   = 6,     << data >>                                            00422000
   AD    = 7,      << tapemark here >>                                  00424000
   T1NX  = 8,     << EOV1&2 >>                                          00426000
   AT2   =10,     << UTLx >>                                            00428000
   ATU   =11;      << tapemark >>                                       00430000
                                                                        00432000
  << Tape label structure definitions >>                                00434000
                                                                        00436000
EQUATE LBLSIZE =40;     << words >>                                     00438000
DEFINE ANSI'VERSION = "3"#;                                    <<04740>>00440000
DEFINE                                                                  00442000
      L0VOLID  =BLABEL0(4)#,                                            00444000
      L0ACCESS =BLABEL0(10)#,                                           00446000
      L0SMARK  =BLABEL0(79)#;                                           00448000
DEFINE                                                                  00450000
      L1FNAME  =BTLABEL(4)#,                                            00452000
      L1VSETID =BTLABEL(21)#,                                           00454000
      L1REEL   =BTLABEL(27)#,                                           00456000
      L1FSEQ   =BTLABEL(31)#,                                           00458000
      L1CYR    =BTLABEL(42)#,                                           00460000
      L1CDAY   =BTLABEL(44)#,                                           00462000
      L1XYR    =BTLABEL(48)#,                                           00464000
      L1XDAY   =BTLABEL(50)#,                                           00466000
      L1ACC    =BTLABEL(53)#,                                           00468000
      L1NBLKS  =BTLABEL(54)#,                                  <<0196>> 00470000
      L1SYSTEM =BTLABEL(60)#;                                           00472000
DEFINE                                                                  00474000
      L2RFMT   =BTLABEL(4)#,                                            00476000
      L2BSIZE  =BTLABEL(5)#,                                            00478000
      L2RSIZE  =BTLABEL(10)#,                                           00480000
      L2BUFOFF =BTLABEL(50)#,                                           00482000
      L2LOCK   =BTLABEL(15)#,     << HP only >>                         00484000
      L2FTYPE  =BTLABEL(36)#,                                           00486000
      L2CCTL   =BTLABEL(37)#,                                           00488000
      L2DSPOSN =BTLABEL(16)#,    << IBM only >>                         00490000
      L2BLKATT =BTLABEL(38)#;                                           00492000
                                                                        00494000
DEFINE                                                                  00496000
      HPSYSTEM  ="HP MPE 3000 "#,                                       00498000
      FOPASCII  =FOPS.(13:1)#,                                          00500000
      FOPFTYPE  =FOPS.(8:2)#,                                           00502000
      FOPCCTL   =FOPS.(7:1)#;                                           00504000
                                                                        00506000
   << Functions for ATTACHIO >>                                         00508000
                                                                        00510000
EQUATE READ=0,                                                          00512000
       WRITE=1,                                                <<02563>>00514000
       DCLOSE=4,         << Device close >>                    <<02563>>00516000
       READ'STATUS=15,   << Read Status for 7976 >>            <<02563>>00518000
       DEN'FUNC=16,      << Set Density for 7976 >>            <<02563>>00520000
                                                               <<02563>>00522000
   << Important status returns from ATTACHIO >>                <<02563>>00524000
                                                               <<02563>>00526000
      PFAIL'ABORT =  %63,  << Power fail abort >>              <<02563>>00528000
      RUNAWAY     = %103,  << Tape runaway, new tape >>        <<02563>>00530000
      POWER'UP    = %213,  << Device powered up >>             <<02563>>00532000
      TRANS'ERROR =  %14,  << Transmission error/track error >><<02563>>00534000
      PARITY'ERR  =  %74;  << Parity error (Series II/III) >>  <<02563>>00536000
                                                               <<02563>>00538000
EQUATE TLTDST=26;                                                       00540000
EQUATE TLTSIR=39;                                                       00542000
                                                                        00544000
<< TLT Base Entry Structure definitions >>                              00546000
                                                                        00548000
EQUATE XESIZE   =1,   << entry size >>                                  00550000
       XLTBASE  =2,   << bottom of LDEV part >>                         00552000
       XVTBASE  =3,   << top of LDEV - bottom of Vol T >>               00554000
       XVTTOP   =4,   << top of current Vol Table >>                    00556000
       XVTMAX   =5,   << upper limit for Vol Table >>          <<03581>>00558000
       XVREST   =6;  << begining of the rest of the entry >>   <<03581>>00560000
                                                                        00562000
   INTEGER STATUS=Q-1;                                                  00564000
   INTEGER RTNX=Q-3;                                                    00566000
   INTEGER S0=S-0;                                                      00568000
   LOGICAL LS0=S-0;                                                     00570000
   INTEGER X=X;                                                         00572000
EQUATE CCG=0, CCL=1, CCE=2;                                             00574000
EQUATE PCBSIZE = 16,                                                    00576000
       PCBBASE = 3,                                                     00578000
       CPCB    = 4,                                                     00580000
                                                               <<03581>>00582000
LBTINVOP    = 20,   << invalid operation >>                             00584000
LBTUNAVL    = 55,   << device unavailable >>                            00586000
LBTSYNTAX   =116,   << Syntax err in formsmsg >>                        00588000
LBTUNEXP    =117,   << Tried write to unexpired tape >>                 00590000
LBTFMTERR   =118,   << Format of "labeled" tape wrong >>                00592000
LBTPOSERR   =119,   << Error positioning labeled tape >>                00594000
LBTIBMWRIT  =120,   << writing IBM labels >>                            00596000
LBTLWERR    =121,   << Labeled tape lockword violation >>               00598000
LBTOFLOW    =122,   << Tape label table overflow >>                     00600000
LBTEOVSET   =123,   << End of volset encountered >>                     00602000
LBTAPPEND   =124,   << Tried Append to labeled tape >>                  00604000
IGNORE'ERR  = 284,  << Ignored tape errors during AVR. >>      <<02722>>00606000
       EOFSTAT = %12,                                                   00608000
       INVALID  = 4;                                                    00610000
DEFINE CC=STATUS.(6:2)#,                                                00612000
   S0STAT=S0.(8:8)#,                                                    00614000
   ASMB  =ASSEMBLE#;                                                    00616000
DEFINE ENABLE = ASSEMBLE(SED 1)#;                                       00618000
DEFINE DISABLE = ASSEMBLE(SED 0)#;                                      00620000
                                                                        00622000
EQUATE  LPDTENTRY=2;                                                    00624000
INTEGER POINTER LPDT = 8;  << LPDT system table >>                      00626000
                                                               <<02563>>00628000
<<*****************************>>                              <<02563>>00630000
<< LPDT Density Definitions    >>                              <<02563>>00632000
<<*****************************>>                              <<02563>>00634000
DEFINE                                                         <<02563>>00636000
   TAPEREC        =  (11:1)#,   << AVR in progress >>          <<02563>>00638000
   STATE          =  (0:2)#,    << Device recognition state >> <<02722>>00640000
   T'SUBTYPE      =  (13:3)#,   << Subtype field for tapes >>  <<02563>>00642000
      HP7970      =  0#,           << Subtype for HP7970 >>    <<02563>>00644000
      HP7976      =  1#,           << Subtype for HP7976 >>    <<02563>>00646000
   AVR'DONE             =       << DEVREC done w/ tape >>      <<02563>>00648000
      LPDT(LDEV*LPDTENTRY + 1).TAPEREC = 0#,                   <<02563>>00650000
   TAPE'DEVICE =                                               <<03581>>00652000
      LDEVTOTYPE(LDEV)=24#,                                    <<03581>>00654000
   SET'BOT'ON =                                                <<03581>>00656000
      SET'LPDT'BOT(LDEV,1)#,                                   <<03581>>00658000
   SET'BOT'OFF =                                               <<03581>>00660000
      SET'LPDT'BOT(LDEV,0)#,                                   <<03581>>00662000
   VARIABLE'DENSITY =       <<Test for var. dens. tape drive>> <<03581>>00664000
      TAPE'DEVICE LAND                                         <<03581>>00666000
      LPDT(LDEV*LPDTENTRY+1).T'SUBTYPE=HP7976#;                <<03581>>00668000
            <<Remember that LDEV could be SDISC>>              <<03581>>00670000
<<*****************************>>                              <<02563>>00672000
<<    LDT Density Definitions  >>                              <<02563>>00674000
<<*****************************>>                              <<02563>>00676000
EQUATE                                                         <<02563>>00678000
   LDTDST       = %16,                                         <<02563>>00680000
   LDTSIR       = %12,                                         <<02563>>00682000
   LDTENTRY     =   5,    << Size of LDT entry >>              <<02563>>00684000
   DENSITYW     =   4,    << Entry offset to density info >>   <<02563>>00686000
   DEN'DEFAULT  =   0,    << Default density requested >>      <<02563>>00688000
   NULL'REQ     =   0,    << Null value for density fields >>  <<02563>>00690000
   DEN'1600     =   1,    << Field value for 1600 BPI >>       <<02563>>00692000
   DEN'6250     =   2;    << Field value for 6250 BPI >>       <<02563>>00694000
                                                               <<02563>>00696000
  << Tape trouble codes  >>                                    <<03581>>00698000
EQUATE                                                         <<03581>>00700000
  TT5 =5,                                                      <<03581>>00702000
  TT6 =6,                                                      <<03581>>00704000
  TT7 =7,                                                      <<03581>>00706000
  TT9 =9,                                                      <<03581>>00708000
  TT10=10,                                                     <<03581>>00710000
  TT11=11,                                                     <<03618>>00712000
  TT12=12,                                                     <<03618>>00714000
  TT13=13,                                                     <<03618>>00716000
  TT14=14,                                                     <<03618>>00718000
  TT15=15,                                                     <<03581>>00720000
  TT16=16,                                                     <<03581>>00722000
  TT23=23,                                                     <<03581>>00724000
  TT24=24,                                                     <<03581>>00726000
  TT25=25,                                                     <<03581>>00728000
  TT27=27,                                                     <<03581>>00730000
  TT29=29,                                                     <<03581>>00732000
  TT41=41,                                                     <<03581>>00734000
  TT42=42,                                                     <<03581>>00736000
  TT43=43,                                                     <<03581>>00738000
  TT52=52,                                                     <<03581>>00740000
  TT53=53;                                                     <<03581>>00742000
DEFINE                                                         <<02563>>00744000
   << Density field definitions >>                             <<02563>>00748000
   TAPE'DENSITY    = LDT'DENW.(1:3)#, << Actual tape density >><<02563>>00750000
   REQUEST'DENSITY = LDT'DENW.(4:3)#; << User requested den. >><<02563>>00752000
EQUATE MONITOR = %1077;   << FILESYS SYSGLOB cell >>           <<02648>>00754000
DEFINE DISABL'IBM = NOT ABSOLUTE(MONITOR).(12:1)#;             <<02648>>00756000
                                                               <<02648>>00758000
$PAGE " FORWARD AND EXTERNAL DECLARATIONS "                             00760000
LOGICAL PROCEDURE CKFORLABEL(LDEV,RDWR,LBLED);                          00762000
   VALUE LDEV,RDWR,LBLED;                                               00764000
   INTEGER LDEV,RDWR; LOGICAL LBLED;                                    00766000
   OPTION FORWARD;                                                      00768000
                                                                        00770000
PROCEDURE CLEANLDEV(LDEV);                                     <<02563>>00772000
   VALUE LDEV;                                                 <<02575>>00774000
   INTEGER LDEV;                                               <<02563>>00776000
   OPTION FORWARD;                                             <<02563>>00778000
                                                               <<02563>>00780000
PROCEDURE STORE'DENSITY(LDEV,DENSITY,MODE);                    <<02563>>00782000
   VALUE LDEV,MODE;                                            <<02563>>00784000
   INTEGER LDEV,MODE;                                          <<02563>>00786000
   ARRAY DENSITY;                                              <<02563>>00788000
   OPTION FORWARD;                                             <<02563>>00790000
                                                               <<02563>>00792000
INTEGER PROCEDURE CONVERTDATE(DATE);                           <<0196>> 00794000
    VALUE DATE;                                                <<0196>> 00796000
    BYTE POINTER DATE;                                         <<0196>> 00798000
    OPTION EXTERNAL;                                           <<0196>> 00800000
<< Converts string of form "MM/DD/YY" to CALENDAR format. >>            00802000
                                                                        00804000
LOGICAL PROCEDURE GETSIR(SIRNUM);                                       00806000
   VALUE SIRNUM;                                                        00808000
   INTEGER SIRNUM;                                                      00810000
   OPTION EXTERNAL;                                                     00812000
                                                                        00814000
LOGICAL PROCEDURE RELSIR(SIRNUM,ALREADY);                               00816000
   VALUE SIRNUM,ALREADY;                                                00818000
   INTEGER SIRNUM;                                                      00820000
   LOGICAL ALREADY;                                                     00822000
   OPTION EXTERNAL;                                                     00824000
                                                                        00826000
LOGICAL PROCEDURE EXCHANGEDB(DSTX);                                     00828000
   VALUE DSTX;                                                          00830000
   LOGICAL DSTX;                                                        00832000
   OPTION EXTERNAL;                                                     00834000
                                                                        00836000
PROCEDURE SUDDENDEATH(CRASH);                                           00838000
   VALUE CRASH; INTEGER CRASH;                                          00840000
   OPTION EXTERNAL;                                                     00842000
                                                                        00844000
DOUBLE PROCEDURE ATTACHIO(LDEV,QMISC,DSTX,ADDR,FUNC,CNT,P1,P2,FLAGS);   00846000
   VALUE LDEV,QMISC,DSTX,ADDR,FUNC,CNT,P1,P2,FLAGS;                     00848000
   INTEGER LDEV,QMISC,DSTX,ADDR,FUNC,CNT,P1,P2,FLAGS;                   00850000
   OPTION EXTERNAL;                                                     00852000
                                                                        00854000
PROCEDURE REPORT'IOERROR(LDEV,IOSTATUS);                       <<02673>>00856000
   VALUE LDEV,IOSTATUS;                                        <<02673>>00858000
   INTEGER LDEV,IOSTATUS;                                      <<02673>>00860000
   OPTION EXTERNAL;                                            <<02673>>00862000
                                                               <<02673>>00864000
INTEGER PROCEDURE REMRITENTRY(ADR);                                     00866000
   VALUE ADR;                                                           00868000
   INTEGER ADR;                                                         00870000
   OPTION EXTERNAL;                                                     00872000
                                                                        00874000
PROCEDURE FREEDEVICE(LDEV,WAIT,NOREW);                                  00876000
   VALUE WAIT,LDEV,NOREW;                                               00878000
   INTEGER LDEV;                                                        00880000
   LOGICAL WAIT,NOREW;                                                  00882000
   OPTION VARIABLE,EXTERNAL;                                            00884000
                                                                        00886000
PROCEDURE SET'LPDT'BOT(LDEV,VAL);                              <<02563>>00888000
   VALUE LDEV,VAL; LOGICAL LDEV,VAL;                           <<02563>>00890000
   OPTION EXTERNAL;                                            <<02563>>00892000
                                                               <<02563>>00894000
PROCEDURE LOG14;                                                        00896000
  OPTION EXTERNAL;                                                      00898000
                                                                        00900000
PROCEDURE DEBUG;                                                        00902000
   OPTION EXTERNAL;                                                     00904000
                                                                        00906000
PROCEDURE DELAY(T);                                            <<02563>>00908000
   VALUE T; DOUBLE T;                                          <<02563>>00910000
   OPTION EXTERNAL;                                            <<02563>>00912000
                                                               <<02563>>00914000
INTEGER PROCEDURE GENMSG(SETNO,MSGNO,MASK,PARM1,PARM2,                  00916000
      PARM3,PARM4,PARM5,DEST,REPLY,OFFSET,DST,CONTROL);                 00918000
   VALUE   SETNO,MSGNO,MASK,PARM1,PARM2,PARM3,PARM4,PARM5,              00920000
           DEST,REPLY,OFFSET,DST,CONTROL;                               00922000
   INTEGER SETNO,MSGNO,DEST,DST;                                        00924000
   LOGICAL MASK,PARM1,PARM2,PARM3,PARM4,PARM5,REPLY,OFFSET,             00926000
      CONTROL;                                                          00928000
   OPTION VARIABLE,EXTERNAL;                                            00930000
                                                                        00932000
PROCEDURE POST'ACB'ERROR(FILENUM,THEIRSTATUS,ERROR);           <<02703>>00934000
  VALUE FILENUM,THEIRSTATUS,ERROR;                             <<02703>>00936000
  INTEGER FILENUM,ERROR;                                       <<02703>>00938000
  LOGICAL THEIRSTATUS;                                         <<02703>>00940000
  OPTION EXTERNAL;                                             <<02703>>00942000
                                                               <<03581>>00944000
INTEGER PROCEDURE LDEVTOTYPE(LDEV);                            <<03581>>00946000
  VALUE LDEV; INTEGER LDEV; OPTION EXTERNAL;                   <<03581>>00948000
                                                               <<03581>>00950000
PROCEDURE FORS'XDS'DEALLOC(LDEV);                              <<03634>>00952000
  VALUE LDEV;                                                  <<03634>>00954000
  INTEGER LDEV;                                                <<03634>>00956000
  OPTION EXTERNAL;                                             <<03634>>00958000
                                                               <<03634>>00960000
INTRINSIC CALENDAR,CTRANSLATE,FGETINFO,FCONTROL,PRINTOPREPLY;           00962000
INTRINSIC ASCII;                                               <<02722>>00964000
$PAGE " UTILITIES "                                                     00966000
PROCEDURE TAPETROUBLE(CRASH);                                           00968000
   VALUE CRASH; INTEGER CRASH;                                          00970000
   OPTION INTERNAL;                                            <<02621>>00972000
                                                                        00974000
   BEGIN                                                                00976000
   SUDDENDEATH(86);                                                     00978000
   END;                                                                 00980000
INTEGER PROCEDURE SETOWNED(LDEV,N);                                     00982000
   VALUE LDEV,N;                                                        00984000
   INTEGER LDEV,N;                                                      00986000
   OPTION INTERNAL;                                            <<02621>>00988000
                                                                        00990000
<< Get or set ownership bits in the LPDT entry. >>                      00992000
                                                                        00994000
   BEGIN                                                                00996000
                                                                        00998000
   DISABLE;                                                             01000000
   TOS := SETOWNED := LPDT(LDEV*LPDTENTRY+1);                           01002000
   IF N >= 0 THEN                                                       01004000
      BEGIN                                                             01006000
      TOS.(0:2) := N;    << new value >>                                01008000
      LPDT(X) := TOS;                                                   01010000
      END;                                                              01012000
   ENABLE;                                                              01014000
   END;                                                                 01016000
PROCEDURE ATTIO(LDEV,FUNC);                                             01018000
VALUE LDEV,FUNC; INTEGER LDEV,FUNC;                                     01020000
   OPTION INTERNAL;                                            <<02621>>01022000
                                                                        01024000
   BEGIN                                                                01026000
   IF LDEV=0 THEN TAPETROUBLE(TT5);  << oops! >>               <<03581>>01028000
   TOS := ATTACHIO(LDEV,0,0,0,FUNC,0,0,0,%11);                          01030000
   DEL;                                                                 01032000
   CC := IF S0.(13:3) = 1 THEN CCE ELSE                                 01034000
      IF S0.(13:3) = 2 THEN CCG ELSE CCL;                               01036000
   RTNX := TOS;                                                         01038000
   END;                                                                 01040000
PROCEDURE LOGIT(VTBUF);                                                 01042000
  ARRAY VTBUF;                                                          01044000
   OPTION INTERNAL;                                            <<02621>>01046000
                                                                        01048000
<< Write Log record.  The record is built by shuffling                  01050000
the VCB, so caller must have finished using it.  DB is                  01052000
at the stack. >>                                                        01054000
                                                                        01056000
   BEGIN                                                                01058000
   VTBUF(5).(0:8) := VCB'PIN;                                  <<02673>>01060000
   VTBUF(2) := VCB'LDEV;                                       <<02673>>01062000
   TOS := VCB'FNUM;   << Get file num. out of the way. >>      <<02673>>01064000
   VTBUF(3) := VCB'FSEQ;                                       <<02673>>01066000
   VTBUF(4).(0:8) := TOS;                                      <<02673>>01068000
   VTBUF(4).(8:8) := VTBUF(0).(8:8);   << seq flags >>                  01070000
                                                                        01072000
   TOS := @VTBUF+2;                                                     01074000
   TOS := 24;                                                           01076000
   TOS := 14;    << log record # >>                                     01078000
   LOG14;                                                               01080000
   END;       << procedure LOGIT>>                                      01082000
$PAGE " NUMERICAL CONVERSION "                                          01084000
PROCEDURE BIN2ASC(NUM,FPTR,FSIZE);                                      01086000
VALUE NUM,FSIZE;                                                        01088000
DOUBLE NUM;                                                             01090000
BYTE ARRAY FPTR;                                                        01092000
INTEGER FSIZE;                                                          01094000
   OPTION INTERNAL;                                            <<02621>>01096000
                                                                        01098000
   BEGIN    << convert to ASCII, with leading zeroes. >>                01100000
   TOS := NUM;                                                          01102000
   WHILE (FSIZE := FSIZE-1) >= 0 DO                                     01104000
      BEGIN                                                             01106000
      TOS := 10;                                                        01108000
      ASMB(LDIV);                                                       01110000
      FPTR(FSIZE) := TOS+"0";   << remainder >>                         01112000
      ASMB(ZERO,XCH);           << restore double >>                    01114000
      END;                                                              01116000
   END;                                                                 01118000
LOGICAL PROCEDURE BINARY'(STRING,NCHARS);                               01120000
VALUE NCHARS;                                                           01122000
BYTE ARRAY STRING;                                                      01124000
INTEGER NCHARS;                                                         01126000
   OPTION INTERNAL;                                            <<02621>>01128000
                                                                        01130000
<< Similar to the intrinsic, but is more forgiving of                   01132000
leading and trailing blanks. >>                                         01134000
                                                                        01136000
   BEGIN                                                                01138000
   INTEGER IX;                                                          01140000
   LOGICAL RESULT = BINARY';                                            01142000
                                                                        01144000
   CC := CCE;                                                           01146000
   IX := 0;                                                             01148000
   WHILE IX < NCHARS AND STRING(IX) = " " DO IX := IX+1;                01150000
   WHILE IX < NCHARS AND STRING(IX) <> " " DO                           01152000
      BEGIN                                                             01154000
      IF ("0" <= INTEGER(STRING(IX)) <= "9") THEN                       01156000
         RESULT := RESULT*10+LOGICAL(STRING(IX)-"0") ELSE               01158000
         CC := CCL;                                                     01160000
      IX := IX+1;                                                       01162000
      END;                                                              01164000
   END;                                                                 01166000
$PAGE " TAPE LABEL TABLE MANAGEMENT "                                   01168000
PROCEDURE GETXDSW(TARGET,DSTN,OFFSET,WC);                               01170000
   VALUE DSTN,OFFSET,WC;                                                01172000
   INTEGER DSTN,OFFSET,WC;                                              01174000
   ARRAY TARGET;                                                        01176000
   OPTION INTERNAL;                                            <<02621>>01178000
                                                                        01180000
<< A dress suit for an MFDS instruction. >>                             01182000
                                                                        01184000
   BEGIN                                                                01186000
   TOS := @TARGET;                                                      01188000
   TOS := DSTN; TOS := OFFSET;                                          01190000
   TOS := WC;                                                           01192000
   ASMB(MFDS 4);                                                        01194000
   END;                                                                 01196000
PROCEDURE PUTXDSW(DSTN,OFFSET,SOURCE,WC);                               01198000
   VALUE DSTN,OFFSET,WC;                                                01200000
   INTEGER DSTN,OFFSET,WC;                                              01202000
   ARRAY SOURCE;                                                        01204000
   OPTION INTERNAL;                                            <<02621>>01206000
                                                                        01208000
<< Fancy clothes for an MTDS instruction. >>                            01210000
                                                                        01212000
   BEGIN                                                                01214000
   TOS := DSTN; TOS := OFFSET;                                          01216000
   TOS := @SOURCE;                                                      01218000
   TOS := WC;                                                           01220000
   ASMB(MTDS 4);                                                        01222000
   END;                                                                 01224000
$PAGE                                                                   01226000
INTEGER PROCEDURE GETFNUM(FNUM,VTBUF);                                  01228000
VALUE FNUM; LOGICAL FNUM;                                               01230000
LOGICAL ARRAY VTBUF;                                                    01232000
   OPTION INTERNAL;                                            <<02621>>01234000
                                                                        01236000
<< Search for volume entry to match FNUM.  For present version,         01238000
match PIN and Filenum; eventually this should become ACB                01240000
location.  DB is at stack. >>                                           01242000
                                                                        01244000
   BEGIN                                                                01246000
   LOGICAL I = GETFNUM;                                                 01248000
   LOGICAL OLDSIR,PIN;                                                  01250000
   DEFINE  INUSE = VTBUF(0)#;                                           01252000
   DOUBLE VTBOUNDS;                                                     01254000
      LOGICAL VTBASE = VTBOUNDS;                                        01256000
      LOGICAL VTTOP = VTBOUNDS+1;                                       01258000
                                                                        01260000
   CC := CCE;                                                           01262000
   PIN := (ABSOLUTE(CPCB)-ABSOLUTE(PCBBASE))/PCBSIZE;                   01264000
   OLDSIR := GETSIR(TLTSIR);                                            01266000
   GETXDSW(VTBOUNDS,TLTDST,XVTBASE,2);                                  01268000
   I := VTBASE;                                                         01270000
   WHILE I < VTTOP DO                                                   01272000
      BEGIN                                                             01274000
      TOS := @VTBUF;                                                    01276000
      TOS := TLTDST; TOS := I;                                          01278000
      TOS := VTESIZE;                                                   01280000
      ASMB(MFDS 4);                                                     01282000
      IF INUSE AND (VCB'FNUM = FNUM) AND (VCB'PIN = PIN) THEN GO OUT;   01284000
      I := I+VTESIZE;                                                   01286000
      END;                                                              01288000
   CC := CCL;    << Not found. >>                                       01290000
   GETFNUM := -1;      << Rat trap. >>                                  01292000
OUT:                                                                    01294000
   RELSIR(TLTSIR,OLDSIR);                                               01296000
   END;        << procedure GETFNUM >>                                  01298000
INTEGER PROCEDURE GETLDEV(LDEV,LTBUF);                                  01300000
VALUE LDEV; LOGICAL LDEV;                                               01302000
LOGICAL ARRAY LTBUF;                                                    01304000
   OPTION INTERNAL;                                            <<02621>>01306000
                                                                        01308000
<< Search VT for entry matching LDEV.  DB is at stack. >>               01310000
                                                                        01312000
   BEGIN                                                                01314000
   LOGICAL I = GETLDEV;                                                 01316000
   INTEGER OLDSIR;                                                      01318000
   LOGICAL LTTOP;                                                       01320000
                                                                        01322000
   IF LDEV=0 THEN TAPETROUBLE(TT6);                            <<03581>>01324000
   CC := CCE;                                                           01326000
   OLDSIR := GETSIR(TLTSIR);                                            01328000
   GETXDSW(LTTOP,TLTDST,XVTBASE,1);                                     01330000
   I := LTESIZE;                                                        01332000
                                                               <<02563>>01334000
WHILE I < LTTOP DO                                             <<02563>>01336000
   BEGIN                                                       <<02563>>01338000
   TOS := @LTBUF;                                                       01340000
   TOS := TLTDST; TOS := I;                                             01342000
   TOS := VTESIZE;                                                      01344000
   ASMB(MFDS 4);                                                        01346000
   IF LCB'LDEV = LDEV THEN GO OUT;                                      01348000
   I := I+LTESIZE;                                                      01350000
   END;                                                        <<02563>>01352000
                                                               <<02563>>01354000
   CC := CCL;    << Not found. >>                                       01356000
OUT:                                                                    01358000
   RELSIR(TLTSIR,OLDSIR);                                               01360000
   END;        << procedure GETLDEV >>                                  01362000
$PAGE                                                                   01364000
PROCEDURE POSTVTENT(VTBUF,VTADDR,SCODE);                                01366000
VALUE SCODE; LOGICAL VTADDR,SCODE; ARRAY VTBUF;                         01368000
   OPTION INTERNAL;                                            <<02621>>01370000
                                                                        01372000
<< Stores entry into VT. DB must be at stack.  VTADDR=0                 01374000
means create a new entry (only in Volume section).  >>                  01376000
                                                                        01378000
   BEGIN                                                                01380000
   LOGICAL INUSE;                                                       01382000
   ARRAY VTBOUNDS(0:2) =Q;                                              01384000
      LOGICAL VTBASE = VTBOUNDS;                                        01386000
      LOGICAL VTTOP = VTBOUNDS+1;                                       01388000
      LOGICAL VTMAX = VTBOUNDS+2;                                       01390000
                                                                        01392000
   GETXDSW(VTBOUNDS,TLTDST,XVTBASE,3);                                  01394000
   IF INTEGER(VTADDR) < 0 THEN TAPETROUBLE(TT6);               <<03581>>01396000
   IF VTADDR <> 0 THEN GO STUFF;                                        01398000
                                                                        01400000
 << Create new entry; find hole for it. >>                              01402000
                                                                        01404000
   VCB'INUSE := 1;                                                      01406000
   VTADDR := VTBASE;                                                    01408000
LOOP:                                                                   01410000
   IF VTADDR >= VTTOP THEN GO EXPAND;                                   01412000
   TOS := @INUSE;                                                       01414000
   TOS := TLTDST; TOS := VTADDR;                                        01416000
   TOS := 1;                                                            01418000
   ASMB(MFDS 4);                                                        01420000
   IF NOT INUSE THEN GO STUFF;                                          01422000
   VTADDR := VTADDR+VTESIZE;                                            01424000
   GO LOOP;                                                             01426000
                                                                        01428000
EXPAND:                                                                 01430000
   CC := CCL;                                                           01432000
   VTTOP := VTTOP+VTESIZE;                                              01434000
   IF VTTOP >= VTMAX THEN GO BYEBYE;     << Burp! >>                    01436000
   PUTXDSW(TLTDST,XVTTOP,VTTOP,1);     << update size >>                01438000
STUFF:                                                                  01440000
   PUTXDSW(TLTDST,VTADDR,VTBUF,VTESIZE);   << post new entry. >>        01442000
   CC := CCE;                                                           01444000
BYEBYE:                                                                 01446000
   IF SCODE <> -1 THEN RELSIR(TLTSIR,SCODE);                            01448000
   END;        << procedure POSTVTENT >>                                01450000
$PAGE                                                          <<03618>>01452000
PROCEDURE LABELED'DEV'MOUNTED(LDEV);                           <<03618>>01454000
  VALUE LDEV;                                                  <<03618>>01456000
  LOGICAL LDEV;                                                <<03618>>01458000
  OPTION UNCALLABLE;                                           <<03618>>01460000
COMMENT                                                        <<03618>>01462000
                                                               <<03618>>01464000
   This procedure allows DEVREC and PVPROC to let REELSWITCH   <<03618>>01466000
know that the "tape" has been mounted.  It will set the        <<03618>>01468000
DEVREC wait bit in the VCB of the table.                       <<03618>>01470000
                                                               <<03618>>01472000
Will be rewritten when we allow different LDEVs for            <<03618>>01474000
reswitches.                                                    <<03618>>01476000
                                                               <<03618>>01478000
;                                                              <<03618>>01480000
BEGIN                                                          <<03618>>01482000
LOGICAL VTADDR,LTADDR;                                         <<03618>>01484000
INTEGER SCODE;                                                 <<03618>>01486000
LOGICAL ARRAY VTBUF(0:VTESIZE-1)=Q;                            <<03618>>01488000
  BUILDVCB;                                                    <<03618>>01490000
LOGICAL ARRAY LTBUF(0:LTESIZE-1)=Q;                            <<03618>>01492000
  BUILDLCB;                                                    <<03618>>01494000
                                                               <<03618>>01496000
LTADDR := GETLDEV(LDEV,LTBUF);                                 <<03618>>01498000
IF < THEN TAPETROUBLE(TT11);                                   <<03618>>01500000
IF LCB'VCB > 0    <<  Tape device is linked up  >>             <<03618>>01502000
  THEN BEGIN                                                   <<03618>>01504000
    VTADDR := LCB'VCB;                                         <<03618>>01506000
    GETXDSW(VTBUF,TLTDST,VTADDR,VTESIZE);                      <<03618>>01508000
    IF LDEV <> VCB'LDEV THEN TAPETROUBLE(TT12);                <<03618>>01510000
    VCB'DR'WAIT := 1;                                          <<03618>>01512000
    SCODE := GETSIR(TLTSIR);                                   <<03618>>01514000
    POSTVTENT(VTBUF,VTADDR,SCODE);                             <<03618>>01516000
    END;                                                       <<03618>>01518000
END;                                                           <<03618>>01520000
$PAGE                                                          <<03618>>01522000
LOGICAL PROCEDURE TEST'FOR'REELSWITCH(LDEV);                   <<03618>>01524000
VALUE LDEV;                                                    <<03618>>01526000
LOGICAL LDEV;                                                  <<03618>>01528000
OPTION UNCALLABLE;                                             <<03618>>01530000
COMMENT                                                        <<03618>>01532000
                                                               <<03618>>01534000
  This procedure will let the caller (PVPROC) know if we       <<03618>>01536000
are waiting for a REELSWITCH.  It will check the               <<03618>>01538000
VCB'RSWAIT bit in the VCB for the volume mounted on the        <<03618>>01540000
LDEV.                                                          <<03618>>01542000
                                                               <<03618>>01544000
  Returns: TRUE if waiting for a reelswitch,                   <<03618>>01546000
           FALSE if not waiting for a reelswitch.              <<03618>>01548000
                                                               <<03618>>01550000
Will be rewritten when we allow different LDEVs for            <<03618>>01552000
reelswitches.                                                  <<03618>>01554000
                                                               <<03618>>01556000
;                                                              <<03618>>01558000
BEGIN                                                          <<03618>>01560000
LOGICAL VTADDR,LTADDR;                                         <<03618>>01562000
INTEGER SCODE;                                                 <<03618>>01564000
LOGICAL ARRAY VTBUF(0:VTESIZE-1)=Q;                            <<03618>>01566000
  BUILDVCB;                                                    <<03618>>01568000
LOGICAL ARRAY LTBUF(0:VTESIZE-1)=Q;                            <<03618>>01570000
  BUILDLCB;                                                    <<03618>>01572000
                                                               <<03618>>01574000
LTADDR := GETLDEV(LDEV,LTBUF);                                 <<03618>>01576000
IF < THEN TAPETROUBLE(TT13);                                   <<03618>>01578000
IF LCB'VCB > 0       <<  Tape device is linked up  >>          <<03618>>01580000
  THEN BEGIN                                                   <<03618>>01582000
    VTADDR := LCB'VCB;                                         <<03618>>01584000
    GETXDSW(VTBUF,TLTDST,VTADDR,VTESIZE);                      <<03618>>01586000
    IF LDEV <> VCB'LDEV THEN TAPETROUBLE(TT14);                <<03618>>01588000
    TEST'FOR'REELSWITCH := VCB'RSWAIT;                         <<03618>>01590000
    END                                                        <<03618>>01592000
  ELSE TEST'FOR'REELSWITCH := FALSE;                           <<03618>>01594000
END;                                                           <<03618>>01596000
PROCEDURE SETUP'TAPES;                                         <<02563>>01598000
OPTION PRIVILEGED,UNCALLABLE;                                           01600000
COMMENT                                                        <<03581>>01602000
                                                               <<03581>>01604000
     Re-format TLTDST as required.  Also, initialize other     <<03581>>01606000
     tape data structures.  Runs only once.  Gets the table    <<03581>>01608000
     in unformated condition (as follows).                     <<03581>>01610000
                                                               <<03581>>01612000
   Word 0 - Size of TLTDST                                     <<03581>>01614000
   Word 1 - N: Number of LDEVs in table.                       <<03581>>01616000
   Word 2 - In (0:8): LDEV number, In (7:8): 1 if tape         <<03581>>01618000
     ~    -     otherwise 0.                                   <<03581>>01620000
   Word N+2                                                    <<03581>>01622000
                                                               <<03581>>01624000
;                                                              <<03581>>01626000
                                                                        01628000
   BEGIN                                                                01630000
   INTEGER POINTER OLDLDEV,NEWLDEV;                                     01632000
   INTEGER                                                     <<03581>>01634000
      MAXSIZE,                                                 <<03581>>01636000
      SCODE,                                                   <<02563>>01638000
      USERDB,                                                  <<02563>>01640000
      NUMLDEVS,       << Number of tape LDEVs >>               <<02563>>01642000
      INDEX := 0,     << Index for TAPE'LDEVS >>               <<02563>>01644000
      LDEV;                                                    <<02563>>01646000
   EQUATE                                                               01648000
      OLDLDEVBASE = 2,                                         <<03581>>01650000
      NEWLDEVBASE = LTESIZE+1;                                          01652000
   INTEGER OLDNUMLDEVW = DB+1;                                 <<03581>>01654000
   INTEGER MAXSIZEW = DB;                                      <<03581>>01656000
<< The next declaration must be the last one in the >>         <<02563>>01658000
<< procedure.  A dynamic direct array will be built >>         <<02563>>01660000
<< on Top Of Stack with an ADDS instruction. >>                <<02563>>01662000
   INTEGER ARRAY TAPE'LDEVS(*) = Q;                            <<02563>>01664000
                                                               <<02563>>01666000
   DEFINE                                                      <<03581>>01668000
     DEV=(0:8)#,                                               <<03581>>01670000
     TAPE=(8:8)#;                                              <<03581>>01672000
                                                               <<03581>>01674000
                                                                        01676000
   SCODE := GETSIR(TLTSIR);                                    <<02563>>01680000
   USERDB := EXCHANGEDB(TLTDST);                               <<02563>>01682000
                                                               <<02563>>01684000
<< Get stack space for TAPE'LDEVS array >>                     <<02563>>01686000
                                                               <<02563>>01688000
   NUMLDEVS := OLDNUMLDEVW;                                    <<03581>>01690000
   MAXSIZE := MAXSIZEW;                                        <<03581>>01692000
   TOS := NUMLDEVS;                                            <<02563>>01694000
   ASMB( ADDS 0 );                                             <<02563>>01696000
                                                               <<02563>>01698000
<< Move LDEV numbers into local array. >>                      <<02563>>01700000
                                                               <<02563>>01702000
   @OLDLDEV := OLDLDEVBASE;                                    <<02563>>01704000
                                                               <<02563>>01706000
   WHILE NUMLDEVS > 0  DO                                      <<02563>>01708000
      BEGIN                                                    <<02563>>01710000
                                                               <<02563>>01712000
      TAPE'LDEVS(INDEX) := OLDLDEV;                            <<03581>>01714000
                                                               <<02563>>01716000
      @OLDLDEV := @OLDLDEV + 1;                                <<03581>>01718000
      NUMLDEVS := NUMLDEVS - 1;                                <<02563>>01720000
      INDEX := INDEX + 1;                                      <<02563>>01722000
      END;                                                     <<02563>>01724000
                                                               <<02563>>01726000
<< Restructure table into new format. >>                       <<02563>>01728000
                                                               <<02563>>01730000
   @NEWLDEV := NEWLDEVBASE;                                    <<02563>>01732000
   NUMLDEVS := INDEX;                                          <<02563>>01734000
   INDEX := 0;                                                 <<02563>>01736000
                                                               <<02563>>01738000
   WHILE NUMLDEVS > 0  DO                                      <<02563>>01740000
      BEGIN                                                    <<02563>>01742000
      << Zero out TLT entry >>                                 <<02563>>01744000
      NEWLDEV(-1) := 0;                                        <<02563>>01746000
      MOVE NEWLDEV(0) := NEWLDEV(-1),(LTESIZE-1);              <<02563>>01748000
                                                               <<02563>>01750000
      NEWLDEV := TAPE'LDEVS(INDEX).DEV;                        <<03581>>01752000
                                                               <<02563>>01754000
      NEWLDEV(-1).(6:1) := TAPE'LDEVS(INDEX).TAPE;             <<03581>>01756000
                                                               <<03581>>01758000
      @NEWLDEV := @NEWLDEV + LTESIZE;                          <<02563>>01760000
      NUMLDEVS := NUMLDEVS - 1;                                <<02563>>01762000
      INDEX := INDEX + 1;                                      <<02563>>01764000
      END;                                                     <<02563>>01766000
                                                               <<02563>>01768000
<< Make base entry. >>                                                  01770000
                                                                        01772000
   @NEWLDEV := @NEWLDEV-1;                                              01774000
   @OLDLDEV := 0;                                                       01776000
   OLDLDEV(0) := 1;      << initialized >>                              01778000
   OLDLDEV(XESIZE) := LTESIZE;                                          01780000
   OLDLDEV(XLTBASE) := LTESIZE;                                         01782000
   OLDLDEV(XVTBASE) := @NEWLDEV;                                        01784000
   OLDLDEV(XVTTOP) := @NEWLDEV;                                         01786000
   OLDLDEV(XVTMAX) := MAXSIZE;                                          01788000
   OLDLDEV(XVREST) := 0;                                       <<03581>>01790000
   MOVE OLDLDEV(XVREST+1) := OLDLDEV(XVREST),(19);             <<03581>>01792000
                                                                        01794000
   RELSIR(TLTSIR,SCODE);                                                01796000
   EXCHANGEDB(USERDB);                                                  01798000
                                                               <<02563>>01800000
<< Initialize tape density data structures.  >>                <<02563>>01802000
<< Zero density fields, and turn on BOT bit. >>                <<02563>>01804000
                                                               <<02563>>01806000
   WHILE (INDEX := INDEX - 1) >= 0  DO                         <<02563>>01808000
      BEGIN                                                    <<02563>>01810000
      LDEV := TAPE'LDEVS(INDEX);                               <<02563>>01812000
      STORE'DENSITY(LDEV,SCODE,2);   << SCODE is a dummy >>    <<02563>>01814000
      IF TAPE'DEVICE THEN SET'BOT'ON;                          <<03581>>01816000
      END;                                                     <<02563>>01818000
                                                               <<02563>>01820000
   END;         << procedure SETUP'TAPES >>                    <<02563>>01822000
$PAGE " SEGMENT INTERNAL DENSITY MANAGEMENT UTILITIES "        <<02563>>01824000
INTEGER PROCEDURE GET'DENSITY(LDEV);                           <<02563>>01826000
   VALUE LDEV; LOGICAL LDEV;                                   <<02563>>01828000
   OPTION INTERNAL;                                            <<02563>>01830000
                                                               <<02563>>01832000
COMMENT                                                        <<02563>>01834000
                                                               <<02563>>01836000
   This procedure returns the density of the tape on LDEV in   <<02563>>01838000
its internal representation.  Its sole purpose is to hide the  <<02563>>01840000
density data structure from other procedures.                  <<02563>>01842000
                                                               <<02563>>01844000
;       << end of comment >>                                   <<02563>>01846000
                                                               <<02563>>01848000
BEGIN                                                          <<02563>>01850000
INTEGER                                                        <<02563>>01852000
   LDT'DENW;      << LDT entry density information >>          <<02563>>01854000
                                                               <<02563>>01856000
   GETXDSW(LDT'DENW,LDTDST,(LDEV*LDTENTRY + DENSITYW),1);      <<02563>>01858000
   GET'DENSITY := TAPE'DENSITY;                                <<02563>>01860000
END;                                                           <<02563>>01862000
                                                               <<02563>>01864000
LOGICAL PROCEDURE WRONG'DENSITY(VTBUF);                        <<02563>>01866000
   INTEGER ARRAY VTBUF;                                        <<02563>>01868000
   OPTION INTERNAL;                                            <<02563>>01870000
                                                               <<02563>>01872000
COMMENT                                                        <<02563>>01874000
                                                               <<02563>>01876000
   This procedure returns TRUE when the user has made a        <<02563>>01878000
specific density request (i.e. not default) and the tape       <<02563>>01880000
associated with the request is of a different density.         <<02563>>01882000
                                                               <<02563>>01884000
;    << end of comment >>                                      <<02563>>01886000
                                                               <<02563>>01888000
BEGIN                                                          <<02563>>01890000
   IF VCB'DENSITY <> DEN'DEFAULT AND                           <<02563>>01892000
     GET'DENSITY(VCB'LDEV) <> VCB'DENSITY  THEN                <<02563>>01894000
      WRONG'DENSITY := TRUE;                                   <<02563>>01896000
END;                                                           <<02563>>01898000
                                                               <<02563>>01900000
LOGICAL PROCEDURE SET'DENSITY(LDEV,DENSITY);                   <<02662>>01902000
   VALUE LDEV,DENSITY;                                         <<02563>>01904000
   LOGICAL LDEV;                                               <<02563>>01906000
   INTEGER DENSITY;                                            <<02563>>01908000
   OPTION INTERNAL;                                            <<02563>>01910000
                                                               <<02563>>01912000
COMMENT                                                        <<02563>>01914000
                                                               <<02563>>01916000
   This procedure sets the density of a multiple density       <<02563>>01918000
mag tape drive.  It is very similar to WRITE'DENSITY in        <<02563>>01920000
module FILEIO.  However, there are certain differences:        <<02563>>01922000
   1)  the BOT bit is handled differently for labelled         <<02563>>01924000
       and unlabelled tapes,                                   <<02563>>01926000
   2)  the requested density is kept in different places       <<02563>>01928000
       for labelled and unlabelled tapes,                      <<02563>>01930000
   3)  DB will always be at the stack,                         <<02563>>01932000
   4)  for now, tape errors are generally ignored in LABSEG,   <<02563>>01934000
   5)  the LDT need not be locked since only one process at    <<02563>>01936000
       a time can access a labelled tape.                      <<02563>>01938000
Returns TRUE if an error occurs.                               <<02662>>01940000
;      << end of comment >>                                    <<02563>>01942000
                                                               <<02563>>01944000
BEGIN                                                          <<02563>>01946000
INTEGER                                                        <<02563>>01948000
   LDT'DENW,        << LDT entry density information >>        <<02563>>01950000
   DENW'INDEX,      << Offset into LDT to get LDT'DENW >>      <<02563>>01952000
   ATTIO'STAT,      << Holds ATTACHIO status return >>         <<02563>>01954000
   P2;              << Parameter 2 to ATTACHIO >>              <<02563>>01956000
EQUATE                                                         <<02563>>01958000
   SUCCESSFUL  = 1, << General status, OK >>                   <<02563>>01960000
   BFLAGS      = 1, << Blocked IO flags >>                     <<02563>>01962000
   P2'6250     = 0, << P2 value for 6250 BPI >>                <<02563>>01964000
   P2'1600     = 1; << P2 value for 1600 BPI >>                <<02563>>01966000
                                                               <<02563>>01968000
                                                               <<02563>>01970000
   IF NOT (VARIABLE'DENSITY) THEN RETURN;                      <<02563>>01972000
                                                               <<02563>>01974000
   P2 := IF DENSITY = DEN'1600 THEN P2'1600                    <<02563>>01976000
                               ELSE P2'6250;                   <<02563>>01978000
                                                               <<02563>>01980000
<< Retry set density if power problems >>                      <<02563>>01982000
                                                               <<02563>>01984000
   DO BEGIN                                                    <<02563>>01986000
      TOS := ATTACHIO(LDEV,0,0,0,DEN'FUNC,0,0,P2,BFLAGS);      <<02563>>01988000
      DEL;                                                     <<02563>>01990000
      ATTIO'STAT := TOS.(8:8);                                 <<02563>>01992000
      END                                                      <<02563>>01994000
   UNTIL ATTIO'STAT <> POWER'UP  AND                           <<02563>>01996000
         ATTIO'STAT <> PFAIL'ABORT;                            <<02563>>01998000
                                                               <<02563>>02000000
   IF ATTIO'STAT.(13:3) = SUCCESSFUL THEN                      <<02563>>02002000
      BEGIN                                                    <<02563>>02004000
      DENW'INDEX := LDEV*LDTENTRY + DENSITYW;                  <<02563>>02006000
      GETXDSW(LDT'DENW,LDTDST,DENW'INDEX,1);                   <<02563>>02008000
                                                               <<02563>>02010000
      TAPE'DENSITY := DENSITY;                                 <<02563>>02012000
                                                               <<02563>>02014000
      PUTXDSW(LDTDST,DENW'INDEX,LDT'DENW,1);                   <<02563>>02016000
      END                                                       <<2563>>02018000
   ELSE SET'DENSITY := TRUE;    << error >>                     <<2563>>02020000
   END;       << of procedure SET'DENSITY >>                    <<2563>>02022000
$PAGE " GOODREEL  "                                            <<02563>>02024000
LOGICAL PROCEDURE GOODREEL(VTBUF,LTBUF);                       <<02648>>02028000
LOGICAL ARRAY VTBUF,LTBUF;                                              02030000
OPTION INTERNAL;                                                        02032000
                                                                        02034000
<< Decides if a mounted volume is suitable to a tape request.  >>       02036000
                                                                        02038000
   BEGIN                                                                02040000
   BUILDLCB;                                                            02042000
   BUILDVCB;                                                            02044000
                                                                        02046000
   IF VCB'LABTYP <> LCB'LABTYP THEN GO NG;                              02048000
   IF VCB'WRITE AND (VCB'SEQTYP=1) THEN    << NEXT >>                   02050000
      IF VCB'VOLID=LCB'VOLID,(6) THEN GO OK ELSE GO NG;                 02052000
   IF VCB'VSETID=LCB'VSETID,(6) THEN GO MAYBE;                          02054000
   IF VCB'VOLID <> LCB'VOLID,(6) THEN GO NG;                            02056000
MAYBE:                                                                  02058000
   IF (VCB'SEQTYP=0) AND VCB'FNAME =LCB'FNAME,(IF LCB'HP THEN 17 ELSE 8)02060000
      AND (LCB'REEL <> 1) THEN GO NG;   << Name - need reel 1 >>        02062000
   IF (VCB'SEQTYP=3) THEN IF (LCB'FSEQ > VCB'FSEQ) OR                   02064000
      (LCB'FSEQ = VCB'FSEQ) AND (LCB'REEL <> 1) THEN                    02066000
      GO NG;       << By file number - need prior reel >>               02068000
OK:                                                                     02070000
   GOODREEL := TRUE;     << We'll buy it. >>                            02072000
NG:                                                                     02074000
   END;       << procedure GOODREEL >>                                  02076000
$PAGE " WRITE HEADER AND TRAILER LABELS "                               02078000
LOGICAL PROCEDURE WRITLAB0(VTBUF);                             <<02662>>02080000
   ARRAY VTBUF;                                                         02084000
   OPTION INTERNAL;                                            <<02621>>02086000
                                                                        02088000
<< Write Volume label [VOL1] per info in VCB. >>                        02090000
                                                                        02092000
   BEGIN                                                                02094000
   BYTE ARRAY VTBUFB(*) = VTBUF;                                        02096000
   ARRAY LABEL0(0:LBLSIZE-1) =Q;                                        02098000
      DOUBLE LTYPE = LABEL0;                                            02100000
      BYTE ARRAY BLABEL0(*) = LABEL0;                                   02102000
                                                                        02104000
   IF SET'DENSITY(VCB'LDEV,VCB'DENSITY) THEN WRITLAB0 := TRUE; <<02662>>02106000
                                                               <<02563>>02108000
   LABEL0 := "  ";                                                      02110000
   MOVE LABEL0(1) := LABEL0,(LBLSIZE-1);                                02112000
   LTYPE := "VOL1";                                                     02114000
   MOVE L0VOLID := VCB'VOLID,(6);                                       02116000
   IF VCB'LABTYP = 2 THEN L0SMARK := ANSI'VERSION ELSE         <<04740>>02118000
      BEGIN          << IBM >>                                          02120000
      L0ACCESS := "0";                                                  02122000
      CTRANSLATE(2,BLABEL0,,80);                                        02124000
      END;                                                              02126000
   TOS := ATTACHIO(VCB'LDEV,0,0,@LABEL0,WRITE,LBLSIZE,0,4,1);  <<02662>>02128000
   DEL;                                                        <<02662>>02130000
   IF TOS.(13:3) <> 1 THEN WRITLAB0 := TRUE;   << error >>     <<02662>>02132000
   END;      << procedure WRITLAB0 >>                                   02134000
$PAGE                                                                   02136000
LOGICAL PROCEDURE WRITELAB(VTBUF,LTYPE);                       <<02662>>02138000
VALUE LTYPE;                                                            02140000
ARRAY VTBUF;                                                            02142000
LOGICAL LTYPE;                                                          02144000
   OPTION INTERNAL;                                            <<02621>>02146000
                                                                        02148000
<< Called from REELSWITCH and CHECKUL to write HDR, EOF,                02150000
and EOV labels.  LTYPE specifies:                                       02152000
   0 - HDR                                                              02154000
   1 - EOF                                                              02156000
   2 - EOV                                                              02158000
DB must be at the stack. Returns True if error occured. >>     <<02662>>02160000
                                                                        02162000
   BEGIN                                                                02164000
   INTEGER LDEV;                                                        02166000
   LOGICAL DATE;                                                        02168000
   INTEGER RECSIZE;                                                     02170000
   INTEGER BLKSIZE;                                                     02172000
   DOUBLE NBLKS;                                                        02174000
   LOGICAL FOPS;                                                        02176000
   LOGICAL ARRAY TLABEL(0:LBLSIZE-1) =Q;                                02178000
      BYTE ARRAY BTLABEL(*)=TLABEL;                                     02180000
      DOUBLE L1TYPE = TLABEL;                                           02182000
      BUILDVCB;                                                         02184000
   DOUBLE ARRAY LTYPECODE(0:2) =PB := "HDR1","EOF1","EOV1";             02186000
   ARRAY FTYPECODE(0:3) =PB := "FFVVUUVV";                              02188000
   EQUATE FLAGS=1;                                                      02190000
                                                                        02192000
                                                               <<02689>>02194000
SUBROUTINE ATTIOS(FUNC);                                       <<02689>>02196000
VALUE FUNC; INTEGER FUNC;                                      <<02689>>02198000
                                                               <<02689>>02200000
   BEGIN                                                       <<02689>>02202000
   IF LDEV=0 THEN TAPETROUBLE(TT5);  << oops! >>               <<03581>>02204000
   TOS := ATTACHIO(LDEV,0,0,@TLABEL,FUNC,LBLSIZE,0,4,FLAGS);   <<02689>>02206000
   DEL;                                                        <<02689>>02208000
   IF S0.(13:3) <> 1 THEN WRITELAB := TRUE; << Report error! >><<02689>>02210000
   X := TOS;                                                   <<02689>>02212000
   END;                                                        <<02689>>02214000
                                                               <<02689>>02216000
                                                               <<02689>>02218000
 << Write HDR1 - EOF1 - EOV1  >>                                        02220000
                                                                        02222000
   TLABEL := "  ";                                                      02226000
   MOVE TLABEL(1) := TLABEL,(39);                                       02228000
   FGETINFO(VCB'FNUM,,FOPS,,RECSIZE,,LDEV,,,,,,,NBLKS,BLKSIZE);         02230000
   IF LTYPE <> 0 THEN ATTIOS(6);  << TM ends data >>           <<02689>>02232000
   L1TYPE := LTYPECODE(LTYPE);                                          02236000
   MOVE L1FNAME := VCB'FNAME,(17);                                      02238000
   BIN2ASC(DOUBLE(VCB'REEL),L1REEL,4);      << put in reel # >>         02240000
   BIN2ASC(DOUBLE(VCB'FSEQ),L1FSEQ,4);       << put in file seq # >>    02242000
   BIN2ASC(DOUBLE(VCB'EXDATE.(0:7)),L1XYR,2);   << put in exp date >>   02244000
   BIN2ASC(DOUBLE(VCB'EXDATE.(7:9)),L1XDAY,3);                          02246000
   DATE := CALENDAR;                                                    02248000
   BIN2ASC(DOUBLE(DATE.(0:7)),L1CYR,2);                                 02250000
   BIN2ASC(DOUBLE(DATE.(7:9)),L1CDAY,3);                                02252000
   MOVE L1VSETID := VCB'VSETID,(6);                                     02254000
   BIN2ASC(IF LTYPE=0 THEN 0D         << HDR1 >>                        02256000
      ELSE IF LTYPE=1 THEN NBLKS      << EOF1 >>                        02258000
      ELSE NBLKS+1D,L1NBLKS,6);       << EOV1 >>                        02260000
   MOVE L1SYSTEM := HPSYSTEM;                                           02262000
   IF VCB'LABTYP = 2 THEN                                               02264000
      BEGIN       << ANSI label >>                                      02266000
      IF VCB'LOCKWRD <> " " THEN L1ACC := %230;                         02268000
      END                                                               02270000
   ELSE                                                                 02272000
      BEGIN      << IBM >>                                              02274000
      L1ACC := "0";                                                     02276000
      CTRANSLATE(2,BTLABEL,,80);                                        02278000
      END;                                                              02280000
   ATTIOS(WRITE);                                              <<02689>>02282000
                                                                        02286000
 << Write HDR2 - EOF2 - EOV2  >>                                        02288000
                                                                        02290000
   TLABEL := "  ";                                                      02292000
   MOVE TLABEL(1) := TLABEL,(39);                                       02294000
   L1TYPE := LTYPECODE(LTYPE)+1D;                                       02296000
   L2RFMT := BYTE(FTYPECODE(FOPFTYPE));                                 02298000
   IF BLKSIZE < 1 THEN BLKSIZE := -BLKSIZE                              02300000
      ELSE BLKSIZE := BLKSIZE*2;       << make +bytes >>                02302000
   IF RECSIZE < 1 THEN RECSIZE := -RECSIZE                              02304000
      ELSE RECSIZE := RECSIZE*2;                                        02306000
   IF LOGICAL(RECSIZE) THEN                                             02308000
      BEGIN    << Round up rec size if block fact > 1. >>               02310000
      IF BLKSIZE <> RECSIZE THEN                                        02312000
         RECSIZE := RECSIZE+1;                                          02314000
      END;                                                              02316000
   BIN2ASC(DOUBLE(BLKSIZE),L2BSIZE,5);                                  02318000
   BIN2ASC(DOUBLE(RECSIZE),L2RSIZE,5);                                  02320000
   IF VCB'LABTYP = 2 THEN                                               02322000
      BEGIN       << ANSI label, with HP features. >>                   02324000
      MOVE L2LOCK := VCB'LOCKWRD,(8);                                   02326000
      L2FTYPE := BYTE("B"-VCB'ASCII);                                   02328000
      IF FOPCCTL THEN L2CCTL := "C";                                    02330000
      MOVE L2BUFOFF := "00";                                            02332000
      END                                                               02334000
   ELSE                                                                 02336000
      BEGIN        << IBM label. >>                                     02338000
      L2DSPOSN := IF LTYPE = 0 THEN "0" ELSE IF LTYPE = 2 THEN "1"      02340000
         ELSE "1";     << needs more >>                                 02342000
      L2BLKATT := IF BLKSIZE = RECSIZE THEN " " ELSE "B";               02344000
      CTRANSLATE(2,BTLABEL,,80);                                        02346000
      END;                                                              02348000
   ATTIOS(WRITE);                                              <<02689>>02350000
   END;      << procedure WRITELAB >>                                   02354000
$PAGE " CHECK1 "                                                        02356000
LOGICAL PROCEDURE CHECK1(LTBUF);                                        02358000
LOGICAL ARRAY LTBUF;                                                    02360000
   OPTION INTERNAL;                                            <<02621>>02362000
   BEGIN                                                                02364000
                                                                        02366000
<< Called from REELSWITCH, CHECKUL, and POSITION to                     02368000
read and validate HDR1, EOF1, and EOV1.  Returns:                       02370000
         =-1 - EOF                                                      02372000
         =0  - HDR1 label                                               02374000
         =1  - EOF1 label                                               02376000
         =2  - EOV1 label                                               02378000
         =3  - VOL1 label  [FCONTROL REWIND]                            02380000
         =4  - violation or none of the above                           02382000
         =5  - UVL label                                         MP.68  02384000
DB must be at the stack.                    >>                          02386000
                                                                        02388000
   LOGICAL RESULT=CHECK1;                                               02390000
   LOGICAL LDEV;                                                        02392000
      BUILDLCB;                                                         02394000
   LOGICAL ARRAY LABEL1(0:LBLSIZE-1) =Q;                                02396000
      DOUBLE L1TYPE = LABEL1;                                           02398000
      BYTE ARRAY BTLABEL(*)=LABEL1;                                     02400000
   EQUATE FLAGS=1;                                                      02402000
                                                                        02404000
 << Begin execution >>                                                  02406000
                                                                        02408000
   CC := CCE;                                                           02410000
   LDEV := LCB'LDEV;                                                    02412000
   TOS := ATTACHIO(LDEV,0,0,@LABEL1,READ,LBLSIZE,0,0,FLAGS);            02414000
   DEL;                                                                 02416000
   IF S0STAT=EOFSTAT THEN                                               02418000
      BEGIN     << Tapemark: end of vol set >>                          02420000
      DEL;                                                              02422000
      CC := CCG;     << report EOF. >>                                  02424000
      RESULT := -1;                                                     02426000
      GO OUTD;                                                          02428000
      END;                                                              02430000
   IF TOS.(13:3) <> 1 THEN                                              02432000
      BEGIN                                                             02434000
      CC := CCL;     << report Error. >>                                02436000
      RESULT := 2;                                                      02438000
      GO OUTD;                                                          02440000
      END;                                                              02442000
   IF LCB'LABTYP = 3 THEN   << IBM >>                                   02444000
      CTRANSLATE(1,BTLABEL,,80);    << to ASCII >>                      02446000
   IF L1TYPE="HDR1" THEN TOS := 0                                       02448000
   ELSE IF L1TYPE="EOF1" THEN TOS := 1                                  02450000
   ELSE IF L1TYPE="EOV1" THEN TOS := 2                                  02452000
   ELSE IF L1TYPE="VOL1" THEN TOS := 3                                  02454000
   ELSE IF BTLABEL="UVL" THEN TOS := 5                         <<02621>>02456000
   ELSE TOS := 4;                                                       02458000
   RESULT := S0;                                                        02460000
   IF TOS < 3 THEN                                                      02462000
      BEGIN       << HDR1/EOF1/EOV1 >>                                  02464000
      MOVE LCB'FNAME := L1FNAME,(17);                                   02466000
      MOVE LCB'VSETID := L1VSETID,(6);                                  02468000
      LCB'HP := IF L1SYSTEM = HPSYSTEM AND (LCB'LABTYP = 2)    <<02690>>02470000
         THEN 1 ELSE 0;                                        <<02690>>02472000
      LCB'LOCKFLG := IF LCB'HP AND (L1ACC=%230) THEN 1 ELSE 0;          02474000
      LCB'CDATE := BINARY'(L1CDAY,3);                                   02476000
      LCB'CDATE.(0:7) := BINARY'(L1CYR,2);                              02478000
      LCB'EXDATE := BINARY'(L1XDAY,3);                                  02480000
      LCB'EXDATE.(0:7) := BINARY'(L1XYR,2);                             02482000
      LCB'FSEQ := BINARY'(L1FSEQ,4);                                    02484000
      LCB'REEL := BINARY'(L1REEL,4);                                    02486000
      END;                                                              02488000
OUTD:                                                                   02490000
   END;      << procedure CHECK1 >>                                     02492000
$PAGE " CREATETLTENT "                                                  02494000
INTEGER PROCEDURE CREATETLTENT(FMSG,ID,FNUM,ACCESS,DENSITY);   <<02563>>02496000
   VALUE FNUM,ACCESS,DENSITY;                                  <<02563>>02498000
   BYTE ARRAY FMSG;                                                     02500000
   ARRAY ID;                                                            02502000
   INTEGER FNUM,ACCESS,DENSITY;                                <<02563>>02504000
   OPTION UNCALLABLE;                                                   02506000
                                                                        02508000
<<  Called from FOPEN to get tape label parameters from the             02510000
Forms message or from the file equation, and make a Volume              02512000
entry in the tape label table.  If no volume ID is specified,           02514000
operator will be asked for a volume ID.  If the first open for          02516000
this volume set, a new file entry will be made in the tape label        02518000
table; otherwise the entry is updated.  Parameters:                     02520000
   FMSG  - Forms msg, e.g. ".VSET01,ANS,12/3/80,NEXT;"                  02522000
   ID  - file name and lockword, as supplied to FOPEN.                  02524000
   FNUM - File number (AFT index)                                       02526000
   ACCESS - Access type (AOPTIONS.(12:4))                               02528000
   DENSITY - Density requested by user (internal form)           MP.60  02530000
                                                                        02532000
Returns 0 if OK, otherwise error number.  DB at stack. >>               02534000
                                                                        02536000
                                                                        02538000
BEGIN                                                                   02540000
   LOGICAL VTADDR;                                                      02542000
   INTEGER SCODE,IX,IXD;                                                02544000
   INTEGER LGTH;                                                        02546000
   LOGICAL PINNO,LABELTYPE;                                             02548000
   LOGICAL VSETOP;                                                      02550000
   LOGICAL EXDATE,SEQTYPE,FSEQ;                                         02552000
   INTEGER RESULT = CREATETLTENT;                                       02554000
   DOUBLE VTBOUNDS;                                                     02556000
      LOGICAL VTBASE = VTBOUNDS;                                        02558000
      LOGICAL VTTOP = VTBOUNDS+1;                                       02560000
   INTEGER ARRAY BUFFER(0:12);                                          02562000
      BYTE ARRAY BBUF(*) = BUFFER;                                      02564000
   INTEGER ARRAY REPLY(0:2) =Q;                                         02566000
      BYTE ARRAY REPLYB(*) =REPLY;                                      02568000
   INTEGER ARRAY VOLSETID(0:5);                                         02570000
      BYTE ARRAY BVSETID(*) = VOLSETID;                                 02572000
   BYTE ARRAY BFNAME(0:17);                                             02574000
   LOGICAL ARRAY VTBUF(0:VTESIZE-1) =Q;                                 02576000
      BUILDVCB;                                                         02578000
   BYTE ARRAY BID(*) = ID;                                              02580000
                                                                        02582000
 << Begin execution >>                                                  02584000
                                                                        02586000
   IF ACCESS = 3 THEN                                                   02590000
      BEGIN       << APPEND - illegal. >>                               02592000
      RESULT := LBTAPPEND;                                              02594000
      GO ENDZ;                                                          02596000
      END;                                                              02598000
   IX := 0;       << index into forms message >>                        02600000
   WHILE FMSG(IX) <> "." DO                                             02602000
      BEGIN       << Skip anything preceding the "." >>                 02604000
      IX := IX+1;                                                       02606000
      IF IX > 49 THEN GO ERRF;                                          02608000
      END;                                                              02610000
   PINNO := (ABSOLUTE(CPCB)-ABSOLUTE(PCBBASE))/PCBSIZE;                 02612000
   LABELTYPE := 2;      << default: ANSI >>                             02614000
   EXDATE := 0;                                                         02616000
   SEQTYPE := 1;        << NEXT >>                                      02618000
   FSEQ := 0;                                                           02620000
                                                                        02622000
<< Get parms from Forms Message here >>                                 02624000
                                                                        02626000
   MOVE BVSETID := "      ";                                            02628000
   IX := IX+1;          << skip over "." >>                             02630000
   IXD := 0;                                                            02632000
   WHILE IXD < 6 DO                                                     02634000
      BEGIN       << get Volume set ID >>                               02636000
      TOS := FMSG(IX);                                                  02638000
      IF NOT(" " <= S0 <= %176) THEN GO ERRF;                  <<02648>>02640000
      IF S0 = ";" OR S0 = "," THEN GO ELABN;  << end >>        <<02648>>02642000
      BVSETID(IXD) := TOS;                                              02644000
      IX := IX+1;                                                       02646000
      IXD := IXD+1;                                                     02648000
      END;                                                              02650000
   TOS := 0;                                                   <<02648>>02652000
ELABN:                                                                  02654000
   DEL;                                                        <<02648>>02656000
   IF IXD = 0 THEN                                                      02658000
      BEGIN    << No vol set ID; request it >>                          02660000
      MOVE BUFFER :=                                                    02662000
         "Volume ID for XXXXXXXX";                                      02664000
      MOVE BBUF(14) := BID,(8);    << copy file name >>                 02666000
      LGTH := PRINTOPREPLY(BUFFER,11,0,REPLY,-6);                       02668000
<< Need to validate input. >>                                           02670000
      MOVE BVSETID := REPLYB,(LGTH);                                    02672000
      END;      << request vol set ID >>                                02674000
   IF FMSG(IX) = ";" THEN GO CHECKVS;    << default all. >>             02676000
   IF FMSG(IX) <> "," THEN GO ERRF;                            <<02648>>02678000
   IX := IX+1;                                                          02680000
   IF FMSG(IX) = "," THEN GO GETDATE;   << labeltype omitted >>         02682000
   IF FMSG(IX) = "ANS" THEN                                             02684000
      IX := IX+3      << step to next , >>                              02686000
   ELSE                                                                 02688000
      BEGIN      << IBM >>                                              02690000
      IF FMSG(IX) <> "IBM" THEN GO ERRF;                                02692000
      IF ACCESS <> 0 THEN IF DISABL'IBM THEN              << !!<<02648>>02694000
         BEGIN RESULT := LBTIBMWRIT; GO ENDZ END;              <<02648>>02696000
      LABELTYPE := 3;    << type to IBM >>                              02698000
      IX := IX+3;      << step to next , >>                             02700000
      END;                                                              02702000
   IF FMSG(IX) = ";" THEN GO CHECKVS;                                   02704000
   IF FMSG(IX) <> "," THEN                                              02706000
      BEGIN    << Error in format >>                                    02708000
ERRF:                                                                   02710000
      RESULT := LBTSYNTAX;                                              02712000
      GO ENDZ;                                                          02714000
      DEBUG;      << dummy call >>                                      02716000
      END;                                                              02718000
                                                                        02720000
GETDATE:                                                                02722000
   IX := IX+1;                                                          02724000
   IF FMSG(IX) <> "," THEN                                              02726000
      BEGIN     << get length of date field >>                          02728000
      IXD := 0;                                                         02730000
      WHILE FMSG(IX+IXD) <> "," AND FMSG(IX+IXD) <> ";" DO              02732000
         BEGIN                                                          02734000
         IF IXD > 12 THEN GO ERRF;                                      02736000
         IXD := IXD+1;                                                  02738000
         END;                                                           02740000
   << IXD = length of date>>                                            02742000
      IF FMSG(IX) = "+" THEN                                            02744000
         BEGIN       << Get increment to today's date. >>               02746000
         EXDATE := CALENDAR;                                            02748000
         TOS := BINARY'(FMSG(IX+1),IXD-1);                              02750000
         IF <> THEN GO ERRF;                                            02752000
         TOS := TOS+EXDATE.(7:9);                                       02754000
         TOS := DOUBLE(TOS-1);                                          02756000
         TOS := 365;                                                    02758000
         ASMB(LDIV);                                                    02760000
         EXDATE.(7:9) := TOS+1;    << remainder = days >>               02762000
         EXDATE.(0:7) := TOS+EXDATE.(0:7);   << quot - yrs >>           02764000
         END                                                            02766000
      ELSE                                                              02768000
         BEGIN        << Expect DD/MM/YY >>                             02770000
         IF IXD < 5 THEN GO ERRF;                                       02772000
         IF FMSG(IX) = "00/00/00" THEN GO BUMP;                         02774000
         EXDATE := CONVERTDATE(FMSG(IX));                               02776000
         IF <> THEN GO ERRF;   << invalid date. >>                      02778000
         END;                                                           02780000
      IF FMSG(IX+IXD) = ";" THEN GO CHECKVS;                            02782000
BUMP: IX := IX+IXD;                                                     02784000
      END;    << convert date >>                                        02786000
                                                                        02788000
  << Get here to get seq type or # >>                                   02790000
                                                                        02792000
   IX := IX+1;   << step past , >>                                      02794000
   IXD := 0;     << Measure length of sequence field >>                 02796000
   WHILE IXD < 4 AND FMSG(IX+IXD) <> ";" AND                            02798000
      FMSG(IX+IXD) <> "," DO IXD := IXD+1;                              02800000
   IF IXD=0 OR FMSG(IX)= "NEXT" THEN  << SEQTYPE := 1 >>                02802000
   ELSE IF FMSG(IX) = "ADDF" THEN                                       02804000
      BEGIN                                                             02806000
      IF ACCESS = 0 THEN                                                02808000
         BEGIN           << Lose: need Write access. >>                 02810000
         RESULT := LBTINVOP;                                            02812000
         GO ENDZ;                                                       02814000
         END;                                                           02816000
      SEQTYPE := 2;                                                     02818000
      END                                                               02820000
   ELSE                                                                 02822000
      BEGIN      << Match file sequence nr. >>                          02824000
      SEQTYPE := 3;                                                     02826000
      FSEQ := BINARY'(FMSG(IX),IXD);                                    02828000
      IF < THEN GO ERRF;                                                02830000
      IF FSEQ = 0 THEN SEQTYPE := 0;  << match filename. >>             02832000
      END;                                                              02834000
                                                                        02836000
<< Search for volume set entry matching specified volume ID.            02838000
If one is found, this is an open of a file on the volume set. >>        02840000
                                                                        02842000
CHECKVS:                                                                02844000
   VSETOP := FALSE;                                                     02846000
   SCODE := GETSIR(TLTSIR);                                             02848000
   GETXDSW(VTBOUNDS,TLTDST,XVTBASE,2);                                  02850000
   VTADDR := VTBASE;                                                    02852000
   WHILE VTADDR < VTTOP DO                                              02854000
      BEGIN                                                             02856000
      GETXDSW(VTBUF,TLTDST,VTADDR,VTESIZE);                             02858000
      IF INUSE AND (VCB'FNUM=0) AND                                     02860000
         (VCB'PIN=PINNO) AND (VCB'LABTYP=LABELTYPE) AND                 02862000
         BVSETID=VCB'VSETID,(6) THEN GO OLDVSET;                        02864000
      VTADDR := VTADDR+VTESIZE;                                         02866000
      END;                                                              02868000
                                                                        02870000
<< Volume set being opened; need new entry. >>                          02872000
                                                                        02874000
   VTADDR := 0;         << forces new entry >>                          02876000
   VSETOP := TRUE;                                                      02878000
   VTBUF := 0;          << zero binary part >>                          02880000
   MOVE VTBUF(1) := VTBUF,(6);                                          02882000
   VTBUF(7) := "  ";    << blank ASCII part >>                          02884000
   MOVE VTBUF(8) := VTBUF(7),(18);                                      02886000
   VCB'LDEV := 0;                                              <<02648>>02888000
   VCB'VSETOPEN := 1;   << 1st open of volume set >>           <<02563>>02890000
   MOVE VCB'VOLID := BVSETID,(6);                                       02892000
   MOVE VCB'VSETID := BVSETID,(6);    << vset ID in new ent >>          02894000
   VCB'FSEQ := FSEQ;                                                    02896000
   VCB'LABTYP := LABELTYPE;                                             02898000
<< Density is a volset attribute. Set only on 1st open. >>     <<02563>>02900000
   VCB'DENSITY := DENSITY;                                     <<02563>>02902000
OLDVSET:                                                                02904000
   MOVE BFNAME := BID,(8);       << file name >>                        02906000
   BFNAME(8) := IF VCB'LABTYP=3 THEN " " ELSE ".";             <<02662>>02908000
   MOVE BFNAME(9) := BID(8),(8);   << group name >>                     02910000
   BFNAME(17) := " ";                                                   02912000
   MOVE VCB'FNAME := BFNAME,(18);   << file name >>                     02914000
   MOVE VCB'LOCKWRD := BID(24),(8);   << lockword >>                    02916000
   VCB'PIN := PINNO;                                                    02918000
   VCB'FNUM := FNUM;                                                    02920000
                                                                        02922000
   VCB'EXDATE := EXDATE;                                                02924000
   VCB'SEQTYP := SEQTYPE;                                               02926000
   IF SEQTYPE=3 THEN VCB'FSEQ := FSEQ;                                  02928000
   VCB'REEL := 1;     << All files begin with this >>                   02930000
   IF VCB'FSEQ = 0 THEN VCB'FSEQ := 1;                                  02932000
   VCB'WRITE := IF ACCESS > 0 THEN 1 ELSE 0;                            02934000
   VCB'LNKWAIT := 1;     << flag for LINKLABEL >>                       02936000
   POSTVTENT(VTBUF,VTADDR,SCODE);                                       02938000
   IF < THEN RESULT := LBTOFLOW;                                        02940000
   IF VSETOP THEN LOGIT(VTBUF);    << write Log record >>               02942000
ENDZ:                                                                   02944000
   END;     << procedure CREATETLTENT >>                                02946000
$PAGE " STORE'DENSITY "                                        <<02563>>02948000
PROCEDURE STORE'DENSITY(LDEV,DENSITY,MODE);                    <<02563>>02950000
   VALUE LDEV,MODE;                                            <<02563>>02952000
   INTEGER LDEV,MODE;                                          <<02563>>02954000
   ARRAY DENSITY;                                              <<02563>>02956000
   OPTION PRIVILEGED,UNCALLABLE;                               <<02563>>02958000
                                                               <<02563>>02960000
COMMENT                                                        <<02563>>02962000
                                                               <<02563>>02964000
   This procedure posts density information into the density   <<02563>>02966000
data structure.  The procedure can be called in three modes:   <<02563>>02968000
                                                               <<02563>>02970000
   MODE = 0, FOPEN-type call.  Although DENSITY is defined as  <<02563>>02972000
      an array, in this type of call it is actually an integer <<02563>>02974000
      by reference.  It contains the user requested density    <<02563>>02976000
      for the tape LDEV.  If this is the first call of this    <<02563>>02978000
      type -- that is REQUEST'DENSITY contains a null value -- <<02563>>02980000
      and the "default" density was requested, then the        <<02563>>02982000
      tape request is set to 6250 BPI.  In all other cases,    <<02563>>02984000
      default density requests are ignored.                    <<02563>>02986000
      Called by:  FOPEN.                                       <<02563>>02988000
   MODE = 1, AVR-type call.  Generally, the caller has just    <<02563>>02990000
      finished AVR on the device LDEV.  DENSITY contains the   <<02563>>02992000
      results of a "read status" request to the mag tape dri-  <<02563>>02994000
      ver.  This procedure then interprets the status bytes and<<02563>>02996000
      stores the actual tape density into the data structure.  <<02563>>02998000
      Called by:  DEVREC and RECOGNIZE (in LABSEG).            <<02563>>03000000
   MODE = 2, DEALLOCATE-type call.  The density data structure <<02563>>03002000
      is to be reinitialized.  This call is made during the    <<02563>>03004000
      final release of a tape drive by its current owner.      <<02563>>03006000
      DENSITY for this call is a dummy.                        <<02563>>03008000
      Called by:  DEALLOCATE, REELSWITH, and CHECKUL.          <<02689>>03010000
                                                               <<02563>>03012000
   CALLER'S RESPONSIBILITIES:                                  <<02563>>03014000
   1)  DB must be at the stack.                                <<02563>>03016000
   2)  The caller should ensure that LDEV is a mag tape drive. <<02563>>03018000
                                                               <<02563>>03020000
;    << end of comment >>                                      <<02563>>03022000
                                                               <<02563>>03024000
BEGIN                                                          <<02563>>03026000
INTEGER                                                        <<02563>>03028000
   LDT'DENW,      << LDT entry density information >>          <<02563>>03030000
   DENW'INDEX,    << Index into LDT to get LDT'DENW >>         <<02563>>03032000
   SAVESIR;                                                    <<02563>>03034000
DEFINE                                                         <<02563>>03036000
   STAT'6250  = DENSITY.(8:1)#;  << Density status bit >>      <<02563>>03038000
                                                               <<02563>>03040000
   << Only continue if tape drive is variable density. >>      <<02563>>03042000
   IF NOT (VARIABLE'DENSITY) THEN RETURN;                      <<02563>>03044000
                                                               <<02563>>03046000
   SAVESIR := GETSIR(LDTSIR);                                  <<02563>>03048000
                                                               <<02563>>03050000
   << Get density info from LDT entry >>                       <<02563>>03052000
   DENW'INDEX := LDEV*LDTENTRY + DENSITYW;                     <<02563>>03054000
   GETXDSW(LDT'DENW,LDTDST,DENW'INDEX,1);                      <<02563>>03056000
                                                               <<02563>>03058000
   CASE MODE OF                                                <<02563>>03060000
      BEGIN                                                    <<02563>>03062000
                                                               <<02563>>03064000
      << FOPEN mode - DENSITY is the user requested dens. >>   <<02563>>03066000
      IF DENSITY <> DEN'DEFAULT THEN                           <<02563>>03068000
         REQUEST'DENSITY := DENSITY  << Specific request >>    <<02563>>03070000
      ELSE                                                     <<02563>>03072000
         << If 1st request, default is 6250 BPI. >>            <<02563>>03074000
         << Else, default is no change. >>                     <<02563>>03076000
         IF REQUEST'DENSITY = NULL'REQ THEN                    <<02563>>03078000
            REQUEST'DENSITY := DEN'6250;                       <<02563>>03080000
                                                               <<02563>>03082000
      << AVR mode - DENSITY contains status bytes >>           <<02563>>03084000
      TAPE'DENSITY := IF NOT STAT'6250 THEN DEN'1600           <<02563>>03086000
                                       ELSE DEN'6250;          <<02563>>03088000
                                                               <<02563>>03090000
      << FREE mode - DENSITY is a dummy.  Clear fields. >>     <<02563>>03092000
      BEGIN                                                    <<02563>>03094000
      REQUEST'DENSITY := NULL'REQ;                             <<02563>>03096000
      TAPE'DENSITY := NULL'REQ;                                <<02563>>03098000
      END;                                                     <<02563>>03100000
                                                               <<02563>>03102000
      END;   << of case >>                                     <<02563>>03104000
                                                               <<02563>>03106000
   << Write word back >>                                       <<02563>>03108000
   PUTXDSW(LDTDST,DENW'INDEX,LDT'DENW,1);                      <<02563>>03110000
                                                               <<02563>>03112000
   RELSIR(LDTSIR,SAVESIR);                                     <<02563>>03114000
                                                               <<02563>>03116000
END;     << of STORE'DENSITY >>                                <<02563>>03118000
$PAGE "  CHECK'AVR'STATUS"                                     <<02722>>03120000
INTEGER PROCEDURE CHECK'AVR'STATUS(LDEV,STATUS,IGNORE);        <<02722>>03122000
   VALUE LDEV,STATUS,IGNORE;                                   <<02722>>03124000
   INTEGER LDEV,STATUS;                                        <<02722>>03126000
   LOGICAL IGNORE;                                             <<02722>>03128000
   OPTION PRIVILEGED,UNCALLABLE;                               <<02722>>03130000
                                                               <<02722>>03132000
COMMENT                                                        <<02722>>03134000
                                                               <<02722>>03136000
   This procedure examines the status returned by ATTACHIO     <<02722>>03138000
during Automatic Volume Recognition.  If there was an error,   <<02722>>03140000
an appropriate error message is printed and the procedure      <<02722>>03142000
return tells the caller what kind of error occured.            <<02722>>03144000
                                                               <<02722>>03146000
INPUT:                                                         <<02722>>03148000
   LDEV   -- the logical device in question.                   <<02722>>03150000
   STATUS -- the last 8 bits of ATTACHIO's status return.      <<02722>>03152000
   IGNORE -- During AVR, certain errors which occur as the     <<02722>>03154000
             result of a READ should be ignored.  For example, <<02722>>03156000
             a tape parity error indicates a problem with the  <<02722>>03158000
             tape surface.  Although the tape cannot be read,  <<02722>>03160000
             it should still be made available to the system   <<02722>>03162000
             as an unlabelled tape.  If IGNORE is TRUE, the    <<02722>>03164000
             following errors should be ignored:               <<02722>>03166000
                                                               <<02722>>03168000
             RUNAWAY     - %103                                <<02722>>03170000
             TRANS'ERROR -  %14                                <<02722>>03172000
             TIMING'ERR  -  %34                                <<02722>>03174000
             UNIT'FAIL   -  %54                                <<02722>>03176000
             PARITY'ERR  -  %74                                <<02722>>03178000
                                                               <<02722>>03180000
             For now, all errors are included because it is not<<02722>>03182000
             clear which errors should be considered fatal.    <<02722>>03184000
                                                               <<02722>>03186000
PROCEDURE RETURN:                                              <<02722>>03188000
                                                               <<02722>>03190000
   0 -- No error.                                              <<02722>>03192000
   1 -- Error indicating power problems.  (No console message) <<02722>>03194000
   2 -- Fatal error.                                           <<02722>>03196000
   3 -- Ignored error.  (Only returned if IGNORE = TRUE.)      <<02722>>03198000
                                                               <<02722>>03200000
DB MUST BE AT STACK.                                           <<02722>>03202000
                                                               <<02722>>03204000
;   << end of comment >>                                       <<02722>>03206000
                                                               <<02722>>03208000
BEGIN                                                          <<02722>>03210000
   INTEGER                                                     <<02722>>03212000
      RESULT = CHECK'AVR'STATUS,   << Procedure return >>      <<02722>>03214000
      LENGTH;                                                  <<02722>>03216000
   BYTE ARRAY                                                  <<02722>>03218000
      STATBUF(0:6);                                            <<02722>>03220000
                                                               <<02722>>03222000
                                                               <<02722>>03224000
   IF STATUS.(13:3) = 1 THEN                                   <<02722>>03226000
      BEGIN                                                    <<02722>>03228000
      RESULT := 0;   << No error >>                            <<02722>>03230000
      RETURN;                                                  <<02722>>03232000
      END;                                                     <<02722>>03234000
                                                               <<02722>>03236000
   IF STATUS = PFAIL'ABORT OR                                  <<02722>>03238000
     STATUS = POWER'UP  THEN                                   <<02722>>03240000
      BEGIN                                                    <<02722>>03242000
      RESULT := 1;   << Power problem >>                       <<02722>>03244000
      RETURN;                                                  <<02722>>03246000
      END;                                                     <<02722>>03248000
                                                               <<02722>>03250000
   IF IGNORE THEN                                              <<02722>>03252000
      BEGIN                                                    <<02722>>03254000
                                                               <<02722>>03256000
<< Eventually, the following IF FALSE THEN clause will >>      <<02722>>03258000
<< determine those status returns which are to be con- >>      <<02722>>03260000
<< sidered fatal even if IGNORE is TRUE. >>                    <<02722>>03262000
                                                               <<02722>>03264000
      IF FALSE THEN                                            <<02722>>03266000
         IGNORE := FALSE                                       <<02722>>03268000
      ELSE                                                     <<02722>>03270000
         BEGIN                                                 <<02722>>03272000
   << Don't report EOF or tape runaway as an error.  They >>   <<03581>>03274000
   << are expected status returns during AVR reads. >>         <<03581>>03276000
         IF STATUS <> EOFSTAT LAND STATUS <> RUNAWAY THEN      <<03581>>03278000
            BEGIN                                              <<02722>>03280000
            LENGTH := ASCII(STATUS,8,STATBUF);                 <<02722>>03282000
            STATBUF(6) := 0;   << GENMSG terminator >>         <<02722>>03284000
            GENMSG(1,IGNORE'ERR,%10000,LDEV,                   <<02722>>03286000
                                @STATBUF(6-LENGTH),,,,0);      <<02722>>03288000
            END;                                               <<02722>>03290000
         END;                                                  <<02722>>03292000
                                                               <<02722>>03294000
      END;   << of IGNORE >>                                   <<02722>>03296000
                                                               <<02722>>03298000
   IF IGNORE THEN                                              <<02722>>03300000
      RESULT := 3                                              <<02722>>03302000
   ELSE                                                        <<02722>>03304000
      BEGIN   << Report fatal I/O error >>                     <<02722>>03306000
      RESULT := 2;                                             <<02722>>03308000
      REPORT'IOERROR(LDEV,STATUS);                             <<02722>>03310000
      END;                                                     <<02722>>03312000
                                                               <<02722>>03314000
END;   << of CHECK'AVR'STATUS >>                               <<02722>>03316000
$PAGE " AVREC "                                                         03318000
LOGICAL PROCEDURE AVREC(LDEV,BUFF,COUNT,CMD);                           03320000
  VALUE LDEV,COUNT,CMD;                                                 03322000
  INTEGER LDEV,COUNT,CMD;                                               03324000
  ARRAY BUFF;                                                           03326000
  OPTION UNCALLABLE;                                                    03328000
                                                                        03330000
<<  DEVREC reads the first record on a newly mounted tape,              03332000
then calls AVREC.  We see if the record is a tape label;                03334000
if so, and if there is a process waiting for this tape, the             03336000
process is re-started by pulling its entry out of the RIT.              03338000
AVREC can be called twice: once to scan the volume label,               03340000
and then to scan the header label.  DB must be at the stack.            03342000
   COUNT - +words.                                                      03344000
   CMD   - 1 if first call, 2 if second.                                03346000
Returns TRUE if done; FALSE if second call is needed.  The              03348000
two-call kluge is needed because DEVREC does unblocked I/O              03350000
and can't be impeded while we do I/O.  Tape is rewound at final         03352000
exit.   >>                                                              03354000
                                                                        03356000
BEGIN                                                                   03358000
   LOGICAL VTADDR,LTADDR;                                               03360000
   LOGICAL RESULT = AVREC;                                              03362000
   DOUBLE VTBOUNDS;                                                     03364000
      LOGICAL VTBASE = VTBOUNDS;                                        03366000
      LOGICAL VTTOP = VTBOUNDS+1;                                       03368000
   LOGICAL ARRAY TLABEL(0:LBLSIZE-1) =Q;                                03370000
      BYTE ARRAY BLABEL0(*) = TLABEL;                                   03372000
      BYTE ARRAY BTLABEL(*) = TLABEL;                                   03374000
      DOUBLE LTYPE = TLABEL;                                            03376000
   ARRAY MSG(0:20);                                                     03378000
      BYTE ARRAY MSGB(*)=MSG;                                  <<1136>> 03380000
   LOGICAL ARRAY VTBUF(0:VTESIZE-1) =Q;                                 03382000
      BUILDVCB;                                                         03384000
   LOGICAL ARRAY LTBUF(0:LTESIZE-1) =Q;                                 03386000
      BUILDLCB;                                                         03388000
   LOGICAL SCODE;                                                       03390000
   LOGICAL EXDAY;                                                       03392000
                                                                        03394000
   TLABEL := "  ";                                                      03398000
   MOVE TLABEL(1) := TLABEL,(LBLSIZE-1);                                03400000
   MOVE TLABEL := BUFF,(COUNT);  << local copy, for no good reason >>   03402000
   SCODE := GETSIR(TLTSIR);                                             03404000
   LTADDR := GETLDEV(LDEV,LTBUF);                                       03406000
   IF < THEN TAPETROUBLE(TT7);                                 <<03581>>03408000
   VCB'FLAGS := 0;     << default >>                                    03410000
   VTADDR := LCB'VCB;                                                   03412000
   IF <> THEN                                                           03414000
      BEGIN      << A volume is associated with this drive. >>          03416000
      GETXDSW(VTBUF,TLTDST,VTADDR,VTESIZE);                             03418000
      END;                                                              03420000
   IF CMD >= 2 THEN GO TRYH1;                                           03422000
   LCB'FLAGS := LCB'FLAGS LAND %1000; << Leave Tape Bit >>     <<03581>>03424000
   LTBUF(2) := 0;      << first call: clear LDEV entry >>               03426000
   MOVE LTBUF(3) := LTBUF(2),(4);                                       03428000
   LTBUF(7) := "  ";                                                    03430000
   MOVE LTBUF(8) := LTBUF(7),(18);                                      03432000
   LCB'VCB := VTADDR;      << restore this word >>                      03434000
                                                                        03436000
<< Process VOL1 label, if present. >>                                   03438000
                                                                        03440000
   IF TLABEL(0)=%162726 AND TLABEL(1)=%151761 AND COUNT=40 THEN         03442000
      BEGIN       << EBCDIC "VOL1" >>                                   03444000
      LCB'LABTYP := 3;      << set to IBM >>                            03446000
      CTRANSLATE(1,TLABEL,,80);                                         03448000
      END                                                               03450000
   ELSE IF LTYPE="VOL1" THEN LCB'LABTYP := 2                            03452000
      ELSE GO NL;                                                       03454000
   MOVE LCB'VOLID := L0VOLID,(6);                                       03456000
   MOVE LCB'VSETID := L0VOLID,(6);  << default >>                       03458000
   GO POSTLCB;                                                          03460000
                                                                        03462000
<< Process HDR1 label. >>                                               03464000
                                                                        03466000
TRYH1:                                                                  03468000
   IF LCB'LABTYP=3 THEN CTRANSLATE(1,TLABEL,,80);                       03470000
   IF BLABEL0 = "UVL" THEN GO POSTLCB;  << ignore these >>              03472000
   RESULT := TRUE;      << don't read again. >>                         03474000
   IF LTYPE = "HDR1" THEN                                               03476000
      BEGIN                                                             03478000
      EXDAY := BINARY'(L1XDAY,3);         << Julian day >>              03480000
      EXDAY.(0:7) := BINARY'(L1XYR,2);    << year >>                    03482000
      LCB'EXDATE := EXDAY;                                              03484000
      LCB'REEL := BINARY'(L1REEL,4);                                    03486000
      LCB'FSEQ := BINARY'(L1FSEQ,4);                                    03488000
      MOVE LCB'VSETID := L1VSETID,(6);                                  03490000
      MOVE LCB'FNAME := L1FNAME,(17);                                   03492000
      LCB'HP := IF L1SYSTEM = HPSYSTEM AND (LCB'LABTYP = 2)    <<02662>>03494000
         THEN 1 ELSE 0;                                        <<02662>>03496000
      IF BTLABEL(68) = "B" THEN LCB'B5000 := 1;                         03498000
      END;                                                              03500000
   ATTACHIO(LDEV,0,0,0,5,0,0,0,%13);    << rewind >>                    03502000
   IF LCB'TAPE THEN SET'BOT'ON; <<Tape at Load point>>         <<03581>>03504000
                                                                        03506000
<< See if anyone wants this particular volume.  If REELSWITCH,          03508000
we can restart the user waiting on this LDEV.  If LINKLABEL,            03510000
we search the volume entries for one matching the volume. >>            03512000
                                                                        03514000
   IF VCB'RSWAIT THEN GO RESTART;                                       03516000
   GETXDSW(VTBOUNDS,TLTDST,XVTBASE,2);                                  03518000
   VTADDR := VTBASE;                                                    03520000
   WHILE VTADDR < VTTOP DO                                              03522000
      BEGIN         << LINKLABEL waiting? >>                            03524000
      GETXDSW(VTBUF,TLTDST,VTADDR,VTESIZE);                             03526000
      IF INUSE AND (VCB'LDEV=0) AND VCB'MNTWAIT AND                     03528000
          GOODREEL(VTBUF,LTBUF) THEN                           <<02648>>03530000
         BEGIN               << Match. >>                               03532000
         LCB'VCB := VTADDR;    << Link up >>                            03534000
         VCB'LDEV := LDEV;                                              03536000
RESTART: POSTVTENT(VTBUF,VTADDR,-1);                                    03538000
         REMRITENTRY(VCB'PIN);                                          03540000
         GO REPORT;                                                     03542000
         END;                                                           03544000
      VTADDR := VTADDR+VTESIZE;                                         03546000
      END;                                                              03548000
                                                                        03550000
<< No one is waiting for this volume, so just post the LDEV             03552000
entry.  >>                                                              03554000
<< 285 Vol ! mounted on LDEV# \  >>                                     03556000
                                                                        03558000
REPORT:                                                                 03560000
   MOVE MSGB := LCB'VOLID,(6);                                          03562000
   MOVE MSGB(6) := " (ANS) of ";                                        03564000
   IF LCB'LABTYP = 3 THEN MOVE MSGB(6) := " (IBM)";                     03566000
   IF LCB'VOLID <> LCB'VSETID,(6) THEN                                  03568000
      BEGIN       << Not first vol of vset >>                           03570000
      MOVE MSGB(16) := LCB'VSETID,(6);                                  03572000
      MSGB(22) := 0;                                                    03574000
      END                                                               03576000
   ELSE MSGB(12) := 0;   << Zero terminator for GENMSG >>               03578000
   GENMSG(1,285,%01000,@MSGB,LDEV,,,,0);                                03580000
                                                                        03582000
POSTLCB:                                                                03584000
   POSTVTENT(LTBUF,LTADDR,SCODE);                                       03586000
   RETURN;                                                              03588000
                                                                        03590000
<< Unlabelled tape: report, rewind, and exit. >>                        03592000
<< 286 Vol (unlabelled) mounted on LDEV# \ >>                           03594000
                                                                        03596000
NL:                                                                     03598000
   LCB'LABTYP := 1;      << unlabelled >>                               03600000
   RESULT := TRUE;                                                      03602000
   POSTVTENT(LTBUF,LTADDR,SCODE);                                       03604000
   ATTACHIO(LDEV,0,0,0,5,0,0,0,%13);    << Rewind >>                    03606000
   IF LCB'TAPE THEN SET'BOT'ON; <<Tape at load point>>         <<03581>>03608000
   IF VCB'RSWAIT THEN REMRITENTRY(VCB'PIN);                             03610000
   GENMSG(1,286,%10000,LDEV,,,,,0);                                     03612000
   END;      << procedure AVREC >>                                      03614000
$PAGE " RECOGNIZE "                                                     03616000
PROCEDURE RECOGNIZE(LDEV);                                              03618000
VALUE LDEV; INTEGER LDEV;                                               03620000
   OPTION UNCALLABLE;                                          <<03581>>03622000
                                                                        03624000
<< If a tape drive is on-line when the system comes up, there           03626000
will be no interrupt to cause AVR, so we call AVREC "by hand"           03628000
to see what's up. >>                                                    03630000
                                                                        03634000
   BEGIN                                                                03636000
   INTEGER CMD,COUNT;                                                   03638000
   INTEGER IOSTATW;                                                     03640000
   ARRAY TLABEL(0:39);                                                  03642000
                                                                        03644000
<< It is possible for DEVREC and RECOGNIZE to both be       >> <<02722>>03646000
<< attempting AVR on the same tape drive.  The state bits   >> <<02722>>03648000
<< in the LPDT tell whether DEVREC is working on the drive. >> <<02722>>03650000
<< If the device is unowned, setting the state bits to 3    >> <<02722>>03652000
<< will prevent DEVREC from working on the same drive.      >> <<02722>>03654000
                                                               <<02722>>03656000
   DISABLE;                                                    <<02722>>03658000
   IF LPDT(LDEV*LPDTENTRY + 1).STATE <> 0 THEN                 <<02722>>03660000
      BEGIN   << Some process (DEVREC?) owns drive. >>         <<02722>>03662000
      ENABLE;                                                  <<02722>>03664000
      CC := CCL;   << Indicate a problem >>                    <<02722>>03666000
      RETURN;                                                  <<02722>>03668000
      END;                                                     <<02722>>03670000
                                                               <<02722>>03672000
   LPDT(LDEV*LPDTENTRY + 1).STATE := 1;  <<Reserve drive>>     <<03581>>03674000
   ENABLE;                                                     <<02722>>03676000
                                                               <<02722>>03678000
START:                                                                  03682000
   ATTIO(LDEV,5);       << Insure Rewound for AVR >>                    03684000
   IOSTATW := X.(8:8);   << Pick up ATTACHIO status >>         <<02722>>03688000
                                                               <<02722>>03690000
   CASE CHECK'AVR'STATUS(LDEV,IOSTATW,FALSE) OF                <<02722>>03692000
      BEGIN                                                    <<02722>>03694000
                                                               <<02722>>03696000
      ;              << 0 - OK.  Continue >>                   <<02722>>03698000
                                                               <<02722>>03700000
      GO START;      << 1 - Restart on power problems >>       <<02722>>03702000
                                                               <<02722>>03704000
      GO IO'ERROR;   << 2 - I/O error.  Quit >>                <<02722>>03706000
                                                               <<02722>>03708000
      ;              << 3 - Can't happen, IGNORE = FALSE >>    <<02722>>03710000
                                                               <<02722>>03712000
      END;   << of case statement >>                           <<02722>>03714000
                                                               <<02722>>03716000
   CMD := 0;                                                            03718000
LOOP:                                                                   03720000
   CMD := CMD+1;                                                        03722000
   TOS := ATTACHIO(LDEV,0,0,@TLABEL,READ,40,0,0,1);   <<Read>>          03724000
   COUNT := TOS;                                                        03726000
   IOSTATW := TOS.(8:8);                                                03728000
                                                               <<02563>>03736000
   CASE CHECK'AVR'STATUS(LDEV,IOSTATW,TRUE) OF                 <<02722>>03740000
      BEGIN                                                    <<02722>>03742000
                                                               <<02722>>03744000
      ;              << 0 - OK.  Continue >>                   <<02722>>03746000
                                                               <<02722>>03748000
      GO START;      << 1 - Restart on power problems >>       <<02722>>03750000
                                                               <<02722>>03752000
      GO IO'ERROR;   << 2 - I/O error.  Quit >>                <<02722>>03754000
                                                               <<02722>>03756000
      COUNT := 0;    << 3 - Ignored error >>                   <<02722>>03758000
                                                               <<02722>>03760000
      END;   << of case statement >>                           <<02722>>03762000
                                                               <<02722>>03764000
   IF NOT AVREC(LDEV,TLABEL,COUNT,CMD)                                  03766000
      THEN GO LOOP;                                                     03768000
                                                               <<02563>>03770000
   << AVREC has taken care of marking the BOT bit for all >>   <<02563>>03772000
   << tape drives.  Now, if variable density drive, must  >>   <<02563>>03774000
   << determine density of tape on drive.                 >>   <<02563>>03776000
                                                               <<02563>>03778000
   IF (VARIABLE'DENSITY) THEN                                  <<02563>>03780000
      BEGIN    << Get status of tape drive >>                  <<02563>>03782000
                                                               <<02563>>03784000
      TOS := ATTACHIO(LDEV,0,0,@TLABEL,READ'STATUS,-5,0,0,1);  <<02563>>03786000
      DEL;                                                     <<02563>>03788000
      IOSTATW := TOS.(8:8);                                    <<02563>>03790000
                                                               <<02563>>03792000
      CASE CHECK'AVR'STATUS(LDEV,IOSTATW,FALSE) OF             <<02722>>03796000
         BEGIN                                                 <<02722>>03798000
                                                               <<02722>>03800000
         ;              << 0 - OK.  Continue >>                <<02722>>03802000
                                                               <<02722>>03804000
         GO START;      << 1 - Restart on power problems >>    <<02722>>03806000
                                                               <<02722>>03808000
         GO IO'ERROR;   << 2 - I/O error.  Quit >>             <<02722>>03810000
                                                               <<02722>>03812000
         ;              << 3 - Can't happen, IGNORE = FALSE >> <<02722>>03814000
                                                               <<02722>>03816000
         END;   << of case statement >>                        <<02722>>03818000
                                                               <<02722>>03820000
      << Put density in data structure. >>                     <<02722>>03822000
      STORE'DENSITY(LDEV,TLABEL,1);                            <<02722>>03824000
                                                               <<02722>>03826000
      END;   << of variable density drive. >>                  <<02722>>03828000
                                                               <<02722>>03830000
   SETOWNED(LDEV,0);   << Done with pseudo-DEVREC >>           <<02722>>03832000
   CC := CCE;                                                  <<02722>>03834000
   RETURN;             << Only good exit from procedure >>     <<02722>>03836000
                                                               <<02722>>03838000
                                                               <<02722>>03840000
IO'ERROR:      << Branch to here on I/O error >>               <<02722>>03842000
                                                               <<02722>>03844000
   CLEANLDEV(LDEV);      << Zero out TLT entry >>              <<02722>>03846000
   ATTACHIO(LDEV,0,0,0,DCLOSE,0,0,0,%13);                      <<02722>>03848000
   SETOWNED(LDEV,0);     << Release tape drive >>              <<02722>>03850000
   CC := CCL;                                                  <<02722>>03852000
                                                               <<02722>>03854000
   END;       << procedure RECOGNIZE >>                                 03856000
$PAGE  " LINKLABEL "                                                    03858000
INTEGER PROCEDURE LINKLABEL(LDEVN,ACCESS);                              03860000
 VALUE ACCESS;                                                          03862000
 INTEGER LDEVN,ACCESS;                                                  03864000
  OPTION UNCALLABLE;                                                    03866000
  COMMENT                                                      <<03581>>03868000
                                                               <<03581>>03870000
     Called from ASKOP in ALLOCATE to link the file to the     <<03581>>03872000
a mount device in the tape label table.  If the volume is not  <<03581>>03874000
mounted, request is issued and the process awaits a reply or   <<03581>>03876000
for the volume to be mounted.  If the operator replies a       <<03581>>03878000
logical device the C field in word 5 of the VCB is set so      <<03581>>03880000
that the VOL1 label will be written later provided that        <<03581>>03882000
device is a tape (or serial disc), the tape is unlabeled or    <<03581>>03884000
expired, and is open for write.  The LDEV is returned.         <<03581>>03886000
                                                               <<03581>>03888000
DB is at the stack.                                            <<03581>>03890000
                                                               <<03581>>03892000
   ACCESS - depends on AOPTIONS.(12:4)                         <<03581>>03894000
    0 - read only                                              <<03581>>03896000
    1 - write only (write,write-save,append)                   <<03581>>03898000
    2 - read-write (read-write or update)                      <<03581>>03900000
                                                               <<03581>>03902000
Exit with tape at Load point.  FOPEN will call POSITION to     <<03581>>03904000
get to the required file.                                      <<03581>>03906000
;                                                              <<03581>>03908000
                                                                        03910000
   BEGIN                                                                03912000
   LOGICAL VTADDR,LTADDR;                                               03914000
   LOGICAL PINNO;                                                       03916000
   INTEGER SCODE,LDEV;                                                  03918000
      INTEGER RESULT = LINKLABEL;                                       03920000
   ARRAY LTBOUNDS(0:2) =Q;                                              03922000
      LOGICAL LTBASE = LTBOUNDS;                                        03924000
      LOGICAL LTTOP = LTBOUNDS+1;                                       03926000
      LOGICAL VTBASE = LTBOUNDS+1;                                      03928000
      LOGICAL VTTOP = LTBOUNDS+2;                                       03930000
   INTEGER ARRAY BUFFER(0:20);                                          03932000
      BYTE ARRAY BBUF(*) = BUFFER;                                      03934000
   INTEGER ARRAY REPLY(0:2) =Q;                                         03936000
      BYTE ARRAY REPLYB(*) =REPLY+1;   << Text of Reply >>              03938000
      INTEGER RCNT =REPLY;        << char count of Reply >>             03940000
   LOGICAL ARRAY VTBUF(0:VTESIZE-1) =Q;                                 03942000
      BUILDVCB;                                                         03944000
   LOGICAL ARRAY LTBUF(0:LTESIZE-1) =Q;                                 03946000
      BUILDLCB;                                                         03948000
   EQUATE REJECTED=3,                                                   03950000
        OKAY=2;                                                         03952000
                                                                        03954000
 << Find the VCB entry created by CREATETLTENT. >>                      03956000
                                                                        03958000
   RESULT := REJECTED;                                                  03960000
   PINNO := (ABSOLUTE(CPCB)-ABSOLUTE(PCBBASE))/PCBSIZE;                 03962000
   SCODE := GETSIR(TLTSIR);                                             03964000
   GETXDSW(LTBOUNDS,TLTDST,XLTBASE,3);                                  03966000
   VTADDR := VTBASE;                                                    03968000
   WHILE VTADDR < VTTOP DO                                              03970000
      BEGIN                                                             03972000
      GETXDSW(VTBUF,TLTDST,VTADDR,VTESIZE);                             03974000
      IF INUSE AND (VCB'PIN = PINNO) AND                                03976000
         VCB'LNKWAIT THEN GO PINMATCH;                                  03978000
      VTADDR := VTADDR+VTESIZE;                                         03980000
      END;                                                              03982000
   TAPETROUBLE(TT9);    << It should be there. >>              <<03581>>03984000
                                                                        03986000
PINMATCH:                                                               03988000
   VCB'LNKWAIT := 0;                                                    03990000
   IF (LDEV := VCB'LDEV) <> 0 THEN                             <<02648>>03992000
      BEGIN       << Re-open volume of mounted vol set. >>     <<02648>>03994000
      LTADDR := GETLDEV(LDEV,LTBUF);                           <<02648>>03996000
      IF <> THEN TAPETROUBLE(TT10);                            <<03581>>03998000
      GO WRCHK;                                                <<02648>>04000000
      END;                                                     <<02648>>04002000
                                                                        04004000
<< Search LDEV's to see if the needed volume has been mounted           04006000
and recognized by AVR.  Even if mounted, it won't yet be linked         04008000
to the volume entry, since we just finished constructing it.   >>       04010000
                                                                        04012000
   LTADDR := LTBASE;                                                    04014000
   WHILE LTADDR < LTTOP DO                                              04016000
      BEGIN                                                             04018000
      GETXDSW(LTBUF,TLTDST,LTADDR,LTESIZE);                             04020000
      LDEV := LCB'LDEV;                                                 04022000
      IF (LCB'VCB=0) AND GOODREEL(VTBUF,LTBUF) THEN GO WRCHK;  <<02648>>04024000
      LTADDR := LTADDR+VTESIZE;                                         04028000
      END;                                                              04030000
                                                                        04032000
<< Volume not mounted; harass opr for it. >>                            04034000
<< 287 Mount tape of volumeset ! >>                                     04036000
                                                                        04038000
   VCB'MNTWAIT := 1;        << Turn on Wait bit >>                      04040000
   POSTVTENT(VTBUF,VTADDR,SCODE);                                       04042000
   MOVE BBUF := VCB'VSETID,(6);                                         04044000
   MOVE BBUF(6) := " (ANS)";                                            04046000
   IF VCB'LABTYP=3 THEN MOVE BBUF(8) := "IBM";                          04048000
   BBUF(12) := 0;    << GENMSG terminator >>                            04050000
BUGOPR:                                                                 04052000
   RCNT := -1;                                                          04054000
   GENMSG(1,287,0,@BBUF,,,,,0,%1004,@REPLY);                            04056000
                                                                        04058000
<< Opr can either mount requested volume, which will be                 04060000
picked up by DEVREC and AVREC, or =REPLY an LDEV, which                 04062000
gets us here.  We check the LDEV to see if it is an                     04064000
appropriate tape.  >>                                                   04066000
                                                                        04068000
   IF REPLY < 0 THEN                                                    04070000
      BEGIN      << AVR, presumably; see what we got. >>                04072000
      SCODE := GETSIR(TLTSIR);                                          04076000
      GETXDSW(VTBUF,TLTDST,VTADDR,VTESIZE);                             04078000
      LDEV := VCB'LDEV;                                                 04080000
      LTADDR := GETLDEV(LDEV,LTBUF);                                    04082000
      IF < THEN TAPETROUBLE(TT10);    << AVR screwup >>        <<03581>>04084000
      GO WRCHK;                                                         04086000
      END;                                                              04088000
                                                                        04090000
<< Opr specified an LDEV.  See if it is legitimate. >>                  04092000
                                                                        04094000
   LDEV := BINARY'(REPLYB,RCNT);                                        04096000
   IF <> THEN GO BUGOPR;      << not a number >>                        04098000
   SCODE := GETSIR(TLTSIR);                                             04100000
   IF LDEV = 0 THEN GO REJECT;   << Opr rejected request. >>            04102000
   LTADDR := GETLDEV(LDEV,LTBUF);                                       04104000
   IF < OR (LCB'VCB <> 0) THEN GO WRONGLU;   << not tape, or in use. >> 04106000
   IF SETOWNED(LDEV,-1).(0:2) <> 0 THEN GO WRONGLU; << Already owned. >>04108000
   IF LCB'LABTYP = 0 THEN                                               04110000
      BEGIN                                                             04112000
                                                                        04114000
<<  The tape on the specified drive has not been identified; it         04116000
may have been Ready when the system came up.                            04118000
Read it and try AVR to spot a labeled tape; if the correct tape         04120000
is mounted, it will be linked by AVR. >>                                04122000
                                                                        04124000
      RELSIR(TLTSIR,SCODE);                                             04126000
      IF LCB'TAPE THEN RECOGNIZE(LDEV)                         <<03581>>04128000
                  ELSE CC := CCL;                              <<03581>>04130000
      IF < THEN GO BUGOPR;     << I/O error >>                          04132000
      SCODE := GETSIR(TLTSIR);     << Tape is at load point. >>         04134000
      LTADDR := GETLDEV(LDEV,LTBUF);                                    04136000
      END;                                                              04138000
   IF (LCB'LABTYP=1) AND ACCESS > 0 THEN GO WVL;    << unlabelled. >>   04140000
   IF LCB'VCB = VTADDR THEN GO WRCHK;  << correct tape - linked >>      04142000
   IF NOT CKFORLABEL(LDEV,1,ACCESS) THEN GO WVL;               <<04819>>04144000
       << If we have the correct access and we have        >>  <<04819>>04146000
       << operator's permission, let us use it as if it    >>  <<04819>>04148000
       << were unlabeled.                                  >>  <<04819>>04150000
                                                               <<02722>>04152000
<< Wrong tape.  Clean LDEV entry & rewind-unload. >>           <<02722>>04154000
                                                               <<02722>>04156000
   CLEANLDEV(LDEV);                                            <<02722>>04158000
   RELSIR(TLTSIR,SCODE);                                       <<02722>>04160000
   ATTIO(LDEV,9);                                              <<02722>>04162000
   GO BUGOPR;                                                  <<02722>>04164000
                                                               <<02722>>04166000
<< Something wrong with operator's reply, ask again. >>        <<02722>>04168000
                                                               <<02722>>04170000
WRONGLU:                                                       <<02722>>04172000
   RELSIR(TLTSIR,SCODE);                                                04174000
   GO BUGOPR;                                                           04176000
                                                                        04178000
<<  It's an unlabelled tape.  Write VOL1 label and set LCB entry. >>    04180000
                                                                        04182000
WVL:                                                                    04184000
   LCB'LABTYP := VCB'LABTYP;                                            04186000
   MOVE LCB'VOLID := VCB'VOLID,(6);                                     04188000
   MOVE LCB'VSETID := VCB'VOLID,(6);                                    04190000
   LCB'FSEQ := 1;                                                       04192000
   LCB'REEL := 1;                                                       04194000
   LCB'EXDATE := VCB'EXDATE;                                            04196000
   LCB'VCB := VTADDR;                                                   04198000
   VCB'MNTWAIT := 0;                                                    04200000
   VCB'LDEV := LDEV;                                                    04202000
   IF VCB'DENSITY = DEN'DEFAULT THEN                           <<02563>>04204000
      VCB'DENSITY := DEN'6250;                                 <<02563>>04206000
                                                                        04208000
   VCB'NEEDVOL := 1;   << Write a VOL1 later >>                <<03581>>04210000
   POSTVTENT(LTBUF,LTADDR,-1);                                          04212000
   POSTVTENT(VTBUF,VTADDR,SCODE);                                       04214000
   GO GOODEXIT;                                                         04218000
                                                                        04220000
<<  A labelled tape of the vol set is mounted and at load point;        04222000
determine if it is suitable.   >>                                       04224000
                                                                        04226000
WRCHK:                                                                  04228000
   IF ACCESS <> 0 THEN                                         <<02690>>04230000
      BEGIN     << Write access. >>                                     04234000
      RELSIR(TLTSIR,SCODE);                                             04236000
      IF CKFORLABEL(LDEV,2,1) THEN                             <<04819>>04238000
         BEGIN           << Not OK to write. >>                         04240000
         SCODE := GETSIR(TLTSIR);                                       04242000
         LCB'VCB := 0;          << De-link >>                           04244000
         POSTVTENT(LTBUF,LTADDR,-1);                                    04246000
REJECT:                                                                 04248000
         VCB'LDEV := 0;                                                 04250000
         VCB'FLAGS := 0;      << Release Volume entry. >>               04252000
         POSTVTENT(VTBUF,VTADDR,SCODE);                                 04254000
         GO NOLINK;                                                     04256000
         END;                                                           04258000
      SCODE := GETSIR(TLTSIR);                                          04260000
      END;                                                              04264000
   LCB'EXDATE := VCB'EXDATE;                                            04266000
   LCB'VCB := VTADDR;                                                   04268000
   VCB'MNTWAIT := 0;                                                    04270000
   VCB'LDEV := LDEV;                                                    04272000
                                                                        04274000
   POSTVTENT(LTBUF,LTADDR,-1);                                          04276000
   POSTVTENT(VTBUF,VTADDR,SCODE);                                       04278000
                                                                        04280000
GOODEXIT:                                                               04282000
   LDEVN := LDEV;                                                       04284000
   RESULT := OKAY;                                                      04286000
NOLINK:                                                                 04288000
   END;       << procedure LINKLABEL >>                                 04290000
$PAGE " CLEANLDEV "                                                     04292000
PROCEDURE CLEANLDEV(LDEV);                                              04294000
  VALUE LDEV;                                                  <<02575>>04296000
  INTEGER LDEV;                                                         04298000
  OPTION UNCALLABLE;                                                    04300000
                                                                        04302000
<< Called from FCLOSE and CHECKUL for FCLOSE to purge an LDEV entry     04304000
from the TLT.  Caller should Rewind-Unload. DB at the stack.  >>        04306000
                                                                        04308000
   BEGIN                                                                04310000
   INTEGER LTADDR,SCODE;                                                04312000
   LOGICAL ARRAY LTBUF(0:LTESIZE-1) =Q;                                 04314000
                                                                        04316000
   SCODE := GETSIR(TLTSIR);                                             04318000
   LTADDR := GETLDEV(LDEV,LTBUF);                                       04320000
   IF < THEN TAPETROUBLE(TT15);                                <<03581>>04322000
    LCB'FLAGS := LCB'FLAGS LAND %1000;  << Leave Tape Bit >>   <<03581>>04324000
   LTBUF(2) := 0;                                                       04326000
   MOVE LTBUF(3) := LTBUF(2),(VTESIZE-3);                               04328000
   POSTVTENT(LTBUF,LTADDR,SCODE);                                       04330000
   END;   << procedure CLEANLDEV >>                                     04332000
$PAGE " REELSWITCH "                                                    04334000
INTEGER PROCEDURE REELSWITCH(LDEV,RDWR);                                04336000
VALUE LDEV,RDWR;                                                        04338000
LOGICAL LDEV;                                                           04340000
INTEGER RDWR;                                                           04342000
  OPTION UNCALLABLE;                                                    04344000
                                                                        04346000
<< Called from POSITION, IOMOVE, RESTORE, etc. when a tapemark          04348000
or EOT marker is encountered in the data area to switch to the          04350000
next reel of a multi-volume file.  If writing, or if reading            04352000
and EOV follows, REELSWITCH calls for the next reel, positions          04354000
it to the data area, and returns True.  If read other than EOV,         04356000
positions tape to tapemark at end of data and returns                   04358000
False.  DB can be anywhere, typically at the user's buffer.             04360000
   RDWR = 0:  Read; next sequential vol of vol set required.            04362000
          1:  Write; any tape OK; any vol label is kept.                04364000
          2:  Read for POSITION; any vol of vol set OK.                 04366000
                                                                        04368000
Returns:  LDEV and CCE if next reel mounted                             04370000
          LDEV and CCG if EOF label found                               04372000
          LDEV and CCL if operator did =REPLY 0.   >>                   04374000
                                                                        04376000
<< Note: although it is planned to allow subsequent volumes             04378000
on different LDEV's, callers can't handle this now, so that             04380000
is not provided for in this code. >>                                    04382000
                                                                        04384000
   BEGIN                                                                04386000
   LOGICAL VTADDR,LTADDR,XLDEV;                                         04388000
   INTEGER SCODE,USERDB;                                                04390000
   LOGICAL RESTOR := FALSE;                                    <<0615>> 04392000
   LOGICAL WRITE = RDWR;                                                04394000
   INTEGER RESULT = REELSWITCH;                                         04396000
   INTEGER LTYPE;                                                       04398000
   LOGICAL ARRAY VTBUF(0:VTESIZE-1) =Q;                                 04400000
      BUILDVCB;                                                         04402000
   LOGICAL ARRAY LTBUF(0:LTESIZE-1) =Q;                                 04404000
      BUILDLCB;                                                         04406000
   INTEGER ARRAY BUFFER(0:30);                                          04408000
      BYTE ARRAY BBUF(*) = BUFFER;                                      04410000
   INTEGER ARRAY REPLY(0:3) =Q;                                         04412000
      BYTE ARRAY REPLYB(*) =REPLY+1;                                    04414000
      INTEGER RCNT = REPLY;                                             04416000
                                                               <<02648>>04418000
SUBROUTINE ATTIOS(FUNC);                                       <<02648>>04420000
VALUE FUNC; INTEGER FUNC;                                      <<02648>>04422000
                                                               <<02648>>04424000
   BEGIN                                                       <<02648>>04426000
   IF LDEV=0 THEN TAPETROUBLE(TT5);    << oops! >>             <<03581>>04428000
   TOS := ATTACHIO(LDEV,0,0,0,FUNC,0,0,4,%11);                 <<02689>>04430000
   DEL;                                                        <<02648>>04432000
   IF S0.(13:3) > 2 THEN                                       <<02648>>04434000
      BEGIN                                                    <<02673>>04436000
      REPORT'IOERROR(LDEV,S0.(8:8));   << gripe >>             <<02673>>04438000
      END;                                                     <<02648>>04440000
   X := TOS;                                                   <<02648>>04442000
   END;                                                        <<02648>>04444000
                                                               <<02648>>04446000
 << Begin execution >>                                                  04448000
                                                                        04450000
   CC := CCE;                                                           04452000
   USERDB := EXCHANGEDB(0);                                             04454000
   LTADDR := GETLDEV(LDEV,LTBUF);                                       04456000
   IF < THEN TAPETROUBLE(TT15);                                <<03581>>04458000
   VTADDR := LCB'VCB;                                                   04460000
   GETXDSW(VTBUF,TLTDST,VTADDR,VTESIZE);                                04462000
   IF LDEV <> VCB'LDEV THEN TAPETROUBLE(TT16);                 <<03581>>04464000
   IF RDWR < 0 THEN                                            <<0615>> 04466000
      BEGIN     << called from STARTVOLUME in RESTORE >>       <<0615>> 04468000
      RDWR := 2;      << set to READ >>                        <<02662>>04470000
      RESTOR := 1;    << GENMSG ask for "prior" reel. >>       <<0615>> 04472000
      GO UNLOAD;                                               <<0615>> 04474000
      END;                                                              04476000
                                                                        04478000
   IF WRITE THEN                                                        04480000
      BEGIN         << Write; finish off this reel. >>                  04482000
      WRITELAB(VTBUF,2);        << write TM,EOV1&2 >>                   04484000
      ATTIOS(6);         << write TM ending labels >>          <<02648>>04486000
      ATTIOS(6);         << write TM ending everything >>      <<02648>>04488000
      END                                                               04490000
   ELSE                                                                 04492000
      BEGIN    << Read.  If EOV1 follows, need next reel. >>            04494000
      LTYPE := CHECK1(LTBUF);      << ** need err check >>              04496000
      IF LTYPE <> 2 THEN                                                04498000
         BEGIN      << should be EOF1. Other cases illegal >>           04500000
         ATTIOS(12);   << BSR over what we just read >>        <<02648>>04502000
         ATTIOS(12);   << BSR over tape mark >>                <<02648>>04504000
         CC := CCG;        << report EOF >>                             04506000
         GO DONE;       << No more; FREAD will return EOF. >>  <<02563>>04508000
         END;                                                           04510000
      END;    << Read >>                                                04512000
UNLOAD:                                                        <<0615>> 04514000
   ATTIOS(9);       << Rewind Unload >>                        <<02648>>04516000
   SCODE := GETSIR(TLTSIR);                                             04520000
                                                                        04522000
<< The old reel has been disposed of.  Figure out which                 04524000
one comes next. >>                                                      04526000
<< 288 Mount next volume of set ! on LDEV# \ >>                         04528000
<< 289 Mount prior volume of set ! on LDEV# \ >>                        04530000
                                                                        04532000
   VCB'REEL := VCB'REEL+1;                                     <<04872>>04534000
   VCB'RSWAIT := 1;                                                     04536000
   VCB'DR'WAIT := 0;  <<  Set to wait on DEVREC >>             <<04698>>04538000
   POSTVTENT(VTBUF,VTADDR,SCODE);                                       04540000
   SETOWNED(LDEV,0);    << set unowned to enable AVR >>        <<04698>>04542000
                                                                        04544000
   MOVE BBUF := VCB'VSETID,(6);                                         04546000
   BBUF(6) := 0;    << GENMSG terminator >>                             04548000
BUGOPR:                                                                 04550000
   RCNT := -1;                                                          04554000
   GENMSG(1,288+RESTOR,%01000,@BBUF,LDEV,,,,0,%1004,@REPLY);            04556000
   IF RCNT < 0 THEN GO DIDAVR;                                          04558000
   XLDEV := BINARY'(REPLYB,RCNT);                                       04560000
   IF <> THEN GO BUGOPR;                                                04562000
   IF XLDEV = 0 THEN GO FLUSH;    << Opr reject. >>                     04564000
   GO BUGOPR;        << other replies invalid. >>                       04566000
                                                                        04568000
<< AVR has happened.  See what tape has been mounted. >>                04570000
                                                                        04572000
<< After AVREC has woken us up, DEVREC still modifies some >>  <<02563>>04574000
<< of the tape data structures.  In particular, it sets    >>  <<02563>>04576000
<< the device state to unowned and determines the tape's   >>  <<02563>>04578000
<< density.  We cannot continue until DEVREC has finished. >>  <<02563>>04580000
<< By waiting on the TAPEREC bit in the LPDT, we can be    >>  <<02563>>04582000
<< sure that AVR has finished. >>                              <<02563>>04584000
                                                               <<02563>>04586000
DIDAVR:                                                                 04588000
   GETXDSW(VTBUF,TLTDST,VTADDR,VTESIZE);                       <<03618>>04592000
   WHILE NOT VCB'DR'WAIT DO                                    <<03618>>04594000
     BEGIN                                                     <<03618>>04596000
     DELAY(100D);       <<  Wait for DEVREC to finish  >>      <<03618>>04598000
     GETXDSW(VTBUF,TLTDST,VTADDR,VTESIZE);                     <<03618>>04600000
     END;                                                      <<03618>>04602000
   SCODE := GETSIR(TLTSIR);                                             04604000
   LTADDR := GETLDEV(LDEV,LTBUF);                                       04606000
   IF < THEN TAPETROUBLE(TT16);                                <<03581>>04608000
   IF WRITE THEN                                               <<02648>>04610000
      BEGIN                                                    <<02648>>04612000
      IF LCB'LABTYP=1 THEN GO WVL      << unlabelled >>        <<02648>>04614000
      ELSE IF LCB'LABTYP=VCB'LABTYP THEN GO WRCHK;             <<02648>>04616000
      END                                                      <<02648>>04618000
   ELSE                                                        <<02648>>04620000
      BEGIN      << Read >>                                    <<02648>>04622000
      IF (LCB'LABTYP=VCB'LABTYP) AND LCB'VSETID=VCB'VSETID,(6) <<02648>>04624000
      THEN IF (RDWR=2) OR (LCB'REEL=VCB'REEL) AND              <<02662>>04626000
        (LCB'FSEQ=VCB'FSEQ) THEN GO READIT;                    <<02648>>04628000
      END;                                                     <<02648>>04630000
   RELSIR(TLTSIR,SCODE);                                       <<02722>>04632000
   ATTIOS(9);            << Wrong tape; unload it. >>          <<02722>>04636000
   GO BUGOPR;                                                           04638000
                                                               <<04739>>04640000
                                                                        04642000
                                                               <<04739>>04644000
FLUSH:                                                         <<04739>>04646000
                                                               <<04739>>04648000
   IF NOT LCB'TAPE THEN << So we may do I/O to serial >>       <<04739>>04650000
     SETOWNED(LDEV,1);  <<disc, we must set owned, in >>       <<04739>>04652000
                 <<additon we leave it owned until the>>       <<04739>>04654000
                 <<SDISC XDS gets cleaned up.         >>       <<04739>>04656000
   SCODE := GETSIR(TLTSIR);                                    <<04739>>04658000
   VCB'FLUSH := 1;                                             <<04739>>04660000
   POSTVTENT(VTBUF,VTADDR,SCODE);                              <<04739>>04662000
                                                               <<04739>>04664000
   << Done with tape drive, clean up data structure. >>        <<04739>>04666000
   CLEANLDEV(LDEV);                                            <<04739>>04668000
   IF LCB'TAPE THEN SET'BOT'ON; <<Tape at BOT>>                <<04739>>04670000
   STORE'DENSITY(LDEV,LDEV,2);   << Clean density >>           <<04739>>04672000
                                                               <<04739>>04674000
   CC := CCL;                                                  <<04739>>04676000
   SETOWNED(LDEV,0);  <<Just in case we are owned >>           <<04739>>04678000
   GO DONE;          << Report lossage. >>                     <<04739>>04680000
                                                               <<04739>>04682000
<< There is now a blank (unlabelled) tape to write on LDEV.             04684000
We'll cook a VOL1 label.  >>                                            04686000
<< 290 Vol ID for volume of set ! on LDEV# \? >>                        04688000
                                                                        04690000
WVL:                                                                    04692000
   RELSIR(TLTSIR,SCODE);                                                04694000
   GENMSG(1,290,%01000,@BBUF,LDEV,,,,0,%3004,@REPLY);                   04696000
   MOVE VCB'VOLID := "      ";                                          04698000
<< Need to bless the input. >>                                 <<02648>>04700000
   MOVE VCB'VOLID := REPLYB,(RCNT);                                     04702000
                                                                        04704000
   LCB'LABTYP := VCB'LABTYP;                                            04706000
   MOVE LCB'VOLID := VCB'VOLID,(6);                                     04708000
   MOVE LCB'VSETID := VCB'VSETID,(6);                                   04710000
   LCB'FSEQ := VCB'FSEQ;                                                04712000
   LCB'REEL := VCB'REEL;                                                04714000
   LCB'EXDATE := VCB'EXDATE;                                            04716000
   VCB'POSN := IF VCB'STORTAP THEN AH2 ELSE AD;                         04718000
   VCB'RSWDONE := 1;                                                    04720000
   VCB'WRITDIR := VCB'STORTAP;                                          04722000
   VCB'RSWAIT := 0;                                                     04724000
   SCODE := GETSIR(TLTSIR);                                             04726000
   POSTVTENT(VTBUF,VTADDR,-1);                                          04728000
   POSTVTENT(LTBUF,LTADDR,SCODE);                                       04730000
   SETOWNED(LDEV,1);                                           <<02563>>04732000
   WRITLAB0(VTBUF);                                            <<02563>>04734000
   GO WRITING;                                                          04736000
                                                                        04738000
<< Reading: correct labeled tape is mounted and at loadpoint. >>        04740000
                                                                        04742000
READIT:                                                                 04744000
   VCB'RSWAIT := 0;     << turn off Wait for REELSWITCH >>              04746000
   MOVE VCB'VOLID := LCB'VOLID,(6);                                     04748000
   VCB'POSN := IF RESTOR THEN AH2 ELSE AD;                              04750000
   IF RDWR <> 2 THEN VCB'RSWDONE := 1;                         <<02690>>04752000
   POSTVTENT(VTBUF,VTADDR,SCODE);                                       04754000
   SETOWNED(LDEV,1);                                                    04756000
   ATTIOS(7);     << FSF over VOL1 and hdr lbls >>             <<02648>>04758000
   IF RESTOR THEN                                              <<0615>> 04760000
      BEGIN         << Go to user hdr lbl (STORE label) >>              04762000
      ATTIOS(12);   << BSR over tapemark >>                    <<02648>>04764000
      ATTIOS(12);   << BSR over last header label >>           <<02648>>04766000
      END;                                                              04768000
   GO GOODEXIT;                                                         04770000
                                                                        04772000
<< Writing: the correct labeled tape has been mounted and is            04774000
at loadpoint; see if it is writeable.  >>                               04776000
                                                                        04778000
WRCHK:                                                                  04780000
   VCB'RSWAIT := 0;     << turn off Wait for REELSWITCH >>              04782000
   MOVE VCB'VOLID := LCB'VOLID,(6);                                     04784000
   VCB'POSN := IF VCB'STORTAP THEN AH2 ELSE AD;                         04786000
   VCB'RSWDONE := 1;                                                    04788000
   VCB'WRITDIR := VCB'STORTAP;                                          04790000
   POSTVTENT(VTBUF,VTADDR,SCODE);                                       04792000
   IF NOT LCB'TAPE THEN SETOWNED(LDEV,0);  << Kludge because >><<04647>>04794000
                              << serial disc will be owned   >><<04647>>04796000
   IF CKFORLABEL(LDEV,2,1) THEN                                <<04819>>04798000
      BEGIN  << Wrong tape, Set up to mount another tape >>    <<04739>>04800000
      SETOWNED(LDEV,1);  << Disable AVR >>                     <<04739>>04802000
      SCODE := GETSIR(TLTSIR);                                 <<04739>>04806000
      VCB'RSWAIT := 1;   << turn on wait for reelswitch >>     <<04739>>04808000
      VCB'DR'WAIT := 0;  << set to wait on DEVREC >>           <<04739>>04810000
      MOVE BBUF := VCB'VSETID,(6);                             <<04739>>04812000
      MOVE BBUF(6) := 0; << GENMSG terminator     >>           <<04739>>04814000
      POSTVTENT(VTBUF,VTADDR,SCODE);                           <<04739>>04816000
      ATTIOS(9);   << Rewind-unload >>                         <<04739>>04818000
      SETOWNED(LDEV,0); << Enable AVR >>                       <<04739>>04820000
      GOTO BUGOPR;                                             <<04739>>04822000
      END;                                                     <<04739>>04824000
   SETOWNED(LDEV,1);                                           <<02563>>04828000
                                                               <<02563>>04830000
<< If the new reel is on a variable density drive, then >>     <<02563>>04832000
<< the VOL1 label will be rewritten if the tape is not  >>     <<02563>>04834000
<< at the correct density. >>                                  <<02563>>04836000
                                                               <<02563>>04838000
   IF (VARIABLE'DENSITY) AND WRONG'DENSITY(VTBUF) THEN         <<02563>>04840000
      BEGIN             << Need a new VOL1 >>                  <<02563>>04842000
      ATTIOS(5);    << Rewind >>                               <<02648>>04844000
      WRITLAB0(VTBUF);                                         <<02563>>04846000
      END                                                      <<02563>>04848000
   ELSE                                                        <<02563>>04850000
      ATTIOS(11);   << FSR over VOL1 >>                        <<02648>>04852000
WRITING:                                                       <<02563>>04854000
   WRITELAB(VTBUF,0);       << write header labels >>                   04858000
   IF NOT VCB'STORTAP THEN ATTIOS(6);  << TM ends lbls >>      <<02648>>04860000
   LOGIT(VTBUF);          << write Log record >>                        04862000
GOODEXIT:                                                               04864000
   IF LCB'TAPE THEN SET'BOT'OFF; <<BOT is off for labtape>>    <<03581>>04866000
DONE:                                                          <<02563>>04868000
   RESULT := LDEV;                                                      04870000
   EXCHANGEDB(USERDB);                                                  04872000
   END;    << procedure REELSWITCH >>                                   04874000
$PAGE " CHECKUL "                                                       04876000
INTEGER PROCEDURE CHECKUL(FNUM,CODE,FUNC);                     <<02690>>04878000
  VALUE FNUM,CODE,FUNC;                                                 04880000
  INTEGER FNUM,CODE,FUNC;                                      <<02690>>04882000
  OPTION UNCALLABLE;                                                    04884000
                                                                        04886000
COMMENT                                                        <<02690>>04888000
                                                               <<02690>>04890000
Called by file system intrinsics that effect tape motion,      <<02690>>04892000
this procedure keeps track of tape position and handles user            04894000
and system tape labels.  DB can be anywhere.  Called from:              04896000
 C,F  Procedure                                                         04898000
 0,0  FREAD                                                             04900000
 1,E  FWRITE             E = ACB'NEWEOF                        <<02690>>04902000
 2,L  FREADLABEL         L = Label number                      <<02690>>04904000
 3,0  FWRITELABEL                                                       04906000
 4,D  FCLOSE             D = Disposition                       <<02690>>04908000
 5,E  FCONTROL RWND      E = ACB'NEWEOF                        <<02690>>04910000
 6,F  FSPACE             F.(14:1) = ACB'NEWEOF                 <<02690>>04912000
                         F.(15:1) = 0, BSR                     <<02690>>04914000
                                  = 1, FSR                     <<02690>>04916000
 7,0  FCONTROL FSF                                                      04918000
Returns error code and CCL if error, else 0 and CCE.           <<02690>>04920000
                                                               <<02690>>04922000
;   << End of comment >>                                       <<02690>>04924000
                                                                        04926000
BEGIN                                                                   04928000
   INTEGER VTADDR,LTADDR,SCODE,USERDB;                                  04930000
   INTEGER LDEV,POSN,LTYPE;                                             04932000
   INTEGER RESULT=CHECKUL;                                     <<02690>>04934000
   LOGICAL LFUNC=FUNC;                                         <<02690>>04936000
   LOGICAL MUSTCLOSE := FALSE;                                 <<02690>>04938000
   LOGICAL ARRAY VTBUF(0:VTESIZE-1) =Q;                                 04940000
   LOGICAL ARRAY LTBUF(0:LTESIZE-1) =Q;                                 04942000
   ARRAY LABEL2(0:3) =Q;                                       <<02662>>04944000
      DOUBLE LABELTYPE=LABEL2;                                 <<02662>>04946000
      BYTE ARRAY BTLABEL(*) = LABEL2;                          <<02662>>04948000
                                                                        04950000
SUBROUTINE ERREXIT(HACK);                                               04952000
VALUE HACK; INTEGER HACK;                                               04954000
   BEGIN                                                                04956000
   RESULT := HACK;                                             <<02690>>04960000
   IF MUSTCLOSE THEN RETURN;   << Finish all processing. >>    <<02690>>04962000
   CC := CCL;                                                           04964000
   GO OUT;                                                              04966000
   END;                                                                 04968000
SUBROUTINE ATTIOS(FUNC);                                                04970000
VALUE FUNC; INTEGER FUNC;                                               04972000
                                                                        04974000
   BEGIN                                                                04976000
   IF LDEV=0 THEN TAPETROUBLE(TT5);    << oops! >>             <<03581>>04978000
   TOS := ATTACHIO(LDEV,0,0,0,FUNC,0,0,4,%11);                 <<02689>>04980000
   DEL;                                                                 04982000
   IF S0.(13:3) > 2 THEN ERREXIT(LBTPOSERR);                            04984000
   X := TOS;                                                            04986000
   END;                                                                 04988000
SUBROUTINE FSFDATA(SKPE2);                                     <<02662>>04990000
   VALUE SKPE2; LOGICAL SKPE2;                                 <<02662>>04992000
   BEGIN       << Advance tape to EOF2 or first UTL. >>        <<02662>>04994000
SKIP:                                                                   04996000
   ATTIOS(7);       << FSF over data >>                                 04998000
   LTYPE := CHECK1(LTBUF);   << read EOF1/EOV1 >>                       05000000
   IF LTYPE = 2 THEN                                                    05002000
      BEGIN        << EOV found; need next reel. >>                     05004000
      ATTIOS(12);    << BSR over EOV1 >>                                05006000
      REELSWITCH(LDEV,0);                                               05008000
      IF < THEN ERREXIT(LBTUNAVL);     << never return... >>            05010000
      IF > THEN ERREXIT(LBTPOSERR);    << not EOV1?? >>                 05012000
      GETXDSW(VTBUF,TLTDST,VTADDR,VTESIZE);                             05014000
      GETXDSW(LTBUF,TLTDST,LTADDR,LTESIZE);                             05016000
      GO SKIP;                                                          05018000
      END;                                                              05020000
   IF LTYPE <> 1 THEN ERREXIT(LBTFMTERR);   << should be EOF1. >>       05022000
   IF NOT SKPE2 THEN RETURN;    << done. >>                    <<02662>>05024000
   TOS := ATTACHIO(LDEV,0,0,@LABEL2,READ,4,0,0,1);             <<02662>>05026000
   DEL;                                                        <<02662>>05028000
   TOS := TOS.(13:3);                                          <<02662>>05030000
   IF S0 > 2 THEN ERREXIT(LBTPOSERR);                          <<02662>>05032000
   IF LCB'LABTYP = 3 THEN CTRANSLATE(1,BTLABEL,,4);            <<02662>>05034000
   IF TOS=2 OR LABELTYPE <> "EOF2" THEN ATTIOS(12);   << BSR >><<02662>>05036000
   END;      << subroutine FSFDATA >>                                   05038000
   IF NOT (0 <= CODE <= 7) THEN TAPETROUBLE(TT41);             <<03581>>05040000
                                                               <<02690>>05042000
   CC := CCE;   << Anticipate no error. >>                     <<02690>>05044000
   USERDB := EXCHANGEDB(0);     << DB to stack >>                       05046000
   VTADDR := GETFNUM(FNUM,VTBUF);                                       05048000
   IF < THEN TAPETROUBLE(TT42);                                <<03581>>05050000
   POSN := VCB'POSN;                                                    05052000
   LDEV := VCB'LDEV;                                                    05054000
   IF VCB'FLUSH AND CODE <> 4 THEN                                      05056000
      BEGIN       << device unavailable (=REPLY 0) >>                   05058000
      ERREXIT(LBTUNAVL);                                                05060000
      END;                                                              05062000
   LTADDR := GETLDEV(LDEV,LTBUF);                                       05064000
   IF < THEN TAPETROUBLE(TT43);                                <<03581>>05066000
   CASE * CODE OF BEGIN                                                 05068000
      BEGIN         << 0: FREAD >>                                      05070000
      IF POSN > AD THEN ERREXIT(LBTINVOP);                              05072000
      IF POSN < DNX THEN                                                05074000
         ATTIOS(7);     << FSF over hdr lbls >>                         05076000
      POSN := AD;                                                       05078000
      END;                                                              05080000
                                                                        05082000
      BEGIN       << 1: FWRITE: complete header labels. >>              05084000
      IF POSN > AD THEN ERREXIT(LBTINVOP);                              05086000
      IF POSN < AH2 AND WRITELAB(VTBUF,0) THEN                 <<02662>>05088000
         ERREXIT(LBTPOSERR);          << write HDR1&2 >>       <<02662>>05090000
      IF POSN < DNX THEN ATTIOS(6);   << WTM ending hdr lbls >>         05092000
      POSN := AD;                                                       05094000
      END;     << Header labels are now complete. >>                    05096000
                                                                        05098000
      BEGIN      << 2: FREADLABEL >>                                    05100000
      IF POSN <= AHU THEN GO OUT;   << OK to read hdr >>                05102000
      IF POSN <= AD THEN FSFDATA(1);   << set to user trlr lbls<<02662>>05104000
      POSN := ATU;                                                      05106000
      END;                                                              05108000
                                                                        05110000
      BEGIN      << 3: FWRITELABEL >>                                   05112000
      IF POSN < AH2 THEN                                                05114000
         BEGIN      << write header labels >>                           05116000
         IF WRITELAB(VTBUF,0) THEN ERREXIT(LBTPOSERR);         <<02662>>05118000
         POSN := AHU;                                                   05120000
         END;                                                           05122000
      IF POSN = AD THEN                                                 05124000
         BEGIN         << Set to write trlr labels >>                   05126000
         IF WRITELAB(VTBUF,1) THEN ERREXIT(LBTPOSERR);   << TM,EOF1&2 >>05128000
         POSN := ATU;                                                   05130000
         END;                                                           05132000
      END;                                                              05134000
                                                                        05136000
      BEGIN            << 4: FCLOSE >>                                  05138000
      IF FUNC < 0 THEN MUSTCLOSE := TRUE;                      <<02690>>05140000
      IF VCB'FLUSH THEN                                        <<02722>>05142000
         BEGIN                                                 <<02722>>05144000
         RESULT := LBTUNAVL;  << Tape drive is already free. >><<02722>>05146000
         GO CVOL;                                              <<02722>>05148000
         END;                                                  <<02722>>05150000
      IF VCB'WRITE THEN                                         <<2622>>05152000
         BEGIN          << Write access >>                      <<2622>>05154000
         IF POSN > H1NX THEN                                    <<2622>>05156000
            BEGIN       << Header labels written >>             <<2622>>05158000
            IF POSN < DNX THEN ATTIOS(6);  << WTM ending hdrs >><<2648>>05160000
            IF POSN < T1NX AND WRITELAB(VTBUF,1) THEN          <<02662>>05162000
               ERREXIT(LBTPOSERR);   << write TM,EOF1&2 >>     <<02662>>05164000
            ATTIOS(6);       << WTM ending trlr lbls >>                 05166000
            ATTIOS(6);       << WTM for EOV >>                          05168000
            IF FUNC < 2 THEN GO VSETCL;                                 05170000
            ATTIOS(12);       << BSR over EOV TM >>                     05172000
            IF FUNC = 2 THEN                                            05174000
               BEGIN          << Rewind file >>                         05176000
               ATTIOS(12);     << BSR over new TM >>                    05178000
               ATTIOS(8);      << BSF over trlr lbls >>                 05180000
               ATTIOS(8);      << BSF over data. (*** Need REELSW) >>   05182000
               ATTIOS(8);      << BSF over hdr lbls >>                  05184000
               ATTIOS(11);     << FSR over TM or VOL1 >>                05186000
               END                                                      05188000
            ELSE VCB'FSEQ := VCB'FSEQ+1;    << at next file >>          05190000
            END         << Header labels written >>             <<2622>>05192000
         ELSE                                                   <<2622>>05194000
            IF FUNC < 2 THEN GO VSETCL;                         <<2622>>05196000
         END            << Write access >>                      <<2622>>05198000
      ELSE                                                              05200000
         BEGIN       << Read access >>                                  05202000
         IF FUNC < 2 THEN                                               05204000
            BEGIN         << Close volume set >>                        05206000
VSETCL:     ATTIOS(9);      << Rewind-unload >>                         05208000
            CLEANLDEV(LDEV);                                   <<02689>>05210000
CVOL:       VTBUF := 0;      << CLEANTLT >>                    <<02689>>05214000
            POSN := 0;                                                  05216000
            MOVE VTBUF(1) := VTBUF,(VTESIZE-1);                         05218000
            GO OUT;                                                     05220000
            END;                                                        05222000
                                                                        05224000
         IF FUNC = 2 THEN                                               05226000
            BEGIN       << Rewind file: close vol but not vset. >>      05228000
            IF POSN >= T1NX THEN ATTIOS(8);  << BSF/trlrs >>            05230000
            IF POSN >= DNX THEN                                         05232000
               BEGIN          << backspace over data >>                 05234000
               ATTIOS(8);   << Loose end: add REELSWITCH. >>            05236000
               END;                                                     05238000
            ATTIOS(8);      << BSF over hdr lbls >>                     05240000
            ATTIOS(11);     << FSR over TM >>                           05242000
            END                                                         05244000
         ELSE                                                           05246000
            BEGIN       << advance to next file. >>                     05248000
            IF POSN < DNX THEN ATTIOS(7);  << FSF hdr lbls >>           05250000
            IF POSN < T1NX THEN FSFDATA(0);                    <<02662>>05252000
            ATTIOS(7);     << FSF over trlr lbls >>                     05254000
            VCB'FSEQ := VCB'FSEQ+1;                                     05256000
            END;                                                        05258000
         END;                                                           05260000
      POSN := H1NX;                                                     05262000
      VCB'FNUM := 0;   << CLEANTLTF: close vol but not vset. >>         05264000
      END;      << Exit with tape before HDR1. >>                       05266000
                                                                        05268000
      BEGIN         << 5: Rewind - write EOF & trlr labels >>           05270000
      IF VCB'STORTAP AND POSN = AD THEN GO OUT;    << Done. >>          05272000
      IF VCB'WRITE THEN                                                 05274000
         BEGIN             << WRITE access >>                           05276000
         IF POSN <= H1NX THEN GO OUT;  << no I/O. >>                    05278000
         IF POSN < DNX THEN                                             05280000
            ATTIOS(6);     << WTM: end of hdr labels >>                 05282000
         IF POSN < T1NX AND WRITELAB(VTBUF,1) THEN             <<02662>>05284000
            ERREXIT(LBTPOSERR);      << write TM,EOF1&2 >>     <<02662>>05286000
         ATTIOS(6);     << WTM: end of trlr labels >>                   05288000
         ATTIOS(6);     << WTM: end of vol set >>                       05290000
         ATTIOS(8);     << BSF over EOV TM >>                           05292000
         ATTIOS(8);     << BSF over end of trlr labels >>               05294000
         POSN := ATU;                                                   05296000
         END;         << Write access >>                                05298000
      IF POSN > AD THEN                                                 05300000
         ATTIOS(8);    << BSF over trlr labels >>                       05302000
      IF POSN >= DNX THEN                                               05304000
         BEGIN                                                          05306000
         ATTIOS(8);    << BSF over data (*** need reelswitch) >>        05308000
         END;                                                           05310000
      ATTIOS(8);    << BSF over header labels >>                        05312000
      IF CHECK1(LTBUF) = 3  << VOL1 >> THEN                             05314000
         ATTIOS(11);    << FSR over HDR1 >>                             05316000
      TOS := ATTACHIO(LDEV,0,0,@LABEL2,READ,4,0,0,1);          <<02662>>05318000
      DEL;                                                     <<02662>>05320000
      TOS := TOS.(13:3);                                       <<02662>>05322000
      IF S0 > 2 THEN ERREXIT(LBTPOSERR);                       <<02662>>05324000
      IF LCB'LABTYP = 3 THEN CTRANSLATE(1,BTLABEL,,4);         <<02662>>05326000
      IF TOS=2 OR LABELTYPE <> "HDR2" THEN ATTIOS(12);   << BSR >>      05328000
      POSN := AHU;                                                      05330000
      END;                                                              05332000
                                                                        05334000
      BEGIN         << 6: FSPACE >>                                     05336000
      IF POSN > AD THEN ERREXIT(LBTINVOP);                              05338000
      IF POSN < DNX THEN     << in header label area >>                 05340000
       IF NOT LFUNC THEN ERREXIT(LBTINVOP)  <<BSR in hdr lbls>><<02690>>05342000
         ELSE BEGIN                                                     05344000
         ATTIOS(7);     << FSF over hdr labels >>                       05346000
         POSN := DNX;                                                   05348000
         END;                                                           05350000
      IF LFUNC.(14:1) THEN                                     <<02690>>05352000
         BEGIN    << Backspace after write: TM needed. >>               05354000
         IF WRITELAB(VTBUF,1) THEN ERREXIT(LBTPOSERR);  << TM,EOF1&2 >> 05356000
         ATTIOS(6);    << WTM ending trlr labels >>                     05358000
         ATTIOS(6);    << WTM ending reel >>                            05360000
         ATTIOS(8);    << BSF over TM >>                                05362000
         ATTIOS(8);    << BSF over TM >>                                05364000
         ATTIOS(8);    << BSF over labels to end of data >>             05366000
         END;        << write trailer labels >>                         05368000
      POSN := AD;                                                       05370000
      END;                                                              05372000
                                                                        05374000
      BEGIN       << 7: FCONTROL 7 - FSF - go to UTL's >>               05376000
      IF POSN > AD THEN                                                 05378000
         ATTIOS(8)      << BSF over trlr labels >>                      05380000
      ELSE IF POSN < DNX THEN                                           05382000
         ATTIOS(7);     << FSF over header lbls >>                      05384000
      FSFDATA(1);       << FSF over data >>                    <<02662>>05386000
      POSN := AT2;                                                      05388000
      END;                                                              05390000
   END;     << CASE >>                                                  05392000
                                                                        05394000
OUT:                                                                    05396000
   SCODE := GETSIR(TLTSIR);                                             05398000
   VCB'POSN := POSN;                                                    05400000
   POSTVTENT(VTBUF,VTADDR,SCODE);                                       05402000
   EXCHANGEDB(USERDB);                                                  05404000
   END;     << procedure CHECKUL>>                                      05406000
$PAGE " POSITION "                                                      05408000
INTEGER PROCEDURE POSITION(LDEV,FNUM,BLKFACT,RSIZ,FOPS,AOPACTYPE);      05410000
   VALUE LDEV,FNUM,AOPACTYPE;                                           05412000
   INTEGER FNUM,BLKFACT,RSIZ;                                           05414000
   LOGICAL LDEV,FOPS,AOPACTYPE;                                         05416000
  OPTION UNCALLABLE;                                                    05418000
                                                                        05420000
COMMENT                                                        <<03581>>05422000
                                                               <<03581>>05424000
   Called from FOPEN to get to the beginning of the specified  <<03581>>05426000
file.  Tape is assumed to be at load point or at a HDR1 label. <<03581>>05428000
If reading, exits with tape after HDR2 label, if writing,      <<03581>>05430000
positioned to write HDR1 after writing VOL1 label if C         <<03581>>05432000
flag in word 5 of VCB is set.  Returns error code, 0 if OK;    <<03581>>05434000
                                                                        05436000
   BEGIN                                                                05438000
   LOGICAL VTADDR,LTADDR,SCODE;                                         05440000
   INTEGER RECSIZE;                                                     05442000
   INTEGER BLKSIZE;                                                     05444000
   INTEGER LTYPE;                                                       05446000
   LOGICAL                                                     <<02563>>05448000
      FIRSTFILE,      << denotes first file on reel >>         <<02563>>05450000
      COUNT,          << for kludgy fseq position >>           <<02563>>05452000
      ADDING;         << adding file to end of vset >>         <<02563>>05454000
   LOGICAL ARRAY TLABEL(0:LBLSIZE-1) =Q;                                05456000
      BYTE ARRAY BTLABEL(*)=TLABEL;                                     05458000
      DOUBLE LTBUFTYPE = TLABEL;                                        05460000
   LOGICAL ARRAY VTBUF(0:VTESIZE-1) =Q;                                 05462000
      BUILDVCB;                                                         05464000
   LOGICAL ARRAY LTBUF(0:LTESIZE-1) =Q;                                 05466000
      BUILDLCB;                                                         05468000
EQUATE FLAGS = 1;                                                       05470000
                                                                        05472000
<< Error subroutine >>                                                  05474000
                                                                        05476000
SUBROUTINE ERREXIT(ERRCODE);                                            05478000
VALUE ERRCODE; INTEGER ERRCODE;                                         05480000
   BEGIN                                                                05482000
   SCODE := GETSIR(TLTSIR);                                             05484000
   VTBUF := 0;     << CLEANTLT - close vol & volset >>                  05486000
   MOVE VTBUF(1) := VTBUF,(VTESIZE-1);                                  05488000
   LCB'FLAGS := LCB'FLAGS LAND %1000; << Leave Tape Bit >>     <<03581>>05490000
   LTBUF(2) := 0;                                                       05492000
   MOVE LTBUF(3) := LTBUF(2),(VTESIZE-3);                               05494000
   POSITION := ERRCODE;   << report error >>                            05496000
   GO POSERR;                                                           05498000
   END;                                                                 05500000
SUBROUTINE ATTIOS(FUNC);                                                05502000
VALUE FUNC; INTEGER FUNC;                                               05504000
                                                                        05506000
   BEGIN                                                                05508000
   IF LDEV=0 THEN TAPETROUBLE(TT5);  << oops! >>               <<03581>>05510000
   TOS := ATTACHIO(LDEV,0,0,0,FUNC,0,0,4,%11);                 <<02689>>05512000
   DEL;                                                                 05514000
   IF S0.(13:3) > 2 THEN ERREXIT(LBTPOSERR);                            05516000
   X := TOS;                                                            05518000
   END;                                                                 05520000
 << Forward Space 1 file from HDR2 to next HDR2. >>                     05522000
                                                                        05524000
SUBROUTINE FSFILE;                                                      05526000
   BEGIN                                                                05528000
   FIRSTFILE := FALSE;                                                  05530000
   ATTIOS(7);     << FSF over header lbls >>                            05532000
SKIP:                                                                   05534000
   ATTIOS(7);     << FSF over data >>                                   05536000
   LTYPE := CHECK1(LTBUF);   << read EOF1/EOV1 >>                       05538000
   IF < THEN ERREXIT(LBTPOSERR);                                        05540000
   IF LTYPE = 2 THEN                                                    05542000
      BEGIN        << EOV found; need next reel. >>                     05544000
      ATTIOS(12);    << BSR over EOV1 >>                                05546000
      REELSWITCH(LDEV,2);                                               05548000
      IF < THEN ERREXIT(LBTUNAVL);     << never return... >>            05550000
      IF > THEN ERREXIT(LBTPOSERR);    << not EOV1?? >>                 05552000
      GETXDSW(VTBUF,TLTDST,VTADDR,VTESIZE);                             05554000
      GETXDSW(LTBUF,TLTDST,LTADDR,LTESIZE);                             05556000
      GO SKIP;                                                          05558000
      END;                                                              05560000
   IF LTYPE <> 1 THEN ERREXIT(LBTFMTERR);   << should be EOF1. >>       05562000
   ATTIOS(7);     << FSF over trlr lbls >>                              05564000
   LTYPE := CHECK1(LTBUF);     << read TM/HDR1 >>                       05566000
   IF < THEN ERREXIT(LBTPOSERR);                                        05568000
   IF LTYPE > 0 THEN ERREXIT(LBTFMTERR);  << wasn't >>                  05570000
   IF LTYPE < 0 THEN LCB'FSEQ := LCB'FSEQ+1;                            05572000
   END;          << subroutine FSFILE >>                                05574000
<< Begin execution >>                                                   05576000
                                                                        05578000
   VTADDR := GETFNUM(FNUM,VTBUF);                                       05580000
   IF < THEN TAPETROUBLE(TT23);                                <<03581>>05582000
   IF LDEV <> VCB'LDEV THEN TAPETROUBLE(TT24);                 <<03581>>05584000
   LTADDR := GETLDEV(LDEV,LTBUF);                                       05586000
   IF AOPACTYPE <> 0 THEN                                               05588000
      ATTIOS(1);      << check for write ring >>                        05590000
   FIRSTFILE := FALSE;                                                  05592000
   ADDING := FALSE;                                            <<02563>>05594000
   LCB'FSEQ := VCB'FSEQ;   << default >>                                05596000
   IF VCB'NEEDVOL THEN                                         <<03581>>05598000
      BEGIN                                                    <<03581>>05600000
      VCB'NEEDVOL := 0;                                        <<03581>>05602000
      WRITLAB0(VTBUF);                                         <<03581>>05604000
      ATTIO(LDEV,6);  << write TM in lieu of HDR1 >>           <<03581>>05606000
      ATTIO(LDEV,5);  <<rewind>>                               <<03581>>05608000
      END;                                                     <<03581>>05610000
                                                                        05612000
SV:                                                                     05614000
   LTYPE := CHECK1(LTBUF);    << read TM, VOL1, or HDR1 >>              05616000
   IF < THEN ERREXIT(LBTPOSERR);                                        05618000
   IF LTYPE = 3 THEN                                                    05620000
      BEGIN     << VOL1 >>                                              05622000
      FIRSTFILE := TRUE;                                                05624000
      GO SV;                                                            05626000
      END;                                                              05628000
   IF LTYPE = 5 AND FIRSTFILE THEN GO SV;    << skip UVL's >>  <<02621>>05630000
   IF LTYPE > 0 THEN ERREXIT(LBTFMTERR);                                05632000
   CASE * VCB'SEQTYP OF BEGIN                                           05634000
      BEGIN       << 0: search for file name >>                         05636000
AGIN:                                                                   05638000
      IF LTYPE < 0 THEN ERREXIT(LBTEOVSET);                             05640000
      IF VCB'FNAME = LCB'FNAME,(IF LCB'HP THEN 17 ELSE 8)      <<02662>>05642000
         THEN GO FMATCH;                                       <<02662>>05644000
      FSFILE;                                                           05646000
      GO AGIN;                                                          05648000
      END;                                                              05650000
                                                                        05652000
      BEGIN      << 1: NEXT >>                                          05654000
      IF AOPACTYPE <> 0 THEN GO ADDEND;                                 05656000
      IF LTYPE < 0 THEN ERREXIT(LBTEOVSET);  << TM found >>             05658000
      GO FMATCH;                                                        05660000
      END;                                                              05662000
                                                                        05664000
      BEGIN       << 2: Add a file to end of volume set >>              05666000
ADDF:                                                                   05668000
      IF LTYPE < 0 THEN GO ADDEND;   << TM: end of vset. >>             05670000
      FSFILE;                                                           05672000
      GO ADDF;                                                          05674000
      END;                                                              05676000
                                                                        05678000
      BEGIN       << 3: Specified file seq # >>                         05680000
      COUNT := 0;                                                       05682000
BUMP:                                                                   05684000
      IF LTYPE < 0 THEN        << tapemark: end of vol set. >>          05686000
<<       IF LCB'FSEQ = VCB'FSEQ AND AOPACTYPE <> 0    >>                05688000
         IF (COUNT+1 = VCB'FSEQ) AND AOPACTYPE <> 0                     05690000
           THEN GO ADDEND ELSE ERREXIT(LBTEOVSET);                      05692000
<<    IF LCB'FSEQ = VCB'FSEQ THEN GO FMATCH;    >>                      05694000
      IF (COUNT := COUNT+1) >= VCB'FSEQ THEN GO FMATCH;  << Hiss! >>    05696000
      FSFILE;                                                           05698000
      GO BUMP;                                                          05700000
      END;                                                              05702000
   END;   << CASE >>                                                    05704000
                                                                        05706000
ADDEND:               << Write new file at end of vset. >>              05708000
   IF FIRSTFILE THEN                                                    05710000
      BEGIN      << Start file sequencing. >>                           05712000
      LCB'FSEQ := 1;                                                    05714000
      END;                                                              05716000
   LCB'EXDATE := 0;                                                     05718000
   ADDING := TRUE;                                             <<02563>>05720000
FMATCH:                                                                 05722000
                                                               <<02563>>05724000
<< If this is the volume set open, then must resolve density >><<02563>>05726000
<< for tapes on variable density drives.  If we're adding a  >><<02563>>05728000
<< file to an empty volume set or accessing the reel in NEXT >><<02563>>05730000
<< mode, then we'll rewrite the VOL1 label at the density    >><<02563>>05732000
<< requested by the user.  In all other cases, VCB'DENSITY   >><<02563>>05734000
<< must be updated to reflect the real density of the tape.  >><<02563>>05736000
                                                               <<02563>>05738000
   IF VCB'VSETOPEN AND (VARIABLE'DENSITY) THEN                 <<02563>>05740000
      BEGIN                                                    <<02563>>05742000
      IF ADDING AND FIRSTFILE AND                              <<02563>>05744000
        WRONG'DENSITY(VTBUF)   THEN                            <<02563>>05746000
         BEGIN           << Rewrite VOL1 at new density >>     <<02563>>05748000
         ATTIOS(5);      << Rewind >>                          <<02563>>05750000
         IF WRITLAB0(VTBUF) THEN ERREXIT(LBTPOSERR);           <<02662>>05752000
         ATTIOS(6);      << Terminate VOL1 with TM >>          <<02563>>05754000
         END                                                   <<02563>>05756000
      ELSE                                                     <<02563>>05758000
         VCB'DENSITY := GET'DENSITY(LDEV);                     <<02563>>05760000
      END;                                                     <<02563>>05762000
                                                               <<02563>>05764000
   IF AOPACTYPE <> 0 THEN                                               05766000
      BEGIN       << Write access >>                                    05768000
      ATTIOS(12);       << BSR over TM/HDR1 >>                          05770000
      VCB'POSN := H1NX;                                        <<02690>>05772000
      END                                                               05774000
   ELSE                                                                 05776000
      BEGIN       << Read access; check HDR2 label >>                   05778000
      TLABEL := 0;                                             <<02662>>05780000
      TOS := ATTACHIO(LDEV,0,0,@TLABEL,READ,LBLSIZE,0,0,FLAGS);         05782000
      DEL;                                                              05784000
      IF TOS.(13:3) > 2 THEN ERREXIT(LBTPOSERR);               <<02648>>05786000
      IF LCB'LABTYP = 3 THEN                                            05788000
         CTRANSLATE(1,BTLABEL,,80);    << from EBCDIC >>                05790000
      IF LTBUFTYPE = "HDR2" THEN                                        05792000
         BEGIN        << Process HDR2 label. >>                         05794000
                                                               <<02690>>05796000
  <<  If the file is an HP ANSI file, always use the  >>       <<02690>>05798000
  <<  HDR2 label to override the FOPEN FOPTIONS.  If  >>       <<02690>>05800000
  <<  the tape is a foreign tape, opening the file    >>       <<02690>>05802000
  <<  as Undefined means ignore the HDR2 label format >>       <<02690>>05804000
  <<  field.  Otherwise, return fixed for "F" and     >>       <<02690>>05806000
  <<  undefined for "V", "D" and "U". >>                       <<02690>>05808000
                                                               <<02690>>05810000
         IF LCB'HP THEN FOPFTYPE := IF L2RFMT = "F" THEN 0     <<02690>>05812000
            ELSE IF L2RFMT = "V" THEN 1                        <<02690>>05814000
            ELSE 2                                             <<02690>>05816000
         ELSE FOPFTYPE := IF (FOPFTYPE <> 2) AND L2RFMT = "F"  <<02690>>05818000
            THEN 0 ELSE 2;                                     <<02690>>05820000
                                                               <<02690>>05822000
         RECSIZE := BINARY'(L2RSIZE,5);     << bytes >>                 05824000
         BLKSIZE := BINARY'(L2BSIZE,5);     << bytes >>                 05826000
                                                               <<02690>>05828000
  <<  If the file is not an HP ANSI file and is being >>       <<02690>>05830000
  <<  accessed with undefined record format, then use >>       <<02690>>05832000
  <<  the BLOCKSIZE field for the record size. >>              <<02690>>05834000
                                                               <<02690>>05836000
         IF (FOPFTYPE = 2) AND NOT LCB'HP THEN                 <<02690>>05838000
            RECSIZE := BLKSIZE;                                <<02690>>05840000
                                                               <<02690>>05842000
         IF RECSIZE <> 0 THEN                                           05844000
            BEGIN                                                       05846000
                                                               <<02690>>05848000
<<   If the label shows carriage control, then we must     >>  <<02690>>05850000
<<   decrement RECSIZE by one since RBSIZE in FOPEN will   >>  <<02690>>05852000
<<   add one to RECSIZE for CCTL files.                    >>  <<02690>>05854000
                                                               <<02690>>05856000
            IF LCB'HP AND L2CCTL = "C" THEN                    <<02690>>05858000
               RECSIZE := RECSIZE - 1;                         <<02690>>05860000
                                                               <<02690>>05862000
            IF BLKSIZE <> 0 THEN BLKFACT := BLKSIZE/RECSIZE;            05864000
            IF LCB'B5000 THEN RECSIZE := RECSIZE*1;   << patch >>       05866000
            RSIZ := -RECSIZE;                                           05868000
            END;                                                        05870000
         IF LCB'HP THEN                                                 05874000
            BEGIN       << Process HP features in HDR2 >>               05876000
            IF L2FTYPE = "A" THEN FOPASCII := 1;                        05878000
            IF L2FTYPE = "B" THEN FOPASCII := 0;                        05880000
            IF L2CCTL = "C" THEN FOPCCTL := 1;                          05882000
            IF LCB'LOCKFLG AND                                          05884000
               VCB'LOCKWRD <> L2LOCK,(8) THEN ERREXIT(LBTLWERR);        05886000
            END;                                                        05888000
         END         << process HDR2 label >>                           05890000
      ELSE                                                              05892000
         ATTIOS(12);     << HDR2 label missing: BSR. >>                 05894000
      VCB'POSN := AH2;                                         <<02690>>05896000
      END;     << Read >>                                               05898000
   SCODE := GETSIR(TLTSIR);                                             05900000
   LCB'REEL := 1;                                                       05902000
   VCB'ASCII := FOPASCII;                                               05904000
   VCB'FSEQ := LCB'FSEQ;                                                05906000
   IF VCB'VSETOPEN THEN                                        <<02563>>05908000
      BEGIN                                                    <<02563>>05910000
      VCB'VSETOPEN := 0;     << Done with VOL set open >>      <<02563>>05912000
      IF LCB'TAPE THEN SET'BOT'OFF; <<BOT off for labtape>>    <<03581>>05914000
      END;                                                     <<02563>>05916000
POSERR:                                                                 05918000
   POSTVTENT(VTBUF,VTADDR,-1);                                          05920000
   POSTVTENT(LTBUF,LTADDR,SCODE);    << save header lbl info >>         05922000
   END;     << procedure POSITION >>                                    05924000
$PAGE " CKFORLABEL "                                                    05926000
LOGICAL PROCEDURE CKFORLABEL(LDEV,ACCESS,LBLED);                        05928000
 VALUE LDEV,ACCESS,LBLED;                                               05930000
 INTEGER LDEV,ACCESS; LOGICAL LBLED;                                    05932000
  OPTION UNCALLABLE;                                                    05934000
COMMENT                                                        <<04819>>05936000
                                                                        05938000
    Called from LINKLABEL, REELSWITCH, and ASKOP in ALLOCATE,  <<04819>>05940000
this procedure determines whether the tape may be written.     <<04819>>05942000
Writing is allowed (CKFORLABEL=FALSE) if the tape is           <<04819>>05944000
unlabeled labeled and if permitted by the operator.            <<04819>>05946000
DB at the stack.                                               <<04819>>05948000
   ACCESS - access mode as in LINKLABEL, 1 unless call         <<04819>>05950000
              from ASKOP.                                      <<04819>>05952000
   LBLED - 2 if the tape is labelled and we don't want to      <<04819>>05954000
           ask the operator for an expired tape (the Volids    <<04819>>05956000
           match).                                             <<04819>>05958000
                                                               <<04819>>05960000
           1 if the tape is supposed to be labelled            <<04819>>05962000
                 (per FOPTIONS)                                <<04819>>05964000
           0 if unlabelled (ASKOP call only).                  <<04819>>05966000
                                                                        05968000
;                                                              <<04819>>05970000
BEGIN                                                                   05972000
   LOGICAL RESULT=CKFORLABEL;                                           05974000
   INTEGER LTADDR,SCODE,MSG'NUM;                               <<04819>>05976000
   LOGICAL ARRAY LTBUF(0:LTESIZE-1) =Q;                                 05978000
      BYTE ARRAY LTBUFB(*) = LTBUF;                            <<04819>>05980000
   INTEGER ARRAY BUFFER(0:39);                                          05982000
      BYTE ARRAY BBUF(*) = BUFFER;                                      05984000
   LOGICAL ARRAY REPLY(0:2) =Q;                                         05986000
   LOGICAL ARRAY MSG(0:3) = Q;                                 <<04819>>05990000
      BYTE ARRAY MSGB(*) = MSG;                                <<04819>>05992000
                                                                        05994000
 <<  Begin execution.  >>                                               05996000
                                                                        05998000
 RESULT := TRUE;      << default: no write. >>                 <<04819>>06002000
 IF SETOWNED(LDEV,-1).(0:2)<>1 THEN                            <<04819>>06004000
   BEGIN             << LDEV is not owned or recognized >>     <<04819>>06006000
   LTADDR := GETLDEV(LDEV,LTBUF);                                       06008000
   IF < THEN TAPETROUBLE(TT25);                                <<03581>>06010000
   IF LCB'LABTYP = 0 THEN                                               06012000
      BEGIN                                                             06014000
                                                                        06016000
<< On the ALLOCATE call, there may be a tape that was                   06018000
Ready when the system came up, so try AVR. >>                  <<02690>>06020000
                                                                        06026000
      IF LCB'TAPE THEN RECOGNIZE(LDEV)                         <<03581>>06028000
                  ELSE CC := CCL;                              <<03581>>06030000
      IF < THEN GO OUT;     << I/O error. >>                            06032000
      GETXDSW(LTBUF,TLTDST,LTADDR,LTESIZE);  << get result of AVR >>    06034000
      END;     << Tape is again at load point. >>                       06036000
                                                                        06038000
   IF LCB'LABTYP < 2 THEN RESULT := FALSE ELSE                          06040000
      BEGIN                                                    <<04819>>06042000
      IF ACCESS = 1 AND NOT(LBLED=2 LAND CALENDAR>LCB'EXDATE)  <<04819>>06046000
        THEN BEGIN                                             <<04819>>06048000
        << Ask if it is OK to write on volume >>               <<04819>>06050000
        MOVE MSGB := LCB'VOLID,(6);                            <<04819>>06052000
        MSGB(6) := 0;  << GENMSG terminator >>                 <<04819>>06054000
        MSG'NUM := (IF CALENDAR > LCB'EXDATE                   <<04819>>06056000
           THEN 282 ELSE 291);                                 <<04901>>06058000
        GENMSG(1,MSG'NUM,%01000,@MSGB,LDEV,,,,0,1,@REPLY);     <<04819>>06060000
   <<291 OK to write on unexpired vol (!) on LDEV# \? (Y/N)>>  <<04819>>06062000
   <<282 OK to write on expired vol (!) on LDEV# \? (Y/N)>>    <<04901>>06064000
                                                               <<04819>>06066000
        IF REPLY                                               <<04819>>06068000
          THEN BEGIN                                           <<04819>>06070000
          LCB'EXDATE := 0;  << Set Expired >>                  <<04819>>06072000
          IF NOT LBLED                                         <<04819>>06074000
            THEN LCB'LABTYP := 1;                              <<04819>>06076000
          SCODE := GETSIR(TLTSIR);                             <<04819>>06078000
          POSTVTENT(LTBUF,LTADDR,SCODE);                       <<04819>>06080000
          RESULT := FALSE;                                     <<04819>>06082000
          END;                                                 <<04819>>06084000
        END                                                    <<04819>>06086000
      ELSE RESULT := FALSE;  << OK to write >>                 <<04819>>06088000
      END;    << labelled tape >>                                       06090000
   END;                                                        <<04819>>06092000
OUT:    << For I/O errors >>                                   <<04819>>06094000
   END;      << procedure CKFORLABEL >>                                 06098000
$PAGE " NEXTTAPEFILE "                                                  06100000
INTEGER PROCEDURE NEXTTAPEFILE(FNUM);                                   06102000
INTEGER FNUM;                                                           06104000
OPTION UNCALLABLE;                                                      06106000
                                                                        06108000
<< Used by Store-Restore to advance to the next file on a               06110000
labeled tape.  Returns 0, or error code and CCL if error.  >>           06112000
                                                                        06114000
   BEGIN                                                                06116000
   INTEGER VTADDR,LTADDR,SCODE;                                         06118000
   INTEGER LDEV,LTYPE,LOC'ACB'STAT;                            <<02703>>06120000
   LOGICAL ARRAY VTBUF(0:VTESIZE-1) =Q;                                 06122000
   LOGICAL ARRAY LTBUF(0:LTESIZE-1) =Q;                                 06124000
                                                                        06126000
<< Error subroutine >>                                                  06128000
                                                                        06130000
SUBROUTINE ERREXIT(ERRCODE);                                            06132000
VALUE ERRCODE; INTEGER ERRCODE;                                         06134000
   BEGIN                                                                06136000
   IF ERRCODE = LBTEOVSET THEN CC := CCG;                      <<02648>>06140000
   NEXTTAPEFILE := ERRCODE;   << report error >>                        06142000
   POST'ACB'ERROR(FNUM,LOC'ACB'STAT,ERRCODE);                  <<02703>>06144000
   GO POSERR;                                                           06146000
   END;                                                                 06148000
                                                                        06150000
SUBROUTINE ATTIOS(FUNC);                                       <<02662>>06152000
VALUE FUNC; INTEGER FUNC;                                               06154000
                                                                        06156000
   BEGIN                                                                06158000
   IF LDEV=0 THEN TAPETROUBLE(TT5);    << oops! >>             <<03581>>06160000
   TOS := ATTACHIO(LDEV,0,0,0,FUNC,0,0,4,%11);                 <<02689>>06162000
   DEL;                                                                 06164000
   IF S0.(13:3) > 2 THEN ERREXIT(LBTPOSERR);                            06166000
   X := TOS;                                                            06168000
   END;                                                                 06170000
                                                                        06172000
   CC := CCL;                                                           06174000
   VTADDR := GETFNUM(FNUM,VTBUF);                                       06176000
   IF < THEN TAPETROUBLE(TT52);                                <<03581>>06178000
   IF VCB'FLUSH THEN                                           <<02621>>06180000
      BEGIN          << device unavailable (=REPLY 0) >>       <<02621>>06182000
      ERREXIT(LBTUNAVL);                                       <<02621>>06184000
      END;                                                     <<02621>>06186000
   LDEV := VCB'LDEV;                                                    06188000
   LTADDR := GETLDEV(LDEV,LTBUF);                                       06190000
   IF < THEN TAPETROUBLE(TT53);                                <<03581>>06192000
   IF VCB'WRITE THEN                                                    06194000
      BEGIN        << STORE: terminate present file. >>                 06196000
      IF VCB'POSN > H1NX THEN                                  <<02622>>06200000
         BEGIN                                                 <<02622>>06202000
         IF VCB'POSN < DNX THEN ATTIOS(6);  << end hdrs >>     <<02662>>06204000
         IF WRITELAB(VTBUF,1) THEN ERREXIT(LBTPOSERR); << TM,EOF1&2 >>  06206000
         ATTIOS(6);        << WTM ending trlr lbls >>          <<02662>>06208000
         VCB'FSEQ := VCB'FSEQ+1;    << at next file >>         <<02622>>06212000
         END;                                                  <<02622>>06214000
      VCB'POSN := H1NX;                                        <<02622>>06216000
      VCB'REEL := 1;        << All files begin with this >>    <<02622>>06218000
      LCB'FSEQ := VCB'FSEQ;                                    <<02622>>06220000
      LCB'EXDATE := 0;                                         <<02622>>06222000
      LCB'REEL := 1;                                           <<02622>>06224000
      END                                                               06226000
   ELSE                                                                 06228000
      BEGIN       << RESTORE: advance tape to next file. >>             06230000
      IF VCB'POSN < DNX THEN ATTIOS(7);   << skip hdr lbls >>  <<02662>>06232000
SKIP:                                                                   06234000
      ATTIOS(7);               << FSF over data >>             <<02662>>06236000
      LTYPE := CHECK1(LTBUF);   << read EOF1/EOV1 >>                    06238000
      IF LTYPE = 2 THEN                                                 06240000
         BEGIN        << EOV found; need next reel. >>                  06242000
         ATTIOS(12);    << BSR over EOV1 >>                    <<02662>>06244000
         REELSWITCH(LDEV,IF VCB'POSN > DNX THEN 0 ELSE 2);              06246000
         IF < THEN ERREXIT(LBTUNAVL);     << never return... >>         06248000
         IF > THEN ERREXIT(LBTPOSERR);    << not EOV1?? >>              06250000
         GETXDSW(VTBUF,TLTDST,VTADDR,VTESIZE);                          06252000
         GETXDSW(LTBUF,TLTDST,LTADDR,LTESIZE);                          06254000
         VCB'RSWDONE := 1;                                     <<02690>>06256000
         GO SKIP;                                                       06258000
         END;                                                           06260000
      IF LTYPE <> 1 THEN ERREXIT(LBTFMTERR);   << should be EOF1. >>    06262000
      ATTIOS(7);         << FSF over trlr lbls >>              <<02662>>06264000
      VCB'REEL := 1;                                           <<02622>>06268000
      LTYPE := CHECK1(LTBUF);     << read TM/HDR1 >>                    06270000
      IF < THEN ERREXIT(LBTPOSERR);                                     06272000
      IF LTYPE > 0 THEN ERREXIT(LBTFMTERR);  << wasn't >>               06274000
      IF LTYPE < 0 THEN ERREXIT(LBTEOVSET);                             06276000
      ATTIOS(11);        << FSR over HDR2 label >>             <<02662>>06278000
      VCB'POSN := AH2;                                         <<02690>>06280000
      LCB'REEL := 1;                                           <<02622>>06282000
      VCB'FSEQ := LCB'FSEQ;                                    <<02622>>06284000
      END;                                                              06286000
   CC := CCE;                                                           06290000
   SCODE := GETSIR(TLTSIR);                                             06292000
   POSTVTENT(VTBUF,VTADDR,-1);                                          06294000
   POSTVTENT(LTBUF,LTADDR,SCODE);    << save header lbl info >>         06296000
   FCONTROL(FNUM,5,FNUM);   << reset block xfer count >>                06298000
POSERR:                                                                 06300000
   END;        << procedure NEXTTAPEFILE >>                             06302000
$PAGE " LDIRECTF "                                                      06304000
LOGICAL PROCEDURE LDIRECTF(FNUM);                                       06306000
   VALUE FNUM; INTEGER FNUM;                                            06308000
 OPTION UNCALLABLE;                                                     06310000
                                                                        06312000
<< Called from FSTORE in STORE after writing a file to see              06314000
if a Reelswitch occurred somewhere in the middle of the file.           06316000
If so, FSTORE will write a directory file following the                 06318000
(partial) file just written on the new reel.  DB at the stack.  >>      06320000
                                                                        06322000
   BEGIN                                                                06324000
   INTEGER VTADDR,SCODE;                                                06326000
   LOGICAL ARRAY VTBUF(0:VTESIZE-1) =Q;                                 06328000
                                                                        06330000
   SCODE := GETSIR(TLTSIR);                                             06332000
   VTADDR := GETFNUM(FNUM,VTBUF);                                       06334000
   IF < THEN TAPETROUBLE(TT27);                                <<03581>>06336000
   LDIRECTF := VCB'WRITDIR;                                             06338000
   VCB'WRITDIR := 0;                                                    06340000
   POSTVTENT(VTBUF,VTADDR,SCODE);                                       06342000
   END;     << procedure LDIRECTF >>                                    06344000
$PAGE " LRELSW "                                                        06346000
LOGICAL PROCEDURE LRELSW(FNUM);                                <<0615>> 06348000
   VALUE FNUM; INTEGER FNUM;                                            06350000
 OPTION UNCALLABLE;                                                     06352000
                                                                        06354000
<< STORE/RESTORE: Check and reset Reelswitch Done bit. Callers:         06356000
  WRITETAPE for FSTORE. If Reelswitch, write header label.              06358000
  IRESTORE to set Store tape bit.                                       06360000
  READTAPE of FRESTORE. If Reelswitch, skip directory file.             06362000
DB at stack.  >>                                                        06364000
                                                                        06366000
   BEGIN                                                                06368000
   INTEGER VTADDR,SCODE;                                                06370000
   LOGICAL ARRAY VTBUF(0:VTESIZE-1) =Q;                                 06372000
                                                                        06374000
   SCODE := GETSIR(TLTSIR);                                             06376000
   VTADDR := GETFNUM(FNUM,VTBUF);                                       06378000
   IF < THEN TAPETROUBLE(TT29);                                <<03581>>06380000
   LRELSW := VCB'RSWDONE;                                               06382000
   VCB'RSWDONE := 0;                                                    06384000
   VCB'STORTAP := 1;                                                    06386000
   POSTVTENT(VTBUF,VTADDR,SCODE);                                       06388000
   END;        << procedure LRELSW >>                                   06390000
$PAGE " PVOLID "                                                        06392000
INTEGER PROCEDURE PVOLID(LDEV,BUF);                                     06394000
VALUE LDEV; INTEGER LDEV;                                               06396000
BYTE ARRAY BUF;                                                         06398000
OPTION UNCALLABLE;                                                      06400000
                                                                        06402000
<< Used by :SHOWDEV in SPOOLCOMS to print Volume ID >>         <<02616>>06404000
<< and tape density (for variable density drives).  >>         <<02616>>06406000
                                                                        06408000
   BEGIN                                                                06410000
   LOGICAL ARRAY LTBUF(0:LTESIZE-1);                                    06412000
      BUILDLCB;                                                         06414000
   EQUATE                                                      <<02616>>06416000
      LABELPOS    = 6,   << Buffer rel. index for label type >><<02616>>06418000
      DENSITYPOS  = 14,  << Buffer rel. index for density >>   <<02616>>06420000
      VOLIDLEN    = 46,  << Total line len. including VOLID >> <<02616>>06422000
      DENSITYLEN  = 52;  << Total line len. including dens. >> <<02616>>06424000
   INTEGER                                                     <<02616>>06426000
      DENSITY;                                                 <<02616>>06428000
                                                                        06430000
   CC := CCL;                                                  <<02648>>06432000
   GETLDEV(LDEV,LTBUF);                                                 06434000
   IF < THEN RETURN;         << Not a tape. >>                          06436000
   CASE LCB'LABTYP OF                                                   06440000
      BEGIN                                                             06442000
      RETURN;                      << 0 >>                              06444000
      MOVE BUF := "(Nolabel)";     << 1 >>                     <<02616>>06446000
                                                               <<02616>>06448000
      BEGIN                        << 2 >>                     <<02616>>06450000
      MOVE BUF := LCB'VOLID,(6);                               <<02616>>06452000
      MOVE BUF(LABELPOS) := "(ANSI)";                          <<02616>>06454000
      END;                                                     <<02616>>06456000
                                                               <<02616>>06458000
      BEGIN                        << 3 >>                     <<02616>>06460000
      MOVE BUF := LCB'VOLID,(6);                               <<02616>>06462000
      MOVE BUF(LABELPOS) := "(IBM)";                           <<02616>>06464000
      END;                                                     <<02616>>06466000
                                                               <<02616>>06468000
      END;                                                              06470000
   PVOLID := VOLIDLEN;                                         <<02616>>06472000
   CC := CCE;   << A tape is mounted on drive. >>              <<02673>>06474000
                                                               <<02616>>06476000
<< If variable density drive, report tape density >>           <<02616>>06478000
                                                               <<02616>>06480000
   IF (VARIABLE'DENSITY) THEN                                  <<02616>>06482000
      BEGIN                                                    <<02616>>06484000
      DENSITY := GET'DENSITY(LDEV);                            <<02616>>06486000
      IF DENSITY <= DEN'6250 THEN                              <<02616>>06488000
         BEGIN                                                 <<02616>>06490000
         CASE DENSITY OF                                       <<02616>>06492000
            BEGIN                                              <<02616>>06494000
            RETURN;                          << 0 - Null >>    <<02616>>06496000
            MOVE BUF(DENSITYPOS) := "1600";  << 1 - DEN'1600 >><<02616>>06498000
            MOVE BUF(DENSITYPOS) := "6250";  << 2 - DEN'6250 >><<02616>>06500000
            END;                                               <<02616>>06502000
         PVOLID := DENSITYLEN;                                 <<02616>>06504000
         END;   << of valid density >>                         <<02616>>06506000
      END;   << of variable density drive >>                   <<02616>>06508000
   END;         << procedure PVOLID >>                                  06512000
$PAGE " TGETINFO "                                                      06514000
PROCEDURE TGETINFO(LDEV,FBUF,ITEMNUM);                                  06516000
   VALUE LDEV,ITEMNUM; INTEGER LDEV,ITEMNUM;                            06518000
   ARRAY FBUF;                                                          06520000
   OPTION UNCALLABLE;                                                   06522000
                                                                        06524000
<< Called from FFILEINFO in FILEIO to report various tape label         06526000
info items to the user. >>                                              06528000
                                                                        06530000
   BEGIN                                                                06532000
   BYTE ARRAY FBUFB(*) = FBUF;                                          06534000
   LOGICAL LEGAL'CALL;                                         <<04612>>06536000
   LOGICAL ARRAY LTBUF(0:LTESIZE-1) =Q;                                 06538000
      BUILDLCB;                                                         06540000
                                                                        06542000
   LEGAL'CALL := TRUE;                                         <<04612>>06544000
   GETLDEV(LDEV,LTBUF);                                                 06546000
   IF < OR LCB'LABTYP < 2 THEN    << not labeled tape. >>      <<04612>>06548000
     LEGAL'CALL := FALSE;                                      <<04612>>06550000
   CASE ITEMNUM OF                                                      06552000
    BEGIN                                                               06554000
      BEGIN       << 00 Volume ID >>                                    06556000
      IF LEGAL'CALL THEN                                       <<04612>>06558000
        MOVE FBUFB := LCB'VOLID,(6)                            <<04612>>06560000
      ELSE MOVE FBUFB := "      ";                             <<04612>>06562000
      END;                                                              06564000
                                                                        06566000
      BEGIN      << 01 Volume Set ID >>                                 06568000
      IF LEGAL'CALL THEN                                       <<04612>>06570000
        MOVE FBUFB := LCB'VSETID,(6)                           <<04612>>06572000
      ELSE MOVE FBUFB := "      ";                             <<04612>>06574000
      END;                                                              06576000
                                                                        06578000
      BEGIN      << 02 Expiration date >>                               06580000
      FBUF := IF LEGAL'CALL THEN LCB'EXDATE ELSE -1;           <<04612>>06582000
      END;                                                              06584000
                                                                        06586000
      BEGIN      << 03 File seq number >>                               06588000
      FBUF := IF LEGAL'CALL THEN LCB'FSEQ ELSE -1;             <<04612>>06590000
      END;                                                              06592000
                                                                        06594000
      BEGIN      << 04 Reel number >>                                   06596000
      FBUF := IF LEGAL'CALL THEN LCB'REEL ELSE -1;             <<04612>>06598000
      END;                                                              06600000
                                                                        06602000
      BEGIN      << 05 Seq type >>                                      06604000
      FBUF := IF LEGAL'CALL THEN 0 ELSE -1;  << LCB'SEQTYP;  >><<04612>>06606000
      END;                                                              06608000
                                                                        06610000
      BEGIN      << 06 Creation date >>                                 06612000
      FBUF := IF LEGAL'CALL THEN LCB'CDATE ELSE -1;            <<04612>>06614000
      END;                                                              06616000
                                                                        06618000
      BEGIN      << 07 Label type >>                                    06620000
      FBUF := IF LEGAL'CALL THEN LCB'LABTYP ELSE -1;           <<04612>>06622000
      END;                                                              06624000
                                                                        06626000
      BEGIN      << 08 Tape file name >>                                06628000
      IF LEGAL'CALL THEN                                       <<04612>>06630000
        BEGIN                                                  <<04873>>06632000
        MOVE FBUFB := LCB'FNAME,(17);                          <<04873>>06634000
        CC := CCE;                                             <<04873>>06636000
        END                                                    <<04873>>06638000
      ELSE                                                     <<04873>>06640000
        BEGIN                                                  <<04873>>06642000
        MOVE FBUFB := "                 ";                     <<04873>>06644000
        CC := CCL;                                             <<04873>>06646000
        END;                                                   <<04873>>06648000
      END;                                                              06650000
                                                                        06652000
    END;                                                                06654000
   END;     << procedure TGETINFO >>                                    06658000
$PAGE " CLEANTAPE "                                                     06660000
PROCEDURE CLEANTAPE(PINNO);                                             06662000
VALUE PINNO; LOGICAL PINNO;                                             06664000
OPTION UNCALLABLE;                                                      06666000
                                                                        06668000
<< Called from Morgue at process termination, following call            06670000
to FPROCTERM.  Files which were closed to close volume but              06672000
not volume set will have volume entries remaining in the TLT            06674000
which we remove here.  FREEDEVICE is called to return associated        06676000
tape drives to the Available pool and rewind them.  >>                  06678000
                                                                        06680000
   BEGIN                                                                06682000
   LOGICAL VTADDR;                                                      06684000
   INTEGER LDEV,SCODE;                                                  06686000
   DOUBLE VTBOUNDS;                                                     06688000
      LOGICAL VTBASE = VTBOUNDS;                                        06690000
      LOGICAL VTTOP = VTBOUNDS+1;                                       06692000
   LOGICAL ARRAY VTBUF(0:VTESIZE-1) =Q;                                 06694000
      BUILDVCB;                                                         06696000
   LOGICAL WAIT := FALSE;                                      <<02673>>06698000
                                                                        06700000
   SCODE := GETSIR(TLTSIR);                                             06702000
   GETXDSW(VTBOUNDS,TLTDST,XVTBASE,2);                                  06704000
   VTADDR := VTBASE;                                                    06706000
   WHILE VTADDR < VTTOP DO                                              06708000
      BEGIN      << search Volume entries >>                            06710000
      GETXDSW(VTBUF,TLTDST,VTADDR,VTESIZE);                             06712000
      IF INUSE AND VCB'PIN=PINNO THEN                                   06714000
         BEGIN         << release Volume entry. >>                      06716000
         LDEV := VCB'LDEV;                                              06718000
         IF <> THEN                                                     06720000
            BEGIN      << release LDEV. >>                              06722000
            RELSIR(TLTSIR,SCODE);                                       06724000
            FREEDEVICE(LDEV,WAIT);                                      06726000
            IF NOT (TAPE'DEVICE)                               <<03634>>06728000
              THEN FORS'XDS'DEALLOC(LDEV);                     <<03634>>06730000
            SCODE := GETSIR(TLTSIR);                                    06732000
            CLEANLDEV(LDEV);                                            06734000
            END;                                                        06736000
         VTBUF := 0;                                                    06738000
         MOVE VTBUF(1) := VTBUF,(VTESIZE-1);                            06740000
         POSTVTENT(VTBUF,VTADDR,-1);                                    06742000
         END;                                                           06744000
      VTADDR := VTADDR+VTESIZE;                                         06746000
      END;                                                              06748000
   RELSIR(TLTSIR,SCODE);                                                06750000
   END;             << procedure CLEANTAPE >>                           06752000
$PAGE " OUTER BLOCK "                                                   06754000
$CONTROL SEGMENT=OUTERBLOCK                                             06756000
END.                                                                    06758000
