CONSTSTRING (30) VSN="- 4th March 1983"
RECORDFORMAT PARMF(INTEGER DEST,SRCE,P1,P2,P3,P4,P5,P6)
RECORDFORMAT SDDTFORM(INTEGER SER,PTSM,PROPADDR,STICK,CAA,GRCB AD, C
BYTEINTEGER LAST ATTN,DACTAD,HALFINTEGER HALFSPARE, C
INTEGER LAST TCB ADDR, STATE,IW1,CONCOUNT,SENSE1,SENSE2,SENSE3,SENSE4, C
REPSNO, BASE, ID, DLVN, MNEMONIC, C
STRING (6)LAB,BYTEINTEGER HWCODE, C
INTEGER ENTSIZE,URCB AD,SENSDAT AD,LOGMASK,UASTE, C
UA SIZE,UA AD,TIMEOUT,PROPS,STATS1,STATS2, C
BYTEINTEGER QSTATE,PRIO,SP1,SP2, C
INTEGER LQLINK,UQLINK,CURCYL,SEMA,TRLINK,SPARE)
RECORDFORMAT PDDTFORM(INTEGER SER,PTS,PROPADDR,STATUS, C
CCA,RQA,LBA,ALA,STATE,IW1,IW2,SENSE1,SENSE2,SENSE3,SENSE4,C
REPSNO,BASE,ID,DLVN,MNEMONIC,STRING (6)LAB,BYTEINTEGER MECH)
!
RECORDFORMAT PROPFORM(INTEGER TRACKS,CYLS,PPERTRK,BLKSIZE,TOTPAGES,C
RQBLKSIZE,LBLKSIZE,ALISTSIZE,FLAGS,SECTINDX)
!
RECORDFORMAT TCBF(INTEGER CMD,STE,DATA LEN,DATA AD,NEXT TCB,RESP, C
(BYTEINTEGER INIT MECH,INIT CMASK,INIT SMASK,INIT MODE,INIT FN,INIT SEG, C
HALFINTEGER INIT CYL,BYTEINTEGER INIT HEAD,INIT HDLIMIT, C
HALFINTEGER INIT SCYL,INIT SHEAD,BYTEINTEGER INIT SECT,INIT OFFSET C
OR INTEGER PRE0,PRE1,PRE2,PRE3), C
INTEGER POST0,POST1,POST2,POST3,POST4,POST5,POST6,POST7)
RECORDFORMAT RQBFORM(INTEGER LSEGPROP,LSEGADDR,LBPROP,LBADDR,ALPROP,C
ALADDR,W6,W7,W8)
!
RECORDFORMAT SCOUNTFORM(BYTEINTEGER ID,SD1,SD2,HFLG,C1,C2,H1,H2,SCTR, C
KL,DL1,DL2)
RECORDFORMAT PCOUNTFORM(BYTEINTEGER HFLG,C1,C2,H1,H2,SCTR,KL,DL1,DL2)
!
!*
!* Communications record format - extant from CHOPSUPE 22B onwards *
!*
RECORDFORMAT COMF(INTEGER OCPTYPE,SLIPL,SBLKS,SEPGS,NDISCS,DLVNADDR, C
(INTEGER GPCTABSIZE,GPCA OR INTEGER DCUTABSIZE,DCUA), C
INTEGER SFCTABSIZE,SFCA,SFCK,DIRSITE, C
DCODEDA,SUPLVN,TOJDAY,DATE0,DATE1,DATE2, C
TIME0,TIME1,TIME2,EPAGESIZE,USERS,CATTAD,SERVAAD, C
BYTEINTEGER NSACS,RESV1, C
(BYTEINTEGER SACPORT1,SACPORT0 OR BYTEINTEGER C
OCP1 SCU PORT,OCP0 SCU PORT), BYTEINTEGER C
NOCPS,SYSTYPE,OCPPORT1,OCPPORT0,INTEGER ITINT, C
(INTEGER CONTYPEA,GPCCONFA,FPCCONFA,SFCCONFA OR C
INTEGER DCU2HWNA,DCUCONFA,MIBA,SP0), C
INTEGER BLKADDR,RATION, C
(INTEGER SMACS OR INTEGER SCUS), C
INTEGER TRANS,LONGINTEGER KMON, C
INTEGER DITADDR,SMACPOS,SUPVSN,PSTVA,SECSFRMN,SECSTOCD, C
SYNC1DEST,SYNC2DEST,ASYNCDEST,MAXPROCS,INSPERSEC,ELAPHEAD, C
COMMSRECA,STOREAAD,PROCAAD,SFCCTAD,DRUMTAD,TSLICE,FEPS, C
MAXCBT,PERFORMAD,BYTEINTEGER DAPNO,DAPBLKS,DAPUSER,DAPSTATE, C
INTEGER DAP1,DAPBMASK,SP1,SP2,SP3, C
LSTL,LSTB,PSTL,PSTB,HKEYS,HOOT,SIM,CLKX,CLKY,CLKZ, C
HBIT,SLAVEOFF,INHSSR,SDR1,SDR2,SDR3, C
SDR4,SESR,HOFFBIT,BLOCKZBIT,BLKSHIFT,BLKSIZE,END)
CONSTRECORD (COMF)NAME COM=X'80C00000'
!
CONSTINTEGER YES=1,NO=0
CONSTINTEGER GETPAGE=X'50000',RETURNPAGE=X'60000'
CONSTINTEGER DISCSNO=X'00200000'
CONSTINTEGER SD=X'58000000'; ! STRING DESRCPTR FOR ADDRSS LIST
!
INTEGERFNSPEC STE(INTEGER AD)
EXTERNALINTEGERFNSPEC DLOWER ACR(INTEGER ACR)
EXTERNALROUTINESPEC DOUT11(RECORD (PARMF)NAME P)
EXTERNALROUTINESPEC DPON(RECORD (PARMF)NAME P)
EXTERNALROUTINESPEC DPOFF(RECORD (PARMF)NAME P)
EXTERNALROUTINESPEC PROMPT(STRING (15) S)
EXTERNALROUTINESPEC RSTRG(STRINGNAME S)
EXTERNALROUTINESPEC RDINT(INTEGERNAME I)
EXTERNALROUTINE FORMAT(STRING (63) S)
!***********************************************************************
!* FORMATS A DISC FROM DATA IN THE PROPERTY TABLE *
!***********************************************************************
STRING (8)FNSPEC STRHEX(INTEGER VALE)
RECORD (PARMF) P
RECORD (SCOUNTFORM)NAME SCOUNT
RECORD (PCOUNTFORM)NAME PCOUNT
RECORD (SDDTFORM)NAME SDDT
RECORD (PDDTFORM)NAME PDDT
RECORD (PROPFORM)NAME PROP
RECORD (TCBF)NAME TCB,INIT TCB
RECORD (RQBFORM)NAME RQB
BYTEINTEGERARRAYFORMAT DATAF(0:255)
BYTEINTEGERARRAYNAME DATA
INTEGER STATE,MNEM,SLOT,DSNO
INTEGER TRACK,LTRACK,UTRACK,CYL,LCYL,UCYL,PPTRK,BUFFA,CDEX,SERVNO
CONSTINTEGER KEYLEN=0; ! no keys
INTEGER SSERIES
CONSTINTEGER FDS160=X'39'
INTEGER I,J,ALA,LBA,DATAPTR,WCKD,RDATA,BUFFSIZE,HALF SIZE
*LSS_(16); *USH_-16; *AND_255; *ST_I
IF I=0 THEN SSERIES=NO ELSE SSERIES=YES
BUFFSIZE=1024*COM_EPAGESIZE
PRINTSTRING("Disc formatter ".VSN)
NEWLINE
PROMPT("Device: ")
RSTRG(S) WHILE LENGTH(S)#4
FOR I=0,1,3 CYCLE
BYTEINTEGER(ADDR(MNEM)+I)=CHARNO(S,I+1)
REPEAT
PROMPT("Lower cyl:")
RDINT(LCYL)
IF LCYL>=0 THEN PROMPT("Upper cyl:") AND RDINT(UCYL)
PROMPT("Lower track:")
RDINT(LTRACK)
IF LTRACK>=0 THEN PROMPT("Upper tracK:") AND RDINT(UTRACK)
!
! Get a 4K buffer
!
P_DEST=GET PAGE
P_SRCE=1
P_P1=M'FRMR'
DPON(P)
DPOFF(P) UNTIL P_P1=M'FRMR'
CDEX=P_P2
BUFFA=P_P4
SERVNO=P_DEST&X'FFFF0000'
!
! Claim the disc for private use
!
P_DEST=DISCSNO+1
P_P2=SERVNO+2
P_SRCE=SERVNO+1
P_P3=MNEM
P_P1=M'FRMR'
DPON(P)
DPOFF(P) UNTIL P_P1=M'FRMR'
SLOT=P_P3
DSNO=P_P2
IF DSNO=0 THEN C
PRINTSTRING("Formatter claim fails
") AND ->RETURNP
I=INTEGER(COM_DITADDR+SLOT*4)
IF SSERIES=YES START
SDDT==RECORD(I)
I=SDDT_PROPADDR
FINISH ELSE START
PDDT==RECORD(I)
I=PDDT_PROPADDR
FINISH
PROP==RECORD(I)
!
! Initialise the buffer
!
I=DLOWER ACR(2)
INTEGER(BUFFA)=M'EMAS'
IF SSERIES=YES THEN J=0 ELSE J=X'08CEF731'
! format pattern for P series - S series only uses buffer for init data
FOR I=BUFFA+4,4,BUFFA+BUFFSIZE-4 CYCLE
INTEGER(I)=J
REPEAT
DATA==ARRAY(BUFFA+BUFFSIZE-256,DATAF)
PRINTSTRING("Formatting with")
WRITE(PROP_BLKSIZE,2)
PRINTSTRING(" byte blocks
")
!
! Set up home address count (no key) and data fields for frmel
!
IF LCYL=-1 THEN LCYL=0 AND UCYL=PROP_CYLS-1
IF LTRACK=-1 THEN LTRACK=0 AND UTRACK=PROP_TRACKS-1
->FAIL UNLESS 0<=LTRACK<=UTRACK AND UTRACK<PROP_TRACKS AND C
0<=LCYL<=UCYL AND UCYL<PROP_CYLS
PPTRK=PROP_PPERTRK
!*
IF SSERIES=YES START
IF SDDT_PROPS>>24>=FDS160 START
PPTRK=PPTRK//2+1; ! _PPERTRK is really pages per 2 tracks
HALF SIZE=PROP_BLKSIZE//2
FINISH ELSE HALF SIZE=0
INIT TCB==RECORD(SDDT_UA AD)
TCB==RECORD(SDDT_UA AD+4*18)
INIT TCB=0
TCB=0
INIT TCB_NEXT TCB=ADDR(TCB)
INIT TCB_CMD=X'2C404081'; ! initialise: post&pre valid
J=STE(ADDR(DATA(0)))
INIT TCB_STE=J
TCB_STE=J
INIT TCB_DATA LEN=22; ! 21 bytes for EDS80s, 18 for EDS100 & 200
INIT TCB_DATA AD=ADDR(DATA(0))
DATA(2)=X'FE'; ! mask no status
DATA(4)=X'18'; ! seek cyl & haed
DATA(12)=0
FINISH
!
! Set up the CCW to write home address and sector 0 on track 0 cyl 0
!
CYL=LCYL
UNTIL CYL>UCYL CYCLE
TRACK=LTRACK
UNTIL TRACK>UTRACK CYCLE
IF SSERIES=YES START
DATA(5)=0; DATA(14)=0; ! sector 0
DATA(6)=CYL>>8
DATA(10)=CYL>>8
DATA(7)=CYL&255
DATA(11)=CYL&255
DATA(8)=TRACK
DATA(13)=TRACK
SCOUNT==RECORD(ADDR(DATA(24)))
SCOUNT_SD1=0; SCOUNT_SD2=0
SCOUNT_C1=CYL>>8; SCOUNT_C2=CYL&255
SCOUNT_H2=TRACK; SCOUNT_HFLG=0
SCOUNT==RECORD(ADDR(DATA(32)))
SCOUNT_C1=CYL>>8
SCOUNT_C2=CYL&255
SCOUNT_H1=0; SCOUNT_H2=TRACK
SCOUNT_HFLG=0
SCOUNT_KL=0; SCOUNT_DL1=X'00'
SCOUNT_DL2=80; SCOUNT_SCTR=0
FOR I=1,1,PPTRK CYCLE
SCOUNT==RECORD(ADDR(DATA(32))+12*I)
SCOUNT_C1=CYL>>8; SCOUNT_C2=CYL&255
SCOUNT_H2=TRACK
SCOUNT_KL=0
IF HALF SIZE>0 AND ((TRACK&1=0 AND I=PPTRK) OR C
(TRACK&1#0 AND I=1)) START
SCOUNT_DL1<-HALF SIZE>>8; ! the odd half-block
SCOUNT_DL2<-HALF SIZE
FINISH ELSE START
SCOUNT_DL1<-PROP_BLKSIZE>>8
SCOUNT_DL2<-PROP_BLKSIZE
FINISH
SCOUNT_SCTR=I
REPEAT
TCB_CMD=X'200040B3'
TCB_DATA LEN=8+12+12*PPTRK
TCB_DATA AD=ADDR(DATA(24))
TCB_RESP=0
INIT TCB_RESP=0
FINISH ELSE START
ALA=PDDT_ALA
LBA=PDDT_LBA
RQB==RECORD(PDDT_RQA)
DATA(0)=0; DATAPTR=0
PCOUNT==RECORD(ADDR(DATA(DATAPTR)))
PCOUNT_C1=CYL>>8; PCOUNT_C2=CYL&255
PCOUNT_H1=0
PCOUNT_H2=TRACK; PCOUNT_SCTR=0
PCOUNT_KL=0; PCOUNT_DL1=X'00'
PCOUNT_DL2=80; PCOUNT_HFLG=0
WCKD=X'1300'; RDATA=X'1200'
IF CYL=0 START
WCKD=X'2B00' IF TRACK<18;! OVERFLOW FORMAT
RDATA=X'401200'; ! IGNORE LENGTH CHK(FRM OFLOW)
FINISH
INTEGER(LBA)=X'84000300';! LIT,CHAIN & WRITE HA
INTEGER(ALA)=SD+5; ! HA = 5 BYTE
INTEGER(ALA+4)=ADDR(PCOUNT_HFLG)
INTEGER(LBA+4)=X'88000B02';! OPUT,DATACHN & WRITE S0
INTEGER(ALA+8)=SD+8; ! COUNT=8
INTEGER(ALA+12)=ADDR(PCOUNT_C1)
INTEGER(LBA+8)=X'84000B04';! OPUT &CHAIN
INTEGER(ALA+16)=SD+80; ! DATA (80)
INTEGER(ALA+20)=BUFFA
INTEGER(ALA+24)=SD+KEYLEN
INTEGER(ALA+28)=BUFFA; ! AL ENTRY FOR SECTN(N>1)
!
! the problem of inconsistent buffer & block sizes is difficult
! if address list entries are set to buffer size and id info to
! the blocksize then all will work if length checks are suppressed
! this avoids a proper format check if buffer smaller than blocks
! but has no other ill effects
!
INTEGER(ALA+32)=SD+BUFFSIZE
INTEGER(ALA+36)=BUFFA
DATAPTR=DATAPTR+9
LBA=LBA+12
ALA=ALA+40
FOR I=1,1,PPTRK CYCLE
PCOUNT==RECORD(ADDR(DATA(DATAPTR)))
PCOUNT_C1=CYL>>8; PCOUNT_C2=CYL&255
PCOUNT_H1=0
PCOUNT_H2=TRACK
PCOUNT_SCTR=I
PCOUNT_KL=KEYLEN
PCOUNT_DL1<-PROP_BLKSIZE>>8
PCOUNT_DL2<-PROP_BLKSIZE
INTEGER(LBA)=X'88000008'+WCKD+2*I;! WRITE CKD+DATCHAIN
INTEGER(ALA)=SD+8
INTEGER(ALA+4)=ADDR(PCOUNT_C1)
IF KEYLEN#0 THEN START
INTEGER(LBA+4)=X'88000006'+WCKD;! USE PREPARED ALIST ENTRIES
LBA=LBA+4
FINISH
INTEGER(LBA+4)=X'84C00008'+WCKD;! IGNRE LNG&SHRT BLKS(OLD FORMATS!)
LBA=LBA+8
ALA=ALA+8
DATAPTR=DATAPTR+9
REPEAT
!
! now reread the track with skip set to check correctly written
! can use the original addres list entries
!
UNLESS CYL=0 AND TRACK<18 START
INTEGER(LBA)=X'24000200'; ! READ &SKIP HA
INTEGER(LBA+4)=X'28000A02';! READ S0
INTEGER(LBA+8)=X'24000A04';! DATACHAIN FOR THE DATA AREA
LBA=LBA+12
FOR I=1,1,PPTRK CYCLE
INTEGER(LBA)=X'28000008'+2*I!RDATA;! READ CKD +DATA CHN
IF KEYLEN#0 THEN START
INTEGER(LBA+4)=X'28000006'!RDATA
LBA=LBA+4
FINISH
INTEGER(LBA+4)=X'24C00008'!RDATA
LBA=LBA+8
REPEAT
FINISH
!
INTEGER(LBA-4)=INTEGER(LBA-4)&X'F3FFFFFF';! KILL CHAINING
!
RQB_W7=X'1E001300'; ! SEEK CYL & DO CHAIN
RQB_W8=CYL<<16!TRACK; ! SEEK DATA
FINISH
P_DEST=DSNO
P_SRCE=SERVNO+2
IF SSERIES=NO START
P_P5=RQB_LSEGPROP
P_P6=RQB_LSEGADDR; ! TILL OUT18 PROVIDES THESE
FINISH
P_P2=CYL<<16!TRACK
P_P1=M'FRMR'
DOUT11(P)
IF P_P2#0 THEN START ; ! FAILURE
PRINTSTRING("Cyl ")
WRITE(CYL,1)
PRINTSTRING(" trk ")
WRITE(TRACK,1)
PRINTSTRING(" faulty
")
PRINTSTRING(STRHEX(P_P3)." ")
FOR I=0,4,12 CYCLE
PRINTSTRING(STRHEX(INTEGER(P_P6+I))." ")
REPEAT
NEWLINE
IF SSERIES=YES START
SCOUNT==RECORD(DATA(24))
SCOUNT_HFLG=2; ! defective track
DATA(14)=0
SCOUNT==RECORD(DATA(32))
SCOUNT_DL1=0; SCOUNT_DL2=80
TCB_CMD=X'200040B3'
TCB_DATA LEN=8+12
TCB_DATA AD=ADDR(DATA(24))
TCB_RESP=0
INIT TCB_RESP=0
FINISH ELSE START
DATA(0)=2; ! defective track
INTEGER(PDDT_LBA+4)=X'80000300';! write ha
FINISH
P_DEST=DSNO
P_SRCE=SERVNO+2
P_P1=M'FRME'
STATE=4
DPON(P)
DPOFF(P) UNTIL P_P1=M'FRME'
FINISH
TRACK=TRACK+1
REPEAT
PRINTSTRING("Cyl")
WRITE(CYL,1)
PRINTSTRING(" completed
")
CYL=CYL+1
REPEAT
IF INTEGER(BUFFA)#M'EMAS' AND KEYLEN#0 THEN ->FAIL
PRINTSTRING("Format complete
")
->FINISH
FAIL: PRINTSTRING("Formatter fails
")
FINISH:
!
! RETURN DEVICE
P_DEST=DISCSNO+1
P_P3=SLOT
STATE=0
P_P2=0
DPON(P)
RETURNP:
P_DEST=RETURN PAGE
P_SRCE=0; ! REPLY NOT WANTED
P_P2=CDEX
DPON(P); ! RETURN THE CORE PAGE
STRING (8) FN STRHEX(INTEGER VALUE)
STRING (8) S
CONSTBYTEINTEGERARRAY H(0:15)='0','1','2','3','4','5','6','7',
'8','9','A','B','C','D','E','F';
*LD_S; *LSS_8; *ST_(DR )
*INCA_1; *STD_TOS ; *STD_TOS
*LSS_0; *LUH_VALUE; *MPSR_X'24'; ! SET CC=1
*SUPK_L =8
*LD_TOS ; *ANDS_L =8,0,15; ! FORCE ZONE CODE TO 0
*LSS_H+4; *LUH_X'18000010'
*LD_TOS ; *TTR_L =8
RESULT =S
END
END
!*
RECORDFORMAT LABFORM(BYTEINTEGERARRAY VOL(0:5),BYTEINTEGER S1,C
S2,S3,S4,ACCESS,BYTEINTEGERARRAY RES(1:20),BYTEINTEGER C1,C2,C
AC1,AC2,TPC1,TPC2,BF1,BF2,BYTEINTEGERARRAY POINTER(0:3), C
IDENT(1:14))
SYSTEMROUTINESPEC ITOE(INTEGER AD,L)
EXTERNALROUTINE DLABEL(STRING (63) S)
!***********************************************************************
!* Labels a disc with a standard label *
!***********************************************************************
RECORD (PARMF) P
RECORD (LABFORM)NAME LABEL
RECORD (PCOUNTFORM)NAME PCOUNT
RECORD (SDDTFORM)NAME SDDT
RECORD (PDDTFORM)NAME PDDT
RECORD (PROPFORM)NAME PROP
RECORD (TCBF)NAME TCB
RECORD (RQBFORM)NAME RQB
BYTEINTEGERARRAYFORMAT VLABF(-100:80)
BYTEINTEGERARRAYNAME VLAB
INTEGER STATE,MNEM,SLOT,DSNO,IPL,CDEX,BA,OP,SERVNO
INTEGER BUFFSIZE
STRING (6)VOLID
INTEGER SSERIES
INTEGER I,ACT,J,ALA,LBA
*LSS_(16); *USH_-16; *AND_255; *ST_I
IF I=0 THEN SSERIES=NO ELSE SSERIES=YES
BUFFSIZE=1024*COM_EPAGESIZE
PRINTSTRING("Disc labeller ".VSN)
NEWLINE
PROMPT("Device: ")
RSTRG(S) WHILE LENGTH(S)#4
STRING(ADDR(STATE)+3)=S
PROMPT("IPL or normal:")
RSTRG(S) UNTIL S="IPL" OR S="NORMAL"
IF S="IPL" THEN IPL=1 ELSE IPL=0
PROMPT("6 char vol id:")
RSTRG(S) UNTIL LENGTH(S)=6
VOLID=S
P_DEST=GET PAGE
P_SRCE=1
P_P1=M'LBLR'
DPON(P)
DPOFF(P) UNTIL P_P1=M'LBLR'
SERVNO=P_DEST&X'FFFF0000'
CDEX=P_P2; BA=P_P4
I=DLOWER ACR(2)
VLAB==ARRAY(BA,VLABF)
CYCLE I=-100,1,80
IF -100<=I<=0 OR 32<=I<=43 THEN J=0 ELSE J=X'40'
VLAB(I)=J
REPEAT
P_DEST=DISCSNO+1
P_P1=M'LABR'
P_P2=SERVNO+2
P_SRCE=SERVNO+1
P_P3=MNEM
DPON(P)
DPOFF(P) UNTIL P_P1=M'LABR'
IF P_P2=0 THEN PRINTSTRING("Labeller claim fails
") AND -> RETURNP
SLOT=P_P3
DSNO=P_P2
I=INTEGER(COM_DITADDR+SLOT*4)
IF SSERIES=YES START
SDDT==RECORD(I)
I=SDDT_PROPADDR
FINISH ELSE START
PDDT==RECORD(I)
I=PDDT_PROPADDR
FINISH
PROP==RECORD(I)
!
! SET UP HOME ADDRESS COUNT (NO KEY) AND DATA FIELDS FOR LABEL
!
STRING(ADDR(VLAB(0)))=VOLID
LABEL==RECORD(ADDR(VLAB(1)))
ITOE(ADDR(LABEL),6); ! VOL ID IN EBCDIC
LABEL_ACCESS=X'C5'; ! C'E' FOR EMAS FILE SYTEMS
!
I=PROP_CYLS
LABEL_C1=I>>8
LABEL_C2=I&255
LABEL_TPC2=PROP_TRACKS
IF IPL=0 THEN LABEL_POINTER(3)=X'40' ELSE C
LABEL_POINTER(2)=8; ! X800 pages for IPL disc
!
IF SSERIES=YES START
TCB==RECORD(SDDT_UA AD)
TCB=0
TCB_STE=STE(ADDR(LABEL))
TCB_CMD=X'2000C013'
TCB_DATA LEN=80
TCB_DATA AD=ADDR(LABEL)
TCB_INIT SMASK=X'FE'
TCB_INIT FN=X'20'; ! restore
FINISH ELSE START
PCOUNT==RECORD(ADDR(VLAB(-8)))
PCOUNT_DL1=0
PCOUNT_DL2=80
!
! SET UP THE CCW TO WRITE HOME ADDRESS AND SECTOR 0 ON TRACK 0 CYL 0
!
ALA=PDDT_ALA
LBA=PDDT_LBA
RQB==RECORD(PDDT_RQA)
!
INTEGER(LBA)=X'84000300'; ! LIT,CHAIN & WRITE HA
INTEGER(ALA)=X'58000005'; ! HA = 5 BYTE
INTEGER(ALA+4)=ADDR(PCOUNT_HFLG)
INTEGER(LBA+4)=X'84000B02'; ! OPUT & WRITE S0
INTEGER(ALA+8)=X'58000058'; ! PCOUNT=8 DATA =80
INTEGER(ALA+12)=ADDR(PCOUNT_C1)
LBA=LBA+8
ALA=ALA+16
IF IPL=0 THEN ->DCHN
CYCLE I=1,1,PROP_PPERTRK
PCOUNT==RECORD(ADDR(PCOUNT)-10)
PCOUNT_SCTR=I; PCOUNT_KL=0
PCOUNT_DL1<-PROP_BLKSIZE>>8
PCOUNT_DL2<-PROP_BLKSIZE
INTEGER(LBA)=X'88002B00'+4*I;! WRITE SCKD & DATACHN
INTEGER(LBA+4)=X'84C02B02'+4*I
INTEGER(ALA)=SD+8
INTEGER(ALA+4)=ADDR(PCOUNT_C1)
INTEGER(ALA+8)=SD+BUFFSIZE
INTEGER(ALA+12)=BA
LBA=LBA+8
ALA=ALA+16
REPEAT
!
DCHN: INTEGER(LBA-4)=INTEGER(LBA-4)&X'F3FFFFFF'
RQB_W7=X'1E001300'; ! SEEK CYL&HD&SECTR0 & DO CHAIN
RQB_W8=0; ! SEEK DATA
FINISH
P_DEST=DSNO
P_SRCE=SERVNO+2
P_P1=M'LABW'
DPON(P)
DPOFF(P) UNTIL P_P1=M'LABW'
->FAIL IF P_P2#0
PRINTSTRING("Labelled ok")
->FINISH
FAIL: PRINTSTRING("Labeller fails")
FINISH:
!
! RETURN DEVICE
P_DEST=DISCSNO+1
P_P3=SLOT
STATE=0
P_P2=-1; ! UNLOAD AFTER LABELLING
DPON(P)
RETURNP:
P_DEST=RETURN PAGE
P_SRCE=0; ! REPLY NOT WANTED
P_P2=CDEX
DPON(P)
END
INTEGERFN STE(INTEGER AD)
INTEGER I,J
I=DLOWER ACR(1)
I=(AD&X'7FFFFFFF')>>18
J=COM_PSTVA+8*I
RESULT =INTEGER(J+4)!(INTEGER(J)>>29&2)
END
ENDOFFILE