!
! VSN 2 29AUG79 LABELS WITH DUMP INHIBITED ON TRACK 0
!
RECORDFORMAT  PARMF(INTEGER  DEST,SRCE,P1,P2,P3,P4,P5,P6)
RECORDFORMAT  DDTFORM(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)
!
RECORDFORMAT  RQBFORM(INTEGER  LSEGPROP,LSEGADDR,LBPROP,LBADDR,ALPROP,C 
      ALADDR,W6,W7,W8)
!
RECORDFORMAT  COUNTFORM(BYTEINTEGER  HFLG,C1,C2,H1,H2,SCTR,KL,DL1,DL2)
!

RECORDFORMAT  COMF(INTEGER  OCPTYPE,IPLDEV,SBLKS,SEPGS,NDISCS,  C 
         DLVNADDR,GPCTABSIZE,GPCA,SFCTABSIZE,SFCA,SFCK,DIRSITE,  C 
         DCODEDA,SUPLVN,TOJDAY,DATE0,DATE1,DATE2,  C 
         TIME0,TIME1,TIME2,EPAGESIZE,USERS,CATTAD,EXDQADDR,  C 
         BYTEINTEGER  NSACS,RESV1,SACPORT1,SACPORT0, C 
         NOCPS,RESV2,OCPPORT1,OCPPORT0, C 
         INTEGER  ITINT,CONTYPEA,GPCCONFA,FPCCONFA,SFCCONFA, C 
         BLKADDR,RATION,SMACS,TRANS,LONGINTEGER  KMON,  C 
         INTEGER  DITADDR)
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))
CONSTINTEGER  DISCSNO=X'00200000', C 
      PDISCSNO=X'210000',RRSNO=X'220000'
CONSTINTEGER  SD=X'58000000';           ! STRING DESRCPTR FOR ADDRSS LIST
CONSTINTEGER  BUFFSIZE=4096
!
EXTERNALROUTINESPEC  DPON(RECORDNAME  P)
EXTERNALROUTINESPEC  DPOFF(RECORDNAME  P)
EXTERNALROUTINESPEC  PROMPT(STRING (63)S)
SYSTEMROUTINESPEC  ITOE(INTEGER  AD,L)
EXTERNALROUTINE  DLABEL(STRING (63) S)
!***********************************************************************
!*    LABELS A DISC WITH A STANDARD LABEL                              *
!***********************************************************************
ROUTINESPEC  READ AS STRING(STRINGNAME  S)
RECORD  P(PARMF)
RECORDNAME  LABEL(LABFORM)
RECORDNAME  COUNT(COUNTFORM)
RECORDNAME  DDT(DDTFORM)
RECORDNAME  PROP(PROPFORM)
RECORDNAME  COM(COMF)
RECORDNAME  RQB(RQBFORM)
BYTEINTEGERARRAYFORMAT  VLABF(-100:80)
BYTEINTEGERARRAYNAME  VLAB
INTEGER  STATE,MNEM,SLOT,DSNO,IPL,CDEX,BA,OP,SERVNO
CONSTINTEGER  GETPAGE=X'50000',RETURNPAGE=X'60000'
STRING (6)VOLID
INTEGER  I,ACT,J,ALA,LBA
      COM==RECORD(X'80C00000')
      IF  LENGTH(S)#4 THEN  PRINTSTRING("LABEL DEVICE ".S."??
") AND  RETURN 
      STRING(ADDR(STATE)+3)=S;          ! SET MNEM
      PROMPT("IPL OR NORMAL:")
A:    READ AS STRING(S)
      IF  S="IPL" THEN  IPL=1 ELSE  START 
         IPL=0
         ->A UNLESS  S="NORMAL"
      FINISH 
B:    PROMPT("6 CHAR VOL ID:")
      READ AS STRING(S)
      ->B UNLESS  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
      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
      DDT==RECORD(INTEGER(COM_DITADDR+SLOT*4))
      PROP==RECORD(DDT_PROPADDR)
!
! 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
!
      COUNT==RECORD(ADDR(VLAB(-8)))
      COUNT_DL1=0
      COUNT_DL2=80
!      %IF IPL#0 %THEN COUNT_HFLG=X'20';      ! STORE DUMP&IPL ALLOWED
!
! SET UP THE CCW TO WRITE HOME ADDRESS AND SECTOR 0 ON TRACK 0 CYL 0
!
      ALA=DDT_ALA
      LBA=DDT_LBA
      RQB==RECORD(DDT_RQA)
!
      INTEGER(LBA)=X'84000300';         ! LIT,CHAIN & WRITE HA
      INTEGER(ALA)=X'58000005';         ! HA = 5 BYTE
      INTEGER(ALA+4)=ADDR(COUNT_HFLG)
      INTEGER(LBA+4)=X'84000B02';       ! OPUT & WRITE S0
      INTEGER(ALA+8)=X'58000058';       ! COUNT=8 DATA =80
      INTEGER(ALA+12)=ADDR(COUNT_C1)
      LBA=LBA+8
      ALA=ALA+16
      LABEL_POINTER(3)=X'40'
      IF  IPL=0 THEN  ->DCHN
      LABEL_POINTER(2)=8
      LABEL_POINTER(3)=0;               ! X800 PAGES FOR SYSTEM ON IPLDISC
      CYCLE  I=1,1,PROP_PPERTRK
         COUNT==RECORD(ADDR(COUNT)-10)
         COUNT_SCTR=I; COUNT_KL=0
         COUNT_DL1<-PROP_BLKSIZE>>8
         COUNT_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(COUNT_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
      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)
ROUTINE  READ AS STRING(STRINGNAME  S)
INTEGER  I
      S=""
      CYCLE 
         READ SYMBOL(I)
         EXIT  IF  I=10
         S=S.TOSTRING(I) IF  I>32
      REPEAT 
END 
END 
ENDOFFILE