!***********************************************************************
!*
!*                      Archive compaction package
!*
!*     Copyright (C)   R.D. Eager   University of Kent   MCMLXXXIII
!*
!***********************************************************************
!
!
!***********************************************************************
!*
!*          Constants
!*
!***********************************************************************
!
%constantinteger no = 0, yes = 1
%constantinteger ssdatafiletype = 4
%constantinteger epage kb = 4
%constantinteger epagesize = epage kb*1024
%constantinteger epages per vol = 8000
%constantinteger abase = x'100';        ! Base of array part of master file
%constantinteger max input tapes = 150
%constantinteger max output tapes = 100
%constantinteger max file entries = 20000
                                        ! Maximum number of files in master file
%constantinteger max pairs entries = 1000
%constantinteger instream = 1, outstream = 2
                                        ! Stream numbers for file access
%constantinteger inchan = 1, outchan1 = 2, outchan2 = 3
                                        ! Channel numbers for tape access
%constantinteger reading = 1, writing = 2
                                        ! Tape access modes
%constantinteger reclevel = 10;         ! Tape error recovery level
%constantinteger max user files = 1000; ! Max number of filenames read at once
%constantinteger logfile identity = x'FFFFFF0B'
                                        ! File format for JOURNAL system
%constantbyteinteger not available = 0, not processed = 1
%constantbyteinteger files in list = 2, being written = 3, written = 4
%constantbyteinteger all copied = 5, freed = 6, scratch = 7
%constantbyteinteger gathered = 0, copied = 1, checked = 2, recorded = 3
%constantstring(1) snl = "
"
%constantstring(11) masterfile = "AA#MASTER"
%constantstring(18) pairs list = "VOLUMS.TAPEPAIRS"
%constantinteger initialised = 0, gathering = 1, gathering done = 2
%constantinteger sorting = 3, sorted = 4, writing pair = 5
%constantinteger pair written = 6, removing input tape = 7
%constantinteger removing output tape = 8, recording pair = 9
%constantinteger pair recorded = 10, adding new pair = 11
%constantinteger removing old pairs = 12, finishing pair = 13
%constantinteger releasing tapes = 14, resetting file list = 15
%constantstring(20)%array compaction status(0:15) = %c
"Initialised","Gathering","Gathering done","Sorting","Sorted",
"Writing pair","Pair written","Removing input tape",
"Removing output tape","Recording pair","Pair recorded",
"Adding new pair","Removing old pairs","Finishing pair",
"Releasing tape","Resetting file list"
%constantstring(15)%array tape status(0:7) = %c
"Not available","Not processed","Files in list","Being written",
"Written","All copied","Freed","Scratch"
%constantstring(15)%array file status(0:3) = %c
"Gathered","Copied","Checked","Recorded"
!
!
!***********************************************************************
!*
!*          Record and array formats
!*
!***********************************************************************
!
%recordformat f input tapes(%string(6) vol,altvol,%byteinteger status,
                            sp0)
%recordformat f output tapes(%string(6) vol,%byteinteger status)
%recordformat f file entry(%string(6) user,%byteinteger status,
                           %integer fsys,%string(6) vol,
                           %byteinteger sp0,%string(6) newvol1,
                           %byteinteger sp1,%string(6) newvol2,
                           %byteinteger sp2,%halfinteger chapter,
                           new chapter,%integer nkb,%string(8) wdate,
                           %byteinteger sp3,sp4,sp5,%string(8) wtime,
                           %byteinteger sp6,sp7,sp8,%string(11) name,
                           %integer flags,%string(8) date,
                           %byteinteger sp9,sp10,sp11)
%recordformat f pairs entry(%string(7) tape1,tape2,%integer link)
!
%recordformat ainff(%string(11) name,%integer nkb,%string(8) date,
                    %string(6) tape,%integer chap,flags)
%recordformat fdf(%integer link,dsnum,%byteinteger status,accessroute,
                  valid action,cur state,%byteinteger mode of use,
                  mode,file org,dev code,%byteinteger rec type,flags,
                  lm,rm,%integer asvar,arec,recsize,minrec,maxrec,
                  maxsize,lastrec,conad,currec,cur,end,transfers,
                  darecnum,cursize,datastart,%string(31) iden)
%recordformat hf(%integer dataend,datastart,filesize,filetype,
                 sum,datetime,format,records)
%recordformat hpf(%string(6) tapename,username,%string(15) filename,
                  %string(8) date,time,type,%byteinteger spare0,
                  spare1,spare2,%integer chapter,epages,fsys,perms,
                  own,eep,arch,codes,ssbyte,cct,spare3,spare4,spare5,
                  records,%string(6) offered to)
%recordformat nnf(%string(6) user,%byteinteger nkb,%integer indno)
%recordformat rf(%integer conad,filetype,datastart,dataend)
!
%ownrecord(f input tapes)%arrayformat af input tapes(1:max input tapes)
%ownrecord(f output tapes)%arrayformat af output tapes %c
                                       (1:max output tapes)
%ownrecord(f file entry)%arrayformat af file entry %c
                                     (1:max file entries)
%ownintegerarrayformat xf(1:max file entries)
!
%ownrecord(f pairs entry)%arrayformat af pairs entry %c
                                      (1:max pairs entries)
!
!
!***********************************************************************
!*
!*          Own variables
!*
!***********************************************************************
!
%owninteger master file connected = no
%owninteger oldpt
%ownlongreal oldcpu
%owninteger mt used = no
!
%ownrecord(f input tapes)%arrayname input tapes
%ownrecord(f output tapes)%arrayname output tapes
%ownrecord(f file entry)%arrayname files
%ownintegerarrayname x
%ownintegername n input tapes
%ownintegername n output tapes
%ownintegername n files
%ownintegername system state
%ownintegername n epages
%ownintegername error flag
%ownintegername oldstate
%ownstringname last run sdate
%ownstringname last run stime
%ownstringname last run edate
%ownstringname last run etime
%ownstringname compaction date
%ownstringname compaction time
%ownstringname out tape 1
%ownstringname out tape 2
!
%ownintegername pairs
%ownintegername free
%ownrecord(f pairs entry)%arrayname pairs recs
!
!
!***********************************************************************
!*
!*          Subsystem references
!*
!***********************************************************************
!
%systemroutinespec connect(%string(31) file,%integer mode,hole,
                           prot,%record(rf)%name r,%integername flag)
%systemlongrealfunctionspec cputime
%externalstringfunctionspec date
%systemroutinespec define(%integer chan,%string(31) iden,
                          %integername afd,flag)
%systemroutinespec disconnect(%string(31) file,%integername flag)
%systemroutinespec etoi(%integer ad,l)
%systemstringfunctionspec failuremessage(%integer mess)
%systemstringfunctionspec itos(%integer n)
%systemintegermapspec mapssfd(%integer dsnum)
%systemroutinespec move(%integer length,from,to)
%systemstringfunctionspec nexttemp
%systemroutinespec outfile(%string(31) file,%integer size,hole,
                           prot,%integername conad,flag)
%externalintegerfunctionspec outpos
%externalintegerfunctionspec pageturns
%systemintegerfunctionspec parmap
%externalroutinespec prompt(%string(255) s)
%systemintegerfunctionspec pstoi(%string(63) s)
%systemroutinespec sendfile(%string(31) file,%string(16) device,
                            %string(11) name,%integer copies,forms,
                            %integername flag)
%systemroutinespec setfname(%string(63) s)
%systemroutinespec setpar(%string(255) s)
%externalroutinespec set return code(%integer i)
%systemstringfunctionspec spar(%integer n)
%externalstringfunctionspec time
%systemroutinespec uctranslate(%integer ad,len)
%externalintegerfunctionspec uinfi(%integer entry)
!
%externalroutinespec cherish(%string(255) s)
!
!
!***********************************************************************
!*
!*          Director references
!*
!***********************************************************************
!
%externalstringfunctionspec derrs(%integer n)
%externalintegerfunctionspec dfilenames(%string(6) user,
                                        %record(ainff)%arrayname inf,
                                        %integername fileno,maxrec,
                                        nfiles,%integer fsys,type)
%externalintegerfunctionspec dmodarch(%string(6) user,
                                      %string(11) file,
                                      %string(8) date,
                                      %record(ainff)%name ent,
                                      %integer fsys,type)
