!* 
!* TAPE PAIRS LIST CREATION AND MAINTENANCE
!*
RECORDFORMAT  RECF(STRING (7)TAPE1,TAPE2,INTEGER  LINK)
CONSTINTEGER  MAX RECS=1000
OWNRECORDARRAYFORMAT  RECSF(1:MAX RECS)(RECF)
OWNRECORDARRAYNAME  RECS(RECF)
OWNINTEGERNAME  FREE,PAIRS
OWNINTEGER  FSYS
CONSTSTRINGNAME  DATE=X'80C0003F',TIME=X'80C0004B'
!
!
SYSTEMROUTINESPEC  MOVE(INTEGER  L,F,T)
EXTERNALROUTINESPEC  PROMPT(STRING (15) S)
EXTERNALROUTINESPEC  GET AV FSYS(INTEGERNAME  N,INTEGERARRAYNAME  A)
EXTERNALINTEGERFNSPEC  DCONNECT(STRING (6)USER,STRING (11)FILE, C 
  INTEGER  FSYS,MODE,APF,INTEGERNAME  SEG,GAP)
EXTERNALINTEGERFNSPEC  DDISCONNECT(STRING (6)USER,STRING (11)FILE, C 
  INTEGER  FSYS,D)
EXTERNALSTRINGFNSPEC  DERRS(INTEGER  FLAG)
EXTERNALINTEGERFNSPEC  NWFILEAD(STRING (15) F,INTEGER  PGS)
EXTERNALROUTINESPEC  DEFINE(STRING (255) S)
EXTERNALROUTINESPEC  RSTRG(STRINGNAME  S)
EXTERNALROUTINESPEC  DISCONNECT(STRING (255) S)
EXTERNALINTEGERFNSPEC  EXIST(STRING (31) F)
EXTERNALINTEGERFNSPEC  WRFILEAD(STRING (15) F)
!
!***********************************************************************
!
INTEGERFN  CONNECT AND MAP
INTEGER  CAD,NA,FLAG,I,SEG,GAP
INTEGERARRAY  A(0:63)
CAD=0
GET AV FSYS(NA,A)
CYCLE  I=0,1,NA-1
  FSYS=A(I)
  SEG=0; GAP=0
  FLAG=DCONNECT("VOLUMS","TAPEPAIRS",FSYS,3,0,SEG,GAP)
  UNLESS  FLAG=0 OR  FLAG=32 START 
    PRINTSTRING("CONNECT VOLUMS.TAPEPAIRS FAILS - ".DERRS(FLAG))
    NEWLINE
    RESULT =CAD
  FINISH 
  EXITIF  FLAG=0
REPEAT 
IF  FLAG=32 START 
  PRINTSTRING("VOLUMS.TAPEPAIRS NOT LOCATED")
  NEWLINE
  RESULT =CAD
FINISH 
! SO CONNECTED ON 'FSYS'
CAD=SEG<<18
FREE==INTEGER(CAD+32)
PAIRS==INTEGER(CAD+36)
RECS==ARRAY(CAD+40,RECSF)
RESULT =CAD
END ;       ! CONNECT AND MAP
!
!***********************************************************************
!
ROUTINE  DISCONNECT PAIRS
INTEGER  FLAG
FLAG=DDISCONNECT("VOLUMS","TAPEPAIRS",FSYS,0)
UNLESS  FLAG=0 START 
  PRINTSTRING("DISCONNECT VOLUMS.TAPEPAIRS FAILS - ".DERRS(FLAG))
  NEWLINE
FINISH 
END ;       ! DISCONNECT PAIRS
!
!***********************************************************************
!
INTEGERFN  FIND(STRING (6) TAPE)
INTEGER  LINK
RECORDNAME  REC(RECF)
LINK=PAIRS
WHILE  LINK#0 CYCLE 
  REC==RECS(LINK)
  IF  REC_TAPE1=TAPE OR  REC_TAPE2=TAPE THENEXIT 
  LINK=REC_LINK