%externalroutinespec getavfsys(%integername n,%integerarrayname a)
%externalintegerfunctionspec getusnames2(%record(nnf)%arrayname unn,
                                         %integername n,%integer fsys)
%systemroutinespec oper(%integer operno,%string(255) s)
!
!
!***********************************************************************
!*
!*          Magnetic tape utility routines
!*
!***********************************************************************
!
%dynamicroutinespec await bulk moves(%integername n,flag)
%dynamicroutinespec closetape(%integer chan,%integername flag)
%dynamicroutinespec opentape(%integer chan,mode,rlevel,
                             %string(6) tape,%integername flag)
%dynamicroutinespec read page(%integer chan,chap,address,
                              %integername flag)
%dynamicroutinespec release all tapes
%dynamicroutinespec read page reverse(%integer chan,chap,address,
                                      %integername flag)
%dynamicroutinespec set tape mode(%integer chan,mode,rlevel)
%dynamicroutinespec skip tm reverse(%integer chan,%integername flag)
%dynamicroutinespec start bulk move(%integer from,to,pages,
                                    %integername flag)
%dynamicroutinespec writepage(%integer chan,chap,address,
                              %integername flag)
%dynamicroutinespec writetrailer(%integer chan,%integername flag)
!
!
!***********************************************************************
!*
!*          Forward references
!*
!***********************************************************************
!
%routinespec clearstream(%integer chan)
%routinespec disconnect master file(%integer setdate)
%routinespec sort filenames(%string(255) parms)
!
!
!***********************************************************************
!*
!*          Service routines
!*
!***********************************************************************
!
%string(255)%function specmessage(%integer n)
%string(255) s,s1,s2
%switch sw(1000:1037)
!
-> sw(n)
!
sw(1000):  s = "Catastrophic error"; %monitor; -> out
sw(1001):  s = "Compaction already initialised"; -> out
sw(1002):  s = "Invalid tape name &"; -> out
sw(1003):  s = "Too many input tapes"; -> out
sw(1004):  s = "Too many output tapes"; -> out
sw(1005):  s = "No more output tapes available"; -> out
sw(1006):  s = "Invalid tape access mode - channel &"; -> out
sw(1007):  s = "Invalid tape channel number - &"; -> out
sw(1008):  s = "Tape channel & already open"; -> out
sw(1009):  s = "Tape channel & not open"; -> out
sw(1010):  s = "Tape channel & not open for writing"; -> out
sw(1011):  s = "Tape channel & not open for reading"; -> out
sw(1012):  s = "Failed to claim tape &"; -> out
sw(1013):  s = "Failed to release tape &"; -> out
sw(1014):  s = "System not in suitable state"; -> out
sw(1015):  s = "Input tape list is empty"; -> out
sw(1016):  s = "Output tape list is empty"; -> out
sw(1017):  s = "Tape read error on &"; -> out
sw(1018):  s = "Tape write error on &"; -> out
sw(1019):  s = "Failed to position tape &"; -> out
sw(1020):  s = "Attempt to write invalid chapter to &"; -> out
sw(1021):  s = "Failed to skip back over tape mark on &"; -> out
sw(1022):  s = "Bulk move fails - &"; -> out
sw(1023):  s = "Inconsistent details in header page; &"; -> out
sw(1024):  s = "Reverse check fails on &"; -> out
sw(1025):  s = "Filenames already sorted"; -> out
sw(1026):  s = "End of tape on &"; -> out
sw(1027):  s = "Tape & already in pairs list"; -> out
sw(1028):  s = "Tape pairs list full"; -> out
sw(1029):  s = "Tape & not in pairs list"; -> out
sw(1030):  s = "Reverse check fails on header page - &"; -> out
sw(1031):  s = "Reverse check fails on volume label - &"; -> out
sw(1032):  s = "Attempt to read invalid chapter from &"; -> out
sw(1033):  s = "Start bulk move fails - &"; -> out
sw(1034):  s = "Unexpected tape mark on &"; -> out
sw(1035):  s = "Tape & already in list"; -> out
sw(1036):  s = "Error flag is set"; -> out
sw(1037):  s = "Tape not in list"; -> out
!
out:
%if s -> s1.("&").s2 %then %start;      ! Fill in variable component of message
   s = failuremessage(233)
   s <- s1.s.s2
%finish
%result = s
%end;   ! of specmessage
!
!
%routine fail(%string(31) op,%integer flag)
%string(255) s
!
%if flag >= 1000 %then %start
   s = " ".specmessage(flag).snl
%finish %else s = failuremessage(flag)
!
release all tapes %if mt used = yes
!
disconnect master file(yes)
!
selectinput(0)
selectoutput(0)
closestream(instream)
closestream(outstream)
clearstream(instream)
clearstream(outstream)
!
printstring(snl.op." fails -".s)
set return code(flag)
%stop
%end;   ! of fail
!
!
%routine readline(%stringname s)
%integer c,l
!
%on %event 9 %start;                    ! Trap 'Input Ended'
   s = ".END"
   %return
%finish
!
s = ""
%cycle
   %cycle
      readsymbol(c)
      %exit %if c = nl
      s <- s.tostring(c)
   %repeat
   l = length(s)
   l = l - 1 %while l > 0 %and charno(s,l) = ' '
   length(s) = l
   %exit %if l # 0
%repeat
uctranslate(addr(s)+1,length(s))
%end;   ! of readline
!
!
%integerfunction connect master file(%integer setdate)
%integer flag,conad,p
%record(f input tapes) it
%record(f output tapes) ot
%record(f file entry) ft
%record(rf) rr
!
%result = 0 %if master file connected = yes
connect(masterfile,3,0,0,rr,flag)
%result = flag %if flag # 0
conad = rr_conad
master file connected = yes
oldcpu = cputime
oldpt = pageturns
!
p = conad + abase
input tapes == array(p,af input tapes)
p = p + sizeof(it)*max input tapes
output tapes == array(p,af output tapes)
p = p + sizeof(ot)*max output tapes
files == array(p,af file entry)
p = p + sizeof(ft)*max file entries
x == array(p,xf)
n input tapes == integer(conad+x'20')
n output tapes == integer(conad+x'24')
n files == integer(conad+x'28')
last run sdate == string(conad+x'2C')
last run stime == string(conad+x'38')
last run edate == string(conad+x'44')
last run etime == string(conad+x'50')
system state == integer(conad+x'5C')
out tape 1 == string(conad+x'60')
out tape 2 == string(conad+x'68')
n epages == integer(conad+x'70')
compaction date == string(conad+x'74')
compaction time == string(conad+x'80')
error flag == integer(conad+x'8C')
oldstate == integer(conad+x'90')
!
%if setdate = yes %then %start
   last run sdate = date
   last run stime = time
   last run edate = ""
   last run etime = ""
%finish
mt used = no
!
%if error flag = yes %then %result = 1036 %else %result = 0
%end;   ! of connect master file
!
!
%routine disconnect master file(%integer setdate)
%integer flag
!
%if master file connected = yes = setdate %then %start
   last run edate = date
   last run etime = time
   mt used = no
   disconnect(masterfile,flag)
   master file connected = no
%finish
selectoutput(0)
newline
printstring("CPU ="); print(cputime-oldcpu,1,1)
printstring(" secs;  Pageturns ="); write(pageturns-oldpt,1)
newline
%end;   ! of disconnect master file
!
!
%integerfunction next file record
%integer i,j,k,n
%string(6) tape
!
%if n files < max file entries %then %start
   n files = n files + 1
   %result = n files
%finish
!
i = n input tapes
%while i > 0 %cycle
   %if input tapes(i)_status = not processed %or %c
       input tapes(i)_status = not available %then %start
      i = i - 1
      %continue
   %finish
   tape = input tapes(i)_vol
   input tapes(i)_status = not available
   printstring("*** File list full - discarding entries for ".tape.snl)
   j = 0
   n = 0
   !
   %for k = 1,1,n files %cycle
      %if files(k)_vol # tape %then %start
         j = j + 1
         files(j) = files(k)
         n = n + (files(j)_nkb+epage kb-1)//epage kb
      %finish
   %repeat
   n files = j
   n epages = n
   %result = next file record
%repeat
fail("GATHERFILENAMES",1000)
%end;   ! of next file record
!
!
%routine get output tapes
%if n output tapes < 2 %then %start
   out tape 1 = ""
   out tape 2 = "";                    ! Signal failure
   %return
%finish
!
out tape 1 = output tapes(1)_vol
out tape 2 = output tapes(2)_vol
output tapes(1)_status = being written
output tapes(2)_status = being written
%end;   ! of get output tapes
!
!
%integerfunction connect pairs list
%integer flag,nfsys,i,fsys,conad
%record(rf) rr
%integerarray fs(0:99)
!
get av fsys(nfsys,fs)
!
conad = 0
%for i = 0,1,nfsys-1 %cycle
   fsys = fs(i)
   connect(pairs list,3,0,(fsys << 8)!x'80',rr,flag)
   %if 0 # flag # 218 %then -> err
   %if flag = 0 %then conad = rr_conad %and %exit
%repeat
!
%if conad = 0 %then %start
   setfname(pairs list)
   flag = 218;                          ! File does not exist
   -> err
%finish
!
free == integer(conad+x'20')
pairs == integer(conad+x'24')
pairs recs == array(conad+x'28',af pairs entry)
%result = 0
!
err:
%result = flag
%end;   ! of connect pairs list
!
!
%routine disconnect pairs list
%integer flag
!
disconnect(pairs list,flag)
%end;   ! of disconnect pairs list
!
!
%integerfunction locate pair(%string(6) tape)
%integer link
%record(f pairs entry)%name pair
!
link = pairs
%while link # 0 %cycle
   pair == pairs recs(link)
   %exit %if pair_tape1 = tape %or pair_tape2 = tape
   link = pair_link
%repeat
%result = link
%end;   ! of locate pair
!
!
%string(6)%function paired(%string(6) vol)
%integer link,flag
%record(f pairs entry)%name pair
!
flag = connect pairs list
%result = "" %if flag # 0
!
link = locate pair(vol)
%result = "" %if link = 0
!
pair == pairs recs(link)
%if vol = pair_tape1 %then %start
   %result = pair_tape2
%finish %else %result = pair_tape1
%end;   ! of paired
!
!
%integerfunction add tape pair(%string(6) tape1,tape2)
%integer flag,i
%string(6)%array t(1:2)
%record(f pairs entry)%name pair
!
flag = connect pairs list
-> err %if flag # 0
!
t(1) = tape1
t(2) = tape2
%for i = 1,1,2 %cycle
   flag = locate pair(t(i))
   %if flag # 0 %then %start
      setfname(t(i))
      flag = 1027;                      ! Tape already in pairs list
      -> err
   %finish
%repeat
!
%if free = 0 %then %start
   flag = 1028;                         ! Tape pairs list full
   -> err
%finish
!
pair == pairs recs(free)
i = free
free = pair_link
pair_tape1 = tape1
pair_tape2 = tape2
pair_link = pairs;                      ! At front
pairs = i
!
flag = 0
!
err:
disconnect pairs list
%result = flag
%end;   ! of add tape pair
!
!
%integerfunction remove tape pair(%string(6) tape)
%integer flag,i
%integername link
%record(f pairs entry)%name pair
!
flag = connect pairs list
-> err %if flag # 0
!
link == pairs
%while link # 0 %cycle
   pair == pairs recs(link)
   %if pair_tape1 = tape %or pair_tape2 = tape %then %start
      i = pair_link
      pair_link = free
      free = link
      link = i
      flag = 0
      -> err
   %finish
   link == pair_link
%repeat
!
setfname(tape)
flag = 1029;                            ! Tape not in pairs list
!
err:
disconnect pairs list
%result = flag
%end;   ! of remove tape pair
!
!
%routine clearstream(%integer chan)
%record(fdf)%name f
!
%if mapssfd(chan) # 0 %then %start
   f == record(mapssfd(chan))
   %if f_status = 0 %then %start
      f_dsnum = 0;                      ! Mark descriptor as free
      mapssfd(chan) = 0;                ! Clear pointer
   %finish
%finish
%end;   ! of clearstream
!
!
!***********************************************************************
!*
!*          I N I T I A L I S E   C O M P A C T I O N
!*
!***********************************************************************
!
%externalroutine initialise compaction(%string(255) parms)
%integer flag,conad,i,masterfilesize
%record(f input tapes) it
%record(f output tapes) ot
%record(f file entry) ft
%record(hf)%name r
!
set return code(1000)
setpar(parms)
%if parmap # 0 %then %start
   flag = 263;                          ! Wrong number of parameters
   -> err
%finish
!
flag = connect master file(yes)
%if flag # 218 %then %start
   flag = 1001;                         ! Compaction already initialised
   -> err
%finish
!
masterfilesize = abase + sizeof(it)*max input tapes + %c
                         sizeof(ot)*max output tapes + %c
                         sizeof(ft)*max file entries + %c
                         4*max file entries
outfile(masterfile,masterfilesize,0,0,conad,flag)
-> err %if flag # 0
r == record(conad);                     ! Fill in header
r_filetype = ssdatafiletype
r_format = 3;                           ! Un-structured
r_dataend = r_filesize
flag = connect master file(yes)
-> err %if flag # 0
cherish(masterfile)
!
%for i = 1,1,max input tapes %cycle
   input tapes(i)_vol = ""
   input tapes(i)_altvol = ""
   input tapes(i)_status = not processed
%repeat
n input tapes = 0
!
%for i = 1,1,max output tapes %cycle
   output tapes(i)_vol = ""
   output tapes(i)_status = not processed
%repeat
n output tapes = 0
!
%for i = 1,1,max file entries %cycle
   files(i) = 0
   x(i) = i
%repeat
!
n files = 0
n epages = 0
error flag = no
!
compaction date = ""
compaction time = ""
out tape 1 = ""
out tape 2 = ""
!
system state = initialised
disconnect master file(yes)
set return code(0)
%stop
!
err:
fail("INITIALISECOMPACTION",flag)
%end;   ! of initialise compaction
!
!
!***********************************************************************
!*
!*          A D D   I N P U T   T A P E S
!*
!***********************************************************************
!
%externalroutine add input tapes(%string(255) parms)
%integer flag,afd,added,i
%string(255) s
!
set return code(1000)
setpar(parms)
%if parmap > 1 %then %start
   flag = 263;                          ! Wrong number of parameters
   -> err
%finish
!
%if parmap # 0 %then %start
   define(instream,spar(1),afd,flag)
   -> err %if flag # 0
   selectinput(instream)
%finish
!
flag = connect master file(yes)
-> err %if flag # 0
!
%if system state # initialised %then %start
   flag = 1014;                         ! System not in suitable state
   -> err
%finish
!
added = 0
prompt("Input tape: ")
%cycle
   readline(s)
   %exit %if s = ".END"
   %if length(s) # 6 %then %start
      flag = 1002;                      ! Invalid tape name
      setfname(s)
      -> err
   %finish
   %if n input tapes + added >= max input tapes %then %start
      flag = 1003;                      ! Too many input tapes
      -> err
   %finish
   %for i = 1,1,n input tapes + added %cycle
      %if s = input tapes(i)_vol %then %start
         setfname(s)
         flag = 1035;                   ! Tape already in list
         -> err
      %finish
   %repeat
   added = added + 1
   input tapes(n input tapes + added)_vol = s
   input tapes(n input tapes + added)_status = not processed
%repeat
n input tapes = n input tapes + added
printstring("Input tapes added: ".itos(added).snl)
selectinput(0)
closestream(instream)
clearstream(instream)
!
disconnect master file(yes)
set return code(0)
%stop
!
err:
fail("ADDINPUTTAPES",flag)
%end;   ! of add input tapes
!
!
!***********************************************************************
!*
!*          R E M O V E   I N P U T   T A P E
!*
!***********************************************************************
!
%externalroutine remove input tape(%string(255) parms)
%integer flag,i,j
%string(255) vol
!
set return code(1000)
setpar(parms)
%if parmap # 1 %then %start
   flag = 263;                          ! Wrong number of parameters
   -> err
%finish
!
vol <- spar(1)
%if length(vol) # 6 %then %start
   setfname(vol)
   flag = 202;                          ! Invalid parameter
   -> err
%finish
!
flag = connect master file(yes)
-> err %if flag # 0
!
%if system state # initialised %then %start
   flag = 1014;                         ! System not in suitable state
   -> err
%finish
!
system state = removing input tape
!
j = 0
%for i = 1,1,n input tapes %cycle
   %if input tapes(i)_vol # vol %then %start
      j = j + 1
      input tapes(j) = input tapes(i)
   %finish