REPEAT 
RESULT =LINK
END ;         ! FN FIND
!
!***********************************************************************
!
EXTERNALROUTINE  GET PAIR(STRING (255) TAPE)
INTEGER  FLAG
RECORDNAME  REC(RECF)
UNLESS  LENGTH(TAPE)=6 START 
  PRINTSTRING("FORM IS   GET PAIR(TAPE ID)
")
  RETURN 
FINISH 
!
FLAG=CONNECT AND MAP
RETURNIF  FLAG=0
FLAG=FIND(TAPE)
IF  FLAG=0 START 
  PRINTSTRING(TAPE." NOT FOUND IN LIST")
FINISHELSESTART 
  REC==RECS(FLAG)
  PRINTSTRING(REC_TAPE1."-".REC_TAPE2)
FINISH 
NEWLINE
DISCONNECT PAIRS
END ;         ! ROUTINE GET RECORD
!
!***********************************************************************
!
EXTERNALROUTINE  ADD PAIR(STRING (255) S)
RECORDNAME  REC(RECF)
INTEGER  FLAG,I
STRING (255)ARRAY  TAPE(1:2)
!
UNLESS  S->TAPE(1).(",").TAPE(2) ANDC 
                               LENGTH(TAPE(1))=LENGTH(TAPE(2))=6 START 
  PRINTSTRING("FORM IS   ADD PAIR(TAPE1,TAPE2)
")
  RETURN 
FINISH 
!
FLAG=CONNECT AND MAP
RETURNIF  FLAG=0
!
! CHECK IF EITHER TAPE ALREADY IN LIST
CYCLE  I=1,1,2
  FLAG=FIND(TAPE(I))
  IF  FLAG#0 START 
    REC==RECS(FLAG)
    PRINTSTRING(TAPE(I)." ALREADY IN LIST  ** ")
    PRINTSTRING(REC_TAPE1."-".REC_TAPE2." **")
    NEWLINE
    ->OUT
  FINISH 
REPEAT 
! SO NEITHER THERE. SEE IF THERE IS SPACE
IF  FREE=0 START 
  PRINTSTRING("LIST FULL!!")
  NEWLINE
  ->OUT
FINISH 
! SO A SLOT AVAILABLE
REC==RECS(FREE)
I=FREE
FREE=REC_LINK
REC_TAPE1=TAPE(1)
REC_TAPE2=TAPE(2)
REC_LINK=PAIRS;    ! FRONT
PAIRS=I;    ! THISD ONE
PRINTSTRING("DONE")
NEWLINE
!
OUT:
DISCONNECT PAIRS
END ;          ! ROUTINE ADD PAIR
!
!***********************************************************************
!
EXTERNALROUTINE  ADD PAIRS(STRING (255) S)
RECORDNAME  REC(RECF)
INTEGER  FLAG,I
STRING (255)ARRAY  TAPE(1:2)
!
FLAG=CONNECT AND MAP
RETURNIF  FLAG=0
!
CYCLE 
  PROMPT("TAPE1,TAPE2: ")
   
  RSTRG(S)
  IF  S="END" THENEXIT 
  UNLESS  S->TAPE(1).(",").TAPE(2) ANDC 
                      LENGTH(TAPE(1))=LENGTH(TAPE(2))=6 START 
    PRINTSTRING("FORM IS   TAPE1,TAPE2
")
    CONTINUE 
  FINISH 
  !
  ! CHECK IF EITHER TAPE ALREADY IN LIST
  CYCLE  I=1,1,2
    FLAG=FIND(TAPE(I))
    IF  FLAG#0 START 
      REC==RECS(FLAG)
      PRINTSTRING(TAPE(I)." ALREADY IN LIST  ** ")
      PRINTSTRING(REC_TAPE1."-".REC_TAPE2." **")
      NEWLINE
      EXIT 
    FINISH 
  REPEAT 
  CONTINUEIF  FLAG#0
  ! SO NEITHER THERE. SEE IF THERE IS SPACE
  IF  FREE=0 START 
    PRINTSTRING("LIST FULL!!")
    NEWLINE
    EXIT 
  FINISH 
  ! SO A SLOT AVAILABLE
  REC==RECS(FREE)
  I=FREE
  FREE=REC_LINK
  REC_TAPE1=TAPE(1)
  REC_TAPE2=TAPE(2)
  REC_LINK=PAIRS;    ! FRONT
  PAIRS=I;    ! THISD ONE
  PRINTSTRING("DONE")
  NEWLINE
REPEAT 
!
DISCONNECT PAIRS
END ;          ! ROUTINE ADD PAIRS
!
!***********************************************************************
!
EXTERNALROUTINE  REMOVE PAIR(STRING (255) TAPE)
RECORDNAME  REC(RECF)
INTEGER  FLAG,I
INTEGERNAME  LINK
UNLESS  LENGTH(TAPE)=6 START 
  PRINTSTRING("FORM IS   REMOVE PAIR(TAPE ID)
")
  RETURN 
FINISH 
!
FLAG=CONNECT AND MAP
RETURNIF  FLAG=0
!
LINK==PAIRS
WHILE  LINK#0 CYCLE 
  REC==RECS(LINK)
  IF  REC_TAPE1=TAPE OR  REC_TAPE2=TAPE START 
    I=REC_LINK;   ! NEXT USED
    REC_LINK=FREE;    ! FIRST FREE
    FREE=LINK;    ! THIS ONE
    LINK=I;       ! JOIN UP USED
    PRINTSTRING(REC_TAPE1."-".REC_TAPE2." REMOVED")
    NEWLINE
    ->OUT
  FINISH 
  LINK==REC_LINK
REPEAT 
PRINTSTRING(TAPE." NOT FOUND IN LIST")
NEWLINE
!
OUT:
DISCONNECT PAIRS
END ;         ! ROUTINE REMOVE PAIR
!
!***********************************************************************
!
EXTERNALROUTINE  INIT TAPE PAIRS(STRING (255) S)
! CREATES AND INITIALISES TAPEPAIRS FILE IN THIS PROCESS.
! THE FILE MUST THEN BE TRANSFERRED TO VOLUMS. THIS FUNCTION
! IS INTENDED TO BE DONE BY VOLUMS COMMAND V/NEW PAIRS LIST
! THIS ROUTINE IS SUPPLIED FOR CURIOUS USE.
RECORDNAME  REC(RECF)
INTEGER  CAD,I,PGS
!
PRINTSTRING("THIS IS MORE EASILY DONE BY 'V/NEW PAIRS LIST'
")
PROMPT("PROCEED? ")
RSTRG(S)
UNLESS  S->("Y").S THENRETURN 
!
IF  EXIST("TAPEPAIRS")#0 START 
  PRINTSTRING("FILE 'TAPEPAIRS' ALREADY EXISTS
")
  RETURN 
FINISH 
!
PGS=(MAX RECS*20+8+32+4095)>>12;   ! E PAGES
CAD=NWFILEAD("TAPEPAIRS",PGS)
RETURNIF  CAD=0
!
INTEGER(CAD)=PGS<<12;    ! END
INTEGER(CAD+4)=32;      ! START
INTEGER(CAD+8)=PGS<<12; ! SIZE
!
FREE==INTEGER(CAD+32)
PAIRS==INTEGER(CAD+36)
RECS==ARRAY(CAD+40,RECSF)
PAIRS=0
CYCLE  I=1,1,MAX RECS-1
  REC==RECS(I)
  REC=0
  REC_LINK=I+1
REPEAT 
FREE=1
RECS(MAX RECS)=0
DISCONNECT("TAPEPAIRS")
PRINTSTRING("FILE 'TAPEPAIRS' CREATED AND INITIALISED.
BEFORE FURTHER USE DO:
  1. CHERISH TAPEPAIRS
  2. CHECK ALL FSYS FOR VOLUMS.TAPEPAIRS AND DESTROY IF FOUND
  3. TRANSFER TAPEPAIRS TO VOLUMS ON SLOAD DISC
  4. PERMIT IT FROM VOLUMS.
")
END ;       ! ROUTINE INIT TAPE PAIRS
!
!***********************************************************************
!
EXTERNALROUTINE  LIST PAIRS(STRING (255) OUTDEV)
INTEGER  FLAG,LINK,WIDTH,I
RECORDNAME  REC(RECF)
!
UNLESS  LENGTH(OUTDEV)>0 START 
  PRINTSTRING("FORM IS   LIST PAIRS(OUTDEV)
")
  RETURN 
FINISH 
!
IF  OUTDEV=".OUT" THEN  WIDTH=72 ELSE  WIDTH=120
!
FLAG=CONNECT AND MAP
RETURNIF  FLAG=0
LINK=PAIRS
DEFINE("1,".OUTDEV)
SELECTOUTPUT(1)
NEWLINE
PRINTSTRING("TAPE PAIRS LIST ON ".DATE." AT ".TIME)
NEWLINES(2)
I=WIDTH
WHILE  LINK#0 CYCLE 
  REC==RECS(LINK)
  PRINTSTRING(REC_TAPE1."-".REC_TAPE2."   ")
  I=I-16
  IF  I<16 THEN  NEWLINE AND  I=WIDTH
  LINK=REC_LINK
REPEAT 
NEWLINE
PRINTSTRING("END OF LIST")
NEWLINE
SELECTOUTPUT(0)
DISCONNECT PAIRS
END ;        ! ROUTINE LIST PAIRS
!
!***********************************************************************
!
EXTERNALROUTINE  REVERSE PAIRS(STRING (255) S)
!
! PRIMARIES BECOME SECONDARIES AND V.V. IN A LOCAL COPY OF LIST
!
RECORDNAME  REC(RECF)
INTEGER  CAD,LINK
STRING (6) TAPE
!
IF  EXIST("TAPEPAIRS")=0 START 
  PRINTSTRING("'TAPEPAIRS' DOES NOT EXIST
")
  RETURN 
FINISH 
CAD=WRFILEAD("TAPEPAIRS")
RETURNIF  CAD=0
!
FREE==INTEGER(CAD+32)
PAIRS==INTEGER(CAD+36)
RECS==ARRAY(CAD+40,RECSF)
!
LINK=PAIRS
WHILE  LINK#0 CYCLE 
  REC==RECS(LINK)
  TAPE=REC_TAPE2
  REC_TAPE2=REC_TAPE1
  REC_TAPE1=TAPE
  LINK=REC_LINK
REPEAT 
PRINTSTRING("DONE")
NEWLINE
DISCONNECT("TAPEPAIRS")
END ;      ! ROUTINE REVERSE PAIRS
!
!***********************************************************************
!
EXTERNALROUTINE  COPY PAIRSLIST(STRING (255) S)
!
! COPIES PAIRSLIST TO 'TAPEPAIRS' IN THIS PROCESS
!
INTEGER  CADFROM,CADTO,PGS
!
IF  EXIST("TAPEPAIRS")#0 START 
  PRINTSTRING("FILE 'TAPEPAIRS' ALREADY EXISTS
")
  RETURN 
FINISH 
!
PGS=(MAX RECS*20+8+32+4095)>>12;   ! EPAGES
CADTO=NWFILEAD("TAPEPAIRS",PGS)
RETURNIF  CADTO=0;   ! FAILED
!
CADFROM=CONNECT AND MAP
RETURNIF  CADFROM=0
!
MOVE(INTEGER(CADFROM+8),CADFROM,CADTO)
PRINTSTRING("COPY IN 'TAPEPAIRS'
")
DISCONNECT PAIRS
DISCONNECT("TAPEPAIRS")
END ;            ! ROUTINE COPY PAIRSLIST
!
ENDOFFILE