%repeat
%if j = n input tapes %then flag = 1037 %else %start
   n input tapes = n input tapes - 1
   flag = 0
   printstring("Tape ".vol." removed".snl)
%finish
!
system state = initialised
disconnect master file(yes)
-> err %if flag # 0
set return code(0)
%stop
!
err:
fail("REMOVEINPUTTAPE",flag)
%end;   ! of remove input tape
!
!
!***********************************************************************
!*
!*          A D D   O U T P U T   T A P E S
!*
!***********************************************************************
!
%externalroutine add output tapes(%string(255) parms)
%integer flag,afd,added,i
%string(255) s
!
set return code(1000)
setpar(parms)
%if parmap > 1 %then %start
   flag = 263;                          ! Wrong number of parameters
   -> err
%finish
!
%if parmap # 0 %then %start
   define(instream,spar(1),afd,flag)
   -> err %if flag # 0
   selectinput(instream)
%finish
!
flag = connect master file(yes)
-> err %if flag # 0
!
%if initialised # system state # sorted %then %start
   flag = 1014;                         ! System not in suitable state
   -> err
%finish
!
added = 0
prompt("Output tape: ")
%cycle
   readline(s)
   %exit %if s = ".END"
   %if length(s) # 6 %then %start
      flag = 1002;                      ! Invalid tape name
      setfname(s)
      -> err
   %finish
   %if n output tapes + added >= max output tapes %then %start
      flag = 1004;                      ! Too many output tapes
      -> err
   %finish
   %for i = 1,1,n output tapes + added %cycle
      %if s = output tapes(i)_vol %then %start
         setfname(s)
         flag = 1035;                   ! Tape already in list
         -> err
      %finish
   %repeat
   added = added + 1
   output tapes(n output tapes + added)_vol = s
   output tapes(n output tapes + added)_status = not processed
%repeat
n output tapes = n output tapes + added
printstring("Output tapes added: ".itos(added).snl)
selectinput(0)
closestream(instream)
clearstream(instream)
!
disconnect master file(yes)
set return code(0)
%stop
!
err:
fail("ADDOUTPUTTAPES",flag)
%end;   ! of add output tapes
!
!
!***********************************************************************
!*
!*          R E M O V E   O U T P U T   T A P E
!*
!***********************************************************************
!
%externalroutine remove output tape(%string(255) parms)
%integer flag,i,j
%string(255) vol
!
set return code(1000)
setpar(parms)
%if parmap # 1 %then %start
   flag = 263;                          ! Wrong number of parameters
   -> err
%finish
!
vol <- spar(1)
%if length(vol) # 6 %then %start
   setfname(vol)
   flag = 202;                          ! Invalid parameter
   -> err
%finish
!
flag = connect master file(yes)
-> err %if flag # 0
!
%if system state # initialised %then %start
   flag = 1014;                         ! System not in suitable state
   -> err
%finish
!
system state = removing output tape
!
j = 0
%for i = 1,1,n output tapes %cycle
   %if output tapes(i)_vol # vol %then %start
      j = j + 1
      output tapes(j) = output tapes(i)
   %finish
%repeat
%if j = n output tapes %then flag = 1037 %else %start
   n output tapes = n output tapes - 1
   flag = 0
   printstring("Tape ".vol." removed".snl)
%finish
!
system state = initialised
disconnect master file(yes)
-> err %if flag # 0
set return code(0)
%stop
!
err:
fail("REMOVEOUTPUTTAPE",flag)
%end;   ! of remove output tape
!
!
!***********************************************************************
!*
!*          C O M P A C T I O N   S T A T E
!*
!***********************************************************************
!
%externalroutine compaction state(%string(255) parms)
%integer flag,afd,i
!
set return code(1000)
setpar(parms)
%if parmap > 1 %then %start
   flag = 263;                          ! Wrong number of parameters
   -> err
%finish
%if parmap # 0 %then %start
   define(outstream,spar(1),afd,flag)
   -> err %if flag # 0
   selectoutput(outstream)
%finish
!
flag = connect master file(no)
-> err %if 0 # flag # 1036
!
printstring(snl."Archive compaction status on ".date." at ".time)
newlines(2)
printstring("System state: ".compaction status(system state))
newlines(2)
printstring("Last run started on ".last run sdate." at ".last run stime)
newline
%if last run edate # "" %then %start
   printstring("    and finished on ".last run edate." at ".%c
               last run etime)
%finish %else printstring("    and never finished")
newlines(2)
printstring("Input tape list:".snl.snl)
%if n input tapes = 0 %then %start
   printstring("<Empty>")
   newline
%else
   %for i = 1,1,n input tapes %cycle
      printstring(input tapes(i)_vol.": ")
      printstring(tape status(input tapes(i)_status))
      %if i & 1 # 0 %then spaces(34-outpos) %else newline
   %repeat
%finish
newlines(n input tapes & 1 + 2)
!
printstring("Output tape list:".snl.snl)
%if n output tapes = 0 %then %start
   printstring("<Empty>")
   newline
%else
   %for i = 1,1,n output tapes %cycle
      printstring(output tapes(i)_vol.": ")
      printstring(tape status(output tapes(i)_status))
      %if i & 1 # 0 %then spaces(34-outpos) %else newline
   %repeat
%finish
newlines(n output tapes & 1 + 2)
!
printstring("Output tape 1: ".out tape 1)
spaces(34-outpos)
printstring("Output tape 2: ".out tape 2.snl)
!
newline
printstring("Files in file list:   ".itos(n files).snl.snl)
printstring("Total epages:         ".itos(n epages+n files).snl)
                                        ! Allow for header pages
printstring("Tape pairs required: ")
write((n epages+n files+epages per vol-1)//epages per vol,1)
newlines(2)
!
printstring("Error flag: ")
%if error flag = yes %then printstring("Set") %else printstring("Clear")
newlines(2)
!
selectoutput(0)
closestream(outstream)
clearstream(outstream)
!
disconnect master file(no)
set return code(0)
%stop
!
err:
fail("COMPACTIONSTATE",flag)
%end;   ! of compaction state
!
!
!***********************************************************************
!*
!*          G A T H E R   F I L E N A M E S
!*
!***********************************************************************
!
%externalroutine gather filenames(%string(255) parms)
%integer flag,afd,nf,ix,fsys,nfsys,fx,nusers,ux,fileno,tx,i,j,maxrec
%integer txs
%string(31) s
%integerarray fs(0:99)
%record(nnf)%array us(0:340)
%record(ainff)%array inf(0:max user files-1)
%stringname user,tape
%record(f file entry)%name ent
%record(ainff)%name curfile
!
set return code(1000)
setpar(parms)
%if parmap > 3 %then %start
   flag = 263;                          ! Wrong number of parameters
   -> err
%finish
%if parmap & 1 # 0 %then %start
   define(outstream,spar(1),afd,flag)
   -> err %if flag # 0
   selectoutput(outstream)
%finish
!
flag = connect master file(yes)
-> err %if flag # 0
!
%if parmap & 2 # 0 %then %start;        ! File system specified - for debugging ONLY
   nfsys = 1
   fs(0) = pstoi(spar(2))
   %unless 0 <= fs(0) <= 99 %then %start
      flag = 202;                       ! Invalid parameter
      setfname(spar(2))
      -> err
   %finish
   prompt("Fsys ".itos(fs(0))." only? ")
   %for i = 1,1,2 %cycle
      readline(s)
      %unless charno(s,1) = 'Y' %then %start
         flag = 202;                    ! Invalid parameter
         setfname(spar(2))
         -> err
      %finish
      prompt("Are you sure? ")
   %repeat
%else
   get av fsys(nfsys,fs)
   %if nfsys > 1 %then %start;          ! Sort into ascending order
      %cycle
         flag = no
         %for i = 0,1,nfsys - 2 %cycle
            %if fs(i) > fs(i+1) %then %start
               j = fs(i)
               fs(i) = fs(i+1)
               fs(i+1) = j
               flag = yes
            %finish
         %repeat
         %exit %if flag = no
      %repeat
   %finish
%finish
!
%if system state # initialised %then %start
   flag = 1014;                         ! System not in suitable state
   -> err
%finish
!
%if n input tapes = 0 %then %start
   flag = 1015;                         ! Input tape list is empty
   -> err
%finish
!
n files = 0
fx = 0
system state = gathering
%while fx < nfsys %cycle;               ! Round each file system
   fsys = fs(fx)
   fx = fx + 1
   flag = get usnames2(us,nusers,fsys); ! Users sorted into index order
   %if flag # 0 %then %start
      printstring("*** GETUSNAMES on fsys ".itos(fsys)." fails, flag =")
      printstring(derrs(flag).snl)
      error flag = yes
      %continue
   %finish
   !
   ux = 0
   %while ux < nusers %cycle;           ! Round each user on the file system
      user == us(ux)_user
      ux = ux + 1
      %continue %unless length(user) = 6
      fileno = 0
      %cycle
         maxrec = max user files
         flag = dfilenames(user,inf,fileno,maxrec,nf,fsys,1)
                                        ! Names of all files on archive
         %if flag # 0 %then %start
            printstring("*** DFILENAMES on ".user.", fsys ".itos(fsys))
            printstring(" fails, flag =".derrs(flag).snl)
            error flag = yes
            %exit
         %finish
         ix = 0
         txs = n input tapes
         %while ix < maxrec %cycle;     ! Round each file for the user
            curfile == inf(ix)
            tape == curfile_tape
            flag = no
            tx = txs
            %cycle
               %if tape = input tapes(tx)_vol %then %start
                  %exit %if input tapes(tx)_status = not available
                  input tapes(tx)_status = files in list
                  flag = yes
                  txs = tx
                  %exit
               %finish
               tx = tx - 1
               %if tx = 0 %then tx = n input tapes
               %exit %if tx = txs
            %repeat
            ix = ix + 1
            %continue %if flag = no;    ! File not on any of current input tapes
            ent == files(next file record)
            ent = 0
            ent_user = user
            ent_status = gathered
            ent_fsys = fsys
            ent_vol = curfile_tape
            ent_newvol1 = ""
            ent_newvol2 = ""
            ent_chapter = curfile_chap
            ent_new chapter = 0
            ent_nkb = curfile_nkb
            ent_date = curfile_date
            ent_flags = curfile_flags
            ent_wdate = ""
            ent_wtime = ""
            ent_name = curfile_name
            n epages = n epages + (ent_nkb+epage kb-1)//epage kb
         %repeat;                       ! For each file
         %exit %if maxrec + fileno >= nf
         fileno = fileno + maxrec
      %repeat;                          ! For each group of files
   %repeat;                             ! For each user
%repeat;                                ! For each file system
!
%for i = 1,1,n input tapes %cycle
   %if input tapes(i)_status = not available %then %start
      input tapes(i)_status = not processed
   %finish
%repeat
!
system state = gathering done
selectoutput(0)
closestream(outstream)
clearstream(outstream)
printstring("Filename collection complete".snl)
%if error flag = no %then %start
   printstring("Starting filename sort".snl)
   sort filenames("")
%finish
set return code(0)
%stop
!
err:
fail("GATHERFILENAMES",flag)
%end;   ! of gather filenames
!
!
!***********************************************************************
!*
!*          S O R T   F I L E N A M E S
!*
!***********************************************************************
!
%externalroutine sort filenames(%string(255) parms)
%integer flag,i
!
%routine quicksort(%integer a,b)
%integer l,u,d
!
%return %if a >= b
l = a; u = b; d = x(u)
-> l2
l1: l = l + 1
    -> l4 %if l = u
l2: -> l1 %unless files(x(l))_vol >= files(d)_vol
    %if files(x(l))_vol = files(d)_vol %and %c
        files(x(l))_chapter < files(d)_chapter %then -> l1
    x(u) = x(l)
l3: u = u - 1
    -> l4 %if l = u
    -> l3 %unless files(x(u))_vol <= files(d)_vol
    %if files(x(u))_vol = files(d)_vol %and %c
        files(x(u))_chapter > files(d)_chapter %then -> l3
    x(l) = x(u)
    -> l1
l4: x(u) = d
    quicksort(a,l-1)
    quicksort(u+1,b)
%end;   ! of quicksort
!
set return code(1000)
setpar(parms)
%if parmap # 0 %then %start
   flag = 263;                          ! Wrong number of parameters
   -> err
%finish
!
flag = connect master file(yes)
-> err %if flag # 0
!
%if system state = sorted %then %start
   flag = 1025;                         ! Filenames already sorted
   -> err
%finish
!
%if system state # gathering done %then %start
   flag = 1014;                         ! System not in suitable state
   -> err
%finish
!
system state = sorting
!
%for i = 1,1,n files %cycle
   x(i) = i
%repeat
!
quicksort(1,n files)
!
system state = sorted
printstring("Sort complete".snl)
!
disconnect master file(yes)
set return code(0)
%return
!
err:
fail("SORTFILENAMES",flag)
%end;   ! of sort filenames
!
!
!***********************************************************************
!*
!*          L I S T   F I L E N A M E S
!*
!***********************************************************************
!
%externalroutine list filenames(%string(255) parms)
%integer flag,afd,i
%string(255) ss,sss
%stringname s
%record(fdf)%name f
%record(f file entry)%name ent
!
set return code(1000)
setpar(parms)
%if parmap > 1 %then %start
   flag = 263;                          ! Wrong number of parameters
   -> err
%finish
%if parmap & 1 # 0 %then %start
   define(outstream,spar(1),afd,flag)
   -> err %if flag # 0
   f == record(afd)
   f_maxsize = (uinfi(6)+1)*1024;       ! Get largest possible output file
   selectoutput(outstream)
%finish
!
flag = connect master file(yes)
-> err %if flag # 0
!
%unless system state = gathering done %or %c
        system state = sorted %or %c
        system state = writing pair %or %c
        system state = pair written %or %c
        system state = recording pair %or %c
        system state = pair recorded %then %start
   flag = 1014;                         ! System not in suitable state
   -> err
%finish
!
%if n files = 0 %then %start
   flag = 305;                          ! No input files
   -> err
%finish
!
newpage
newlines(2)
spaces(47)
printstring("Filename list on ".date." at ".time)
newlines(2)
ss = "FSYS    USER     FILENAME        STATUS        TAPE"
ss = ss."   CHAPTER    NTAPE1   NTAPE2    NEWCHAP    DATE       TIME"
sss = ""
%for i = 1,1,length(ss) %cycle
   %if charno(ss,i) = ' ' %then sss = sss." " %else sss = sss."-"
%repeat
printstring(ss.snl)
printstring(sss)
newlines(2)
%for i = 1,1,n files %cycle
   ent == files(x(i))
   write(ent_fsys,2)
   spaces(4)
   printstring(ent_user)
   spaces(3)
   s == ent_name
   printstring(s)
   spaces(15-length(s))
   ss = file status(ent_status)
   printstring(ss)
   spaces(15-length(ss))
   printstring(ent_vol)
   write(ent_chapter,7)
   spaces(5)
   %if ent_newvol1 # "" %then printstring(ent_newvol1) %else spaces(6)
   spaces(3)
   %if ent_newvol2 # "" %then printstring(ent_newvol2) %else spaces(6)
   %if ent_newchapter # 0 %then %start
      write(ent_new chapter,9)
   %finish %else spaces(10)
   spaces(3)
   %if ent_wdate # "" %then printstring(ent_wdate) %else spaces(8)
   spaces(3)
   %if ent_wtime # "" %then printstring(ent_wtime) %else spaces(8)
   newline
%repeat
!
selectoutput(0)
closestream(outstream)
clearstream(outstream)
!
disconnect master file(yes)
set return code(0)
%stop
!
err:
fail("LISTFILENAMES",flag)
%end;   ! of list filenames
!
!
!***********************************************************************
!*
!*          W R I T E   P A I R
!*
!***********************************************************************
!
%externalroutine write pair(%string(255) parms)
%integer i,flag,afd,epages,ad,outchap,epn,ep,n,last file written,j
%string(6) intape
%stringname ss
%record(f file entry)%name ent,vent
%record(hpf)%name h
%byteintegerarray buf(1:epagesize)
!
!
%integerfunction check header(%stringname vol)
%if h_tapename = vol %and %c
    h_username = ent_user %and %c
    h_filename = ent_name %and %c
    h_chapter = ent_new chapter %then %result = 0
!
setfname(vol." ".itos(ent_new chapter))
%result = 1030;                         ! Reverse check fails on header page
%end;   ! of check header
!
!
%integerfunction check label(%stringname vol)
%string(6) s
!
setfname(vol)
etoi(addr(buf(1)),80)
move(4,addr(buf(1)),addr(s)+1)
length(s) = 4
%result = 1031 %unless s = "VOL1";      ! Reverse check fails on volume label
move(6,addr(buf(5)),addr(s)+1)
length(s) = 6
%result = 1031 %unless s = vol;         ! Reverse check fails on volume label
%result = 0
%end;   ! of check label
!
!
%routine mark all copied(%stringname vol)
%integer i
!
%for i = 1,1,n input tapes %cycle
   %if vol = input tapes(i)_vol %then %start
      input tapes(i)_status = all copied
      %exit
   %finish
%repeat
%end;   ! of mark all copied
!
!
set return code(1000)
setpar(parms)
%if parmap > 1 %then %start
   flag = 263;                          ! Wrong number of parameters
   -> err
%finish
!
%if parmap & 1 # 0 %then %start
   define(outstream,spar(1),afd,flag)
   -> err %if flag # 0
   selectoutput(outstream)
%finish
!
flag = connect master file(yes)
-> err %if flag # 0
!
ad = addr(buf(1))
h == record(ad)
!
%if system state # sorted %then %start
   flag = 1014;                         ! System not in suitable state
   -> err
%finish
!
%if n files = 0 %then %start
   flag = 305;                          ! No input files
   -> err
%finish
%for i = 1,1,n files %cycle
   -> some files %if files(x(i))_status = gathered
%repeat
flag = 305;                             ! No input files
-> err
!
some files:
system state = writing pair
get output tapes
%if out tape 1 = "" %then %start
   flag = 1005;                         ! No more output tapes available
   -> err
%finish
!
mt used = yes
opentape(outchan1,writing,reclevel,out tape 1,flag)
-> err %if flag # 0
opentape(outchan2,writing,reclevel,out tape 2,flag)
-> err %if flag # 0
!
! Output  tapes  are  now  positioned  after their labels and first tape
! marks.  
!
intape = "";                            ! Dummy value
!
epages = 0;                             ! Count of epages written to this pair
outchap = 1
!
i = 1
last file written = 0
%cycle
   %exit %if i > n files
   ent == files(x(i))
   i = i + 1
   %continue %if ent_status # gathered
   %if ent_vol # intape %then %start
      %if intape # "" %then %start
         closetape(inchan,flag)
         -> err %if flag # 0
         mark all copied(intape)
      %finish
      intape = ent_vol
      opentape(inchan,reading,reclevel,intape,flag)
      %if flag # 0 %then -> err;        ! Failed to claim tape
      %for j = i+1,1,n files %cycle
         vent == files(x(j))
         %continue %if vent_vol = intape
         %continue %if vent_status # gathered
         oper(0,"Next tape is ".vent_vol)
         %exit
      %repeat
   %finish
   !
   read page(inchan,ent_chapter,ad,flag)
                                        ! Read header page of required chapter
   -> err %if flag # 0
   !
   ! Check  that the details in the header page correspond with those in
   ! the index entry.
   !
   ep = (ent_nkb+epage kb-1)//epage kb
   %unless h_tapename = intape %and %c
           h_username = ent_user %and %c
           h_filename = ent_name %and %c
           h_epages = ep %and %c
           h_chapter = ent_chapter %then %start
      flag = 1023;                      ! Inconsistent details in header page
      setfname(intape." chapter ".itos(ent_chapter))
      -> err
   %finish
   !
   ! Check that there is enough room left on the tape for this file
   !
   %exit %if ep + epages + 1 > epages per vol
   !
   ! Record original date and time of writing, to put on listings
   !
   ent_wdate = h_date
   ent_wtime = h_time
   !
   ! Amend the details in the header page
   !
   h_chapter = outchap
   !
   ! Write the header page to the output tapes
   !
   h_tapename = out tape 1
   writepage(outchan1,outchap,ad,flag)
   -> eot1 %if flag = 1026
   -> err %if flag # 0
   h_tapename = out tape 2
   writepage(outchan2,outchap,ad,flag)
   -> eot2 %if flag = 1026
   -> err %if flag # 0
   !
   ! Copy the file to both output tapes
   ! 
   %for epn = 1,1,ep %cycle
      read page(inchan,ent_chapter,ad,flag)
      -> err %if flag # 0
      writepage(outchan1,outchap,ad,flag)
      -> eot1 %if flag = 1026
      -> err %if flag # 0
      writepage(outchan2,outchap,ad,flag)
      -> eot2 %if flag = 1026
      -> err %if flag # 0
   %repeat
   epages = epages + epn + 1
   !
   ! Amend the record for the file just written
   !
   ent_status = copied
   ent_newvol1 = out tape 1
   ent_newvol2 = out tape 2
   ent_new chapter = outchap
   outchap = outchap + 1
   last file written = i - 1
%repeat
!
do trailer:
outchap = outchap - 1
!
write trailer(outchan1,flag)
flag = 0 %if flag = 1026;               ! Ignore EOT warnings here
-> err %if flag # 0
write trailer(outchan2,flag)
flag = 0 %if flag = 1026
-> err %if flag # 0
!
! Release any input tape
!
%if intape # "" %then %start
   closetape(inchan,flag)
   -> err %if flag # 0
   i = last file written
   %if i = n files %or %c
       files(x(i))_vol # files(x(i+1))_vol %then %start
      mark all copied(intape)
   %finish
%finish
!
! Skip back  over  the  trailing  tape  marks  on both output tapes, in
! preparation for the reverse check of the tapes.
!
%for i = 1,1,2 %cycle
   skip tm reverse(outchan1,flag)
   -> err %if flag # 0
   skip tm reverse(outchan2,flag)
   -> err %if flag # 0
%repeat
!
! Both output tapes are now positioned after the last block of the last
! chapter. Check them in reverse, by bulk moving the file pages to sink
! and then checking the header page.
!
set tape mode(outchan1,reading,0)
set tape mode(outchan2,reading,0)
%for i = last file written,-1,last file written-outchap+1 %cycle
   ent == files(x(i))
   %continue %unless ent_status = copied
   ep = (ent_nkb+epage kb-1)//epage kb
   start bulk move(outchan1,-1,-ep,flag)
   -> err %if flag # 0
   start bulk move(outchan2,-1,-ep,flag)
   -> err %if flag # 0
   n = 2
   await bulk moves(n,flag)
   -> err %if flag # 0
   !
   ! Check header page
   !
   read page reverse(outchan1,ent_new chapter,ad,flag)
   -> err %if flag # 0
   flag = check header(out tape 1)
   -> err %if flag # 0
   read page reverse(outchan2,ent_new chapter,ad,flag)
   -> err %if flag # 0
   flag = check header(out tape 2)
   -> err %if flag # 0
   !
   ! Skip tape mark at head of chapter
   !
   skip tm reverse(outchan1,flag)
   -> err %if flag # 0
   skip tm reverse(outchan2,flag)
   -> err %if flag # 0
   !
   ent_status = checked
%repeat
!
! Check the tape volume label
!
read page reverse(outchan1,0,ad,flag)
-> err %if flag # 0
flag = check label(out tape 1)
-> err %if flag # 0
read page reverse(outchan2,0,ad,flag)
-> err %if flag # 0
flag = check label(out tape 2)
-> err %if flag # 0
!
compaction date = date
compaction time = time
!
%for i = 1,1,n input tapes %cycle
   %if input tapes(i)_status = all copied %then %start
      input tapes(i)_status = freed
   %finish
%repeat
!
output tapes(1)_status = written
output tapes(2)_status = written
!
system state = pair written
!
! Close and release both output tapes
!
closetape(outchan1,flag)
-> err %if flag # 0
closetape(outchan2,flag)
-> err %if flag # 0
!
selectoutput(0)
closestream(outstream)
clearstream(outstream)
!
disconnect master file(yes)
set return code(0)
%stop
!
err:
fail("WRITEPAIR",flag)
%stop
!
eot1:                                   ! End of tape on output tape 1
ss == out tape 1
-> eot
!
eot2:                                   ! End of tape on output tape 2
ss == out tape 2
!
eot:
printstring("*** End of tape on ".ss." ***".snl)
ent_wdate = ""
ent_wtime = ""
skip tm reverse(outchan1,flag)
skip tm reverse(outchan2,flag)
-> do trailer
%end;   ! of write pair
!
!
!***********************************************************************
!*
!*          P R I N T   P A I R
!*
!***********************************************************************
!
%externalroutine printpair(%string(255) parms)
%integer flag,afd,i,n,kb,internal
%string(6) lastuser
%record(fdf)%name fd
%record(f file entry)%name f
%integerarray xx(1:max file entries)
!
!
%routine quicksort(%integer a,b)
%integer l,u,d
!
%return %if a >= b
l = a; u = b; d = xx(u)
-> l2
l1: l = l + 1
    -> l4 %if l = u
l2: -> l1 %unless files(xx(l))_vol >= files(d)_vol
    %if files(xx(l))_vol = files(d)_vol %and %c
        files(xx(l))_new chapter < files(d)_new chapter %then -> l1
    xx(u) = xx(l)
l3: u = u - 1
    -> l4 %if l = u
    -> l3 %unless files(xx(u))_vol <= files(d)_vol
    %if files(xx(u))_vol = files(d)_vol %and %c
        files(xx(u))_new chapter > files(d)_new chapter %then -> l3
    xx(l) = xx(u)
    -> l1
l4: xx(u) = d
    quicksort(a,l-1)
    quicksort(u+1,b)
%end;   ! of quicksort
!
!
%routine heading
newlines(2)
printstring("FSYS  USER    DATE     TIME    FILENAME   KBYTES")
printstring("  TAPE  CHAPTER  TAPE2".snl)
printstring("---- ------ -------- -------- ----------- ------")
printstring(" ------ ------- ------".snl.snl)
%end;   ! of heading
!
%routine item(%record(f file entry)%name f)
!
write(f_fsys,2)
printstring("  ".f_user)
printstring(" ".f_wdate." ".f_wtime." ".f_name)
spaces(12-length(f_name))
write(f_nkb,4)
printstring("  ".f_newvol1)
write(f_new chapter,5)
printstring("   ".f_newvol2.snl)
%end;   ! of item
!
set return code(1000)
setpar(parms)
%if parmap > 3 %then %start
   flag = 263;                          ! Wrong number of parameters
   -> err
%finish
%if parmap & 1 # 0 %then %start
   define(outstream,spar(1),afd,flag)
   -> err %if flag # 0
   fd == record(afd)
   fd_maxsize = (uinfi(6)+1)*1024;      ! Get largest possible output file
   selectoutput(outstream)
%finish
%if parmap & 2 # 0 %then internal = yes %else internal = no
!
flag = connect master file(yes)
-> err %if flag # 0
!
%if pair written # system state # pair recorded %then %start
   flag = 1014;                         ! System not in suitable state
   -> err
%finish
!
printstring("SDT: ".compaction date." ".compaction time.snl)
                                        ! Date and time for JOURNAL system
newpage
spaces(8)
printstring("ARCHIVE COMPACTION ON ".compaction date." AT ".%c
            compaction time)
newlines(4)
n = 0
kb = 0
lastuser = ""
!
%for i = 1,1,n files %cycle
   xx(i) = i
%repeat
!
quicksort(1,n files)
!
%for i = 1,1,n files %cycle
   f == files(xx(i))
   %continue %if f_newvol1 # out tape 1
   %continue %unless f_status = checked %or f_status = recorded
   %if f_user # lastuser %then %start
      lastuser = f_user
      heading
   %finish
   n = n + 1
   kb = kb + f_nkb
   item(f)
%repeat
!
! Print totals
!
newlines(2)
printstring("ARCHIVE COMPACTION FILES"); write(n,1)
printstring(" KBYTES"); write(kb,1)
newline
!
selectoutput(0)
closestream(outstream)
clearstream(outstream)
!
%if internal = no %then disconnect master file(yes)
set return code(0)
%return
!
err:
fail("PRINTPAIR",flag)
%end;   ! of printpair
!
!
!***********************************************************************
!*
!*          C O M P A C T I O N   R E C O V E R Y
!*
!***********************************************************************
!
%externalroutine compaction recovery(%string(255) parms)
%integer flag,setdate,i
%record(f file entry)%name ent
%switch sw(initialised:resetting file list)
!
set return code(1000)
setpar(parms)
%if parmap # 0 %then %start
   flag = 263;                          ! Wrong number of parameters
   -> err
%finish
!
flag = connect master file(no)
-> err %if flag # 0
!
release all tapes
clearstream(instream)
clearstream(outstream)
!
newline
setdate = no
-> sw(system state)
!
sw(initialised):
sw(gathering done):
sw(sorted):
sw(pair written):
sw(pair recorded):
   printstring("System is in '".compaction status(system state))
   printstring("' state - no action required".snl)
   -> out
!
sw(gathering):
   printstring("Failure occurred whilst gathering filenames".snl)
   n files = 0
   setdate = yes
   %for i = 1,1,n input tapes %cycle
      input tapes(i)_status = not processed
   %repeat
   printstring("All filenames lost".snl)
   system state = initialised
   -> out
!
sw(sorting):
   printstring("Failure occurred during filename sort".snl)
   %for i = 1,1,max file entries %cycle
      x(i) = i
   %repeat
   system state = gathered
   setdate = yes
   printstring("Sort abandoned".snl)
   -> out
!
sw(writing pair):
   printstring("Failure occurred whilst tapes being written".snl)
   printstring("Tapes were ".out tape 1." and ".out tape 2.snl)
   !
   ! Scan the file list, resetting status of any file that had been copied
   !
   %for i = 1,1,n files %cycle
      ent == files(i)
      %if ent_status = copied %or ent_status = checked %then %start
         ent_status = gathered
      %finish
   %repeat
   !
   ! Reset tape status
   !
   %for i = 1,1,n input tapes %cycle
      %if input tapes(i)_status = all copied %or %c
          input tapes(i)_status = freed %then %start
         input tapes(i)_status = files in list
      %finish
   %repeat
   output tapes(1)_status = not processed
   output tapes(2)_status = not processed
   out tape 1 = ""
   out tape 2 = ""
   !
   system state = sorted
   setdate = yes
   printstring("File records cleared down".snl)
   -> out
!
sw(removing input tape):
   printstring("Failure occurred whilst removing input tape".snl)
   n input tapes = 0
   system state = initialised
   setdate = yes
   printstring("Input tape list re-initialised".snl)
   -> out
!
sw(removing output tape):
   printstring("Failure occurred whilst removing output tape".snl)
   n output tapes = 0
   system state = initialised
   setdate = yes
   printstring("Output tape list re-initialised".snl)
   -> out
!
sw(recording pair):
   printstring("Failure occurred whilst recording pair".snl)
   system state = pair written
   setdate = yes
   -> out
!
sw(adding new pair):
   printstring("Failure occurred whilst adding new pair".snl)
   system state = pair recorded
   setdate = yes
   -> out
!
sw(removing old pairs):
   printstring("Failure occurred whilst removing old pairs".snl)
   system state = pair recorded
   setdate = yes
   -> out
!
sw(finishing pair):
   printstring("Failure occurred whilst finishing pair".snl)
   system state = pair recorded
   n output tapes = 0
   setdate = yes
   printstring("Output tape list re-initialised".snl)
   printstring("Last pair written was saved and completely processed")
   newline
   -> out
!
sw(releasing tapes):
   printstring("Failure occurred whilst releasing scratch tapes".snl)
   n input tapes = 0
   system state = oldstate
   setdate = yes
   printstring("System returned to previous state".snl)
   -> out
!
sw(resetting file list):
   printstring("Failure occurred whilst resetting file list".snl)
   %for i = 1,1,n input tapes %cycle
      %if input tapes(i)_status = files in list %then %start
         input tapes(i)_status = not processed
      %finish
   %repeat
   n files = 0
   n epages = 0
   setdate = yes
   printstring("All file entries now removed".snl)
   system state = initialised
   -> out
!
out:
printstring(snl."Recovery complete".snl)
disconnect master file(setdate)
set return code(0)
%stop
!
err:
fail("COMPACTIONRECOVERY",flag)
%end;   ! of compaction recovery
!
!
!***********************************************************************
!*
!*          R E C O R D   P A I R
!*
!***********************************************************************
!
%externalroutine record pair(%string(255) parms)
%integer flag,afd,i
%string(10) file
%string(255) s
%record(ainff) inf
%record(rf) rr
%record(hf)%name r
%record(f file entry)%name ent
!
set return code(1000)
setpar(parms)
%if parmap > 1 %then %start
   flag = 263;                          ! Wrong number of parameters
   -> err
%finish
%if parmap & 1 # 0 %then %start
   define(outstream,spar(1),afd,flag)
   -> err %if flag # 0
   selectoutput(outstream)
%finish
!
flag = connect master file(yes)
-> err %if flag # 0
!
%if system state # pair written %then %start
   flag = 1014;                         ! System not in suitable state
   -> err
%finish
!
system state = recording pair
!
%for i = 1,1,n files %cycle
   ent == files(x(i))
   %continue %unless ent_status = checked
   inf = 0
   inf_name = ent_name
   inf_nkb = ent_nkb
   inf_date = ent_date
   inf_tape = ent_newvol1
   inf_chap = ent_new chapter
   inf_flags = ent_flags
   !
   flag = dmodarch(ent_user,ent_name,ent_date,inf,ent_fsys,0)
   %if flag = 0 %then %start
      ent_status = recorded
   %else
      printstring("*** DMODARCH on ".ent_user.".".ent_name." (".%c
                  ent_date.") fails, flag = ".derrs(flag).snl)
      error flag = yes
   %finish
%repeat
%if error flag = yes %then %start
   printstring("Suspend or continue?".snl)
   prompt("S or C: ")
   %cycle
      readline(s)
      %unless charno(s,1) = 'S' %or charno(s,1) = 'C' %then %start
         printstring("Reply 'S' or 'C'".snl)
         %continue
      %finish
      %if charno(s,1) = 'S' %then %start
         system state = pair written
      %finish %else system state = pair recorded
      %exit
   %repeat
%finish %else system state = pair recorded
!
! Print the logfile, and send a copy to the JOURNAL system
!
selectoutput(0)
closestream(outstream)
clearstream(outstream)
file = "T#".nexttemp
printpair(file.",INTERNAL")
connect(file,3,0,0,rr,flag)
-> err %if flag # 0
r == record(rr_conad)
r_format = logfile identity;            ! Fill in JOURNAL index number
disconnect(file,flag)
-> err %if flag # 0
sendfile(file,"JOURNAL","",1,0,flag)
flag = 284 %if flag = 1000
-> err %if flag # 0
printpair(".LP,INTERNAL")
!
disconnect master file(yes)
set return code(0)
%stop
!
err:
fail("RECORDPAIR",flag)
%end;   ! of record pair
!
!
!***********************************************************************
!*
!*          F I N I S H   P A I R
!*
!***********************************************************************
!
%externalroutine finish pair(%string(255) parms)
%integer flag,i
%record(f input tapes)%name t
!
set return code(1000)
setpar(parms)
%if parmap # 0 %then %start
   flag = 263;                          ! Wrong number of parameters
   -> err
%finish
!
flag = connect master file(yes)
-> err %if flag # 0
!
%if system state # pair recorded %then %start
   flag = 1014;                         ! System not in suitable state
   -> err
%finish
!
system state = adding new pair
!
flag = add tape pair(out tape 1,out tape 2)
-> err %if flag # 0
!
system state = removing old pairs
%for i = 1,1,n input tapes %cycle
   t == input tapes(i)
   %continue %unless t_status = freed
   t_altvol = paired(t_vol)
   flag = remove tape pair(t_vol)
   flag = 0 %if flag = 1029;            ! Ignore if not there
   -> err %if flag # 0
   t_status = scratch
%repeat
!
system state = finishing pair
%if out tape 1 # "" %and n output tapes > 0 %then %start
   out tape 1 = ""
   out tape 2 = ""
   n output tapes = n output tapes - 2
   %for i = 1,1,n output tapes %cycle
      output tapes(i) = output tapes(i+2)
   %repeat
%finish
!
system state = sorted
disconnect master file(yes)
set return code(0)
%return
!
err:
fail("FINISHPAIR",flag)
%end;   ! of finish pair
!
!
!***********************************************************************
!*
!*          R E M O V E   P A I R
!*
!***********************************************************************
!
%externalroutine remove pair(%string(255) parms)
%integer flag
!
set return code(1000)
setpar(parms)
%if parmap # 1 %then %start
   flag = 263;                          ! Wrong number of parameters
   -> err
%finish
!
flag = remove tape pair(spar(1))
-> err %if flag # 0
!
set return code(0)
%stop
!
err:
fail("REMOVEPAIR",flag)
%end;   ! of remove pair
!
!
!***********************************************************************
!*
!*          R E L E A S E   S C R A T C H   T A P E S
!*
!***********************************************************************
!
%externalroutine release scratch tapes(%string(255) parms)
%integer flag,i,j,afd,n
%record(f input tapes)%name t
!
!
%routine print token(%string(6) vol)
%integer i
%switch sw(1:5)
!
selectoutput(outstream)
newlines(20)
%for i = 1,1,5 %cycle
   spaces(48)
   -> sw(i)
   !
sw(1):
sw(5):
   printstring("**********************************".snl)
   %continue
   !
sw(2):
sw(4):
   printstring("*                                *".snl)
   %continue
   !
sw(3):
   printstring("* ".vol." is available for re-use *".snl)
   %continue
   !
%repeat
selectoutput(0)
closestream(outstream)
%end;   ! of print token
!
!
set return code(1000)
setpar(parms)
%if parmap # 0 %then %start
   flag = 263;                          ! Wrong number of parameters
   -> err
%finish
!
flag = connect master file(yes)
-> err %if flag # 0
!
%if initialised # system state # sorted %then %start
   flag = 1014;                         ! System not in suitable state
   -> err
%finish
!
define(outstream,".LP",afd,flag)
-> err %if flag # 0
!
oldstate = system state
system state = releasing tapes
!
j = 0
n = 0
%for i = 1,1,n input tapes %cycle
   t == input tapes(i)
   %if t_status = scratch %then %start
      print token(t_vol)
      n = n + 1
      %if t_altvol # "" %then %start
         print token(t_altvol)
         n = n + 1
      %finish
   %else
      j = j + 1
      input tapes(j) = t
   %finish
%repeat
printstring(snl.itos(n)." tapes released".snl)
n input tapes = j
!
system state = oldstate
clearstream(outstream)
disconnect master file(yes)
set return code(0)
%stop
!
err:
fail("RELEASESCRATCHTAPES",flag)
%end;   ! of release scratch tapes
!
!
!***********************************************************************
!*
!*          R E S E T   F I L E   L I S T
!*
!***********************************************************************
!
%externalroutine reset file list(%string(255) parms)
%integer flag,i
%string(255) s
!
set return code(1000)
setpar(parms)
%if parmap # 0 %then %start
   flag = 263;                          ! Wrong number of parameters
   -> err
%finish
!
flag = connect master file(yes)
-> err %if flag # 0
!
%if gathering done # system state # sorted %then %start
   flag = 1014;                         ! System not in suitable state
   -> err
%finish
!
prompt("Reset files? ")
%for i = 1,1,2 %cycle
   readline(s)
   %unless charno(s,1) = 'Y' %then %start
      printstring("No action taken".snl)
      -> out
   %finish
   prompt("Are you sure? ")
%repeat
!
system state = resetting file list
!
%for i = 1,1,n input tapes %cycle
   %if input tapes(i)_status = files in list %then %start
      input tapes(i)_status = not processed
   %finish
%repeat
n files = 0
n epages = 0
printstring("All file entries removed".snl)
system state = initialised
!
out:
disconnect master file(yes)
set return code(0)
%stop
!
err:
fail("RESETFILELIST",flag)
%end;   ! of reset file list
!
!
!***********************************************************************
!*
!*          R E S E T   E R R O R   F L A G
!*
!***********************************************************************
!
%externalroutine reset error flag(%string(255) parms)
%integer flag
!
set return code(1000)
setpar(parms)
%if parmap # 0 %then %start
   flag = 263;                          ! Wrong number of parameters
   -> err
%finish
!
flag = connect master file(yes)
-> err %if 0 # flag # 1036
!
%if flag = 0 %then %start
   printstring("Error flag is already clear".snl)
%else
   error flag = no
   printstring("Error flag cleared".snl)
%finish
!
disconnect master file(yes)
set return code(0)
%stop
!
err:
fail("RESETERRORFLAG",flag)
%end;   ! of reset error flag
%endoffile