cckdload.hla

*/* -------------------------------------------------------------------
*   Restore a cckd file to a real dasd unit.
*   The dasd unit must be offline.
*
*   Invocation:
*      //step   EXEC PGM=CCKDLOAD,PARM=unit
*      //STEPLIB  DD DISP=SHR,DSN=apf.authorized.loadlib
*      //SYSPRINT DD SYSOUT=*
*      //SYSUT1   DD DISP=SHR,DSN=cckd.file
*
* ------------------------------------------------------------------ */

*/* -------------------------------------------------------------------
*   local macros
* ------------------------------------------------------------------ */
         MACRO
&L      #LLE  &R,&A                      load little-endian
&L       IC   &R,&A
         ICM  &R,2,1+&A
         ICM  &R,4,2+&A
         ICM  &R,8,3+&A
         MEND

         MACRO
&L      #LHLE &R,&A                      load halfword little-endian
&L       SLR  &R,&R
         IC   &R,&A
         ICM  &R,2,1+&A
         MEND

         MACRO
&L      #LC   &R,&A                      load conditional
&L       TM   cdevhdr_options,CCKD_BIGENDIAN
         BO   #LC&SYSNDX.A
        #LLE  &R,&A
         B    #LC&SYSNDX.B
#LC&SYSNDX.A  L  &R,&A
#LC&SYSNDX.B  DS 0H
         MEND

         MACRO
&L      #LHC  &R,&A                      load halfword conditional
&L       TM   cdevhdr_options,CCKD_BIGENDIAN
         BO   #LHC&SYSNDX.A
        #LHLE &R,&A
         B    #LHC&SYSNDX.B
#LHC&SYSNDX.A SLR &R,&R
              ICM &R,3,&A
#LHC&SYSNDX.B DS  0H
         MEND

         MACRO
&L      #READ &OFFSET=,&LENGTH=,&ADDR=   read a cckd block
&L       LA   r1,pl
.*
         AIF  ('&OFFSET'(1,1) EQ '(').r1
         LA   re,&OFFSET
         AGO  .x1
.r1      LR   re,&OFFSET(1)
.x1      ANOP
.*
         AIF  ('&LENGTH'(1,1) EQ '(').r2
         LA   rf,&LENGTH
         AGO  .x2
.r2      LR   rf,&LENGTH(1)
.x2      ANOP
.*
         AIF  ('&ADDR'(1,1) EQ '(').r3
         LA   r0,&ADDR
         AGO  .x3
.r3      LR   r0,&ADDR(1)
.x3      ANOP
.*
         STM  re,r0,0(r1)
         L    rf,=A(readr)
         BALR re,rf
         MEND

         MACRO
&L      #WRITE &ADDR=                    write a ckd track image
.*
         AIF  ('&ADDR'(1,1) EQ '(').r1
&L       LA   r1,&ADDR
         AGO  .x1
.r1      ANOP
&L       LR   r1,&ADDR(1)
.x1      ANOP
         L    rf,=A(writer)
         BALR re,rf
         MEND

         MACRO
&L      #MSG   &MSG,&TYPE=CALL           messages
         LCLA  &A,&N,&O
         LCLC  &C
         GBLA  &MSG_IX
         GBLC  &MSGS(256)
         AIF   ('&TYPE' EQ 'CALL').CALL,                               x
               ('&TYPE' EQ 'GEN').GEN
         MNOTE 8,'Invalid type specified'
         MEXIT
.*
.CALL    ANOP
&MSG_IX  SETA  &MSG_IX+1
&MSGS(&MSG_IX) SETC '&MSG'
&L       L     re,=A(#MSG&MSG_IX)
         LA    rf,L'#MSG&MSG_IX
&A       SETA  2
&O       SETA  0
&N       SETA  N'&SYSLIST
         AGO   .PL0
.PLLOOP  ANOP
         LA    re,&SYSLIST(&A)
&A       SETA  &A+1
         AIF   (&A GT &N).PLX14
         LA    rf,&SYSLIST(&A)
&A       SETA  &A+1
.PL0     ANOP
         AIF   (&A GT &N).PLX15
         LA    r0,&SYSLIST(&A)
&A       SETA  &A+1
         AIF   (&A GT &N).PLX0
         LA    r1,&SYSLIST(&A)
&A       SETA  &A+1
         AIF   (&A GT &N).PLX1
         STM   re,r1,pl+&O
&O       SETA  &O+16
         AGO   .PLLOOP
.PLX14   ST    re,pl+&O
         AGO   .CALL2
.PLX15   STM   re,rf,pl+&O
         AGO   .CALL2
.PLX0    STM   re,r0,pl+&O
         AGO   .CALL2
.PLX1    STM   re,r1,pl+&O
.CALL2   LA    r1,pl
         L     rf,=a(msgr)
         BALR  re,rf
         MEXIT
.*
.GEN     ANOP
         AIF   ('&L' EQ '').GENNOL
&L       DS    0H
.GENNOL  ANOP
&A       SETA  1
.GENLOOP AIF   (&A GT &MSG_IX).MEND
#MSG&A   DC    C&MSGS(&A)
&A       SETA  &A+1
         AGO   .GENLOOP
.MEND    MEND

*/* -------------------------------------------------------------------
*   mainline routine
* ------------------------------------------------------------------ */
main     CSECT ,
main     AMODE 31
main     RMODE ANY
         B     init-*(,rf)
         DC    AL1(init-*)
pgmid    DC    CL8'cckdload'
vrm      DC    X'000102'          version 0 release 1 modlvl 2  CZV70
         DC    C' &SYSDATE &SYSTIME '
init     SAVE  (14,12)
         LR    rc,rf              set base reg
         USING main,rc
         LA    ra,4095(,rc)       set 2nd base reg
         USING main+4095,ra
         LR    r2,r1              copy parm reg

*/* -------------------------------------------------------------------
*   obtain and initialize workareas
* ------------------------------------------------------------------ */
         STORAGE OBTAIN,LENGTH=workl,BNDRY=PAGE get work area
         ST    r1,8(,rd)          chain save areas
         ST    rd,4(,r1)
         LR    rd,r1              set area base
         USING work,rd
         MVC   workid,pgmid       set area identifier
         LA    r0,work+8          clear the area
         L     r1,=a(workl-8)
         SLR   rf,rf
         MVCL  r0,re
         STORAGE OBTAIN,LENGTH=work24l,LOC=BELOW,BNDRY=PAGE 24 bit area
         LR    rb,r1              set 24-bit area base
         USING work24,rb
         MVC   work24id,pgmid     set 24-bit area identifier
         LA    r0,work24+4        clear the 24-bit area
         L     r1,=a(work24l-4)
         SLR   rf,rf
         MVCL  r0,re

*/* -------------------------------------------------------------------
*   process PARM= : <unit-address>
* ------------------------------------------------------------------ */
         N     r2,=A(X'7fffffff') test parameter reg
         BZ    Enoparm             invalid parameter list
         L     r3,0(,r2)          point to parameters
         N     r3,=A(X'7fffffff')  test parameter reg
         BZ    Enoparm              invalid parameter list
         LH    r4,0(,r3)          get length of parameters
         LTR   r4,r4               test length
         BNP   Enoparm              invalid parameter list
         BCTR  r4,0               decrement for EX
         LA    r3,2(,r3)          point past length
         SLR   r2,r2              clear TRT register

*/*      1st and only parm is unit address in hex                    */
         XC    dw,dw              clear double-word work area
         CH    r4,=Y(4)           check 2nd parm length
         BNL   Ebadparm           error if too long
         EX    r4,parmmvc         copy 2nd parameter
*/*      MVC   dw(0),0(r3)        *** executed ***                   */
         TR    dw,upcase          convert to uppercase
         EX    r4,parmhexc        test if all hex digits
*/*      TRT   drwdw(0),hexchars  *** executed ***                   */
         BNZ   Ebadparm            error if not
         EX    r4,parmhex         convert to hex digits
*/*      TR    dw(0),hextab       *** executed ***                   */
         LA    r5,1(,r4)
         EX    r5,parmpack        get hex value
*/*      PACK  dw2,dw(0)          *** executed ***                   */
         SLR   r5,r5              clear unit address
         ICM   r5,3,dw2+5         load hex value
         STH   r5,unit            save unit address

*/* -------------------------------------------------------------------
*   print initialization message
* ------------------------------------------------------------------ */
         TIME  DEC
         STM   r0,r1,ctime        get time and date of load
         LA    r1,ctime
         LA    r0,dtime
         BAL   re,datetime
        #MSG   '%s:8 %d:1.%d:1.%d:1 load starting at %s:20',           X
               pgmid,vrm,vrm+1,vrm+2,dtime

*/* -------------------------------------------------------------------
*   open the cckd file
* ------------------------------------------------------------------ */
         MVC   sysut1,m_sysut1                   copy the model dcb
         MVC   sysut1e,m_sysut1e                 copy the model dcbe
ut1      USING IHADCB,sysut1
         LA    r1,sysut1e                        set dcbe address
         ST    r1,ut1.DCBDCBE                     in the dcb
         DEVTYPE ut1.DCBDDNAM,devta              get device info
         LTR   rf,rf                             test return code
         BNZ   Edevterr                           error if non-zero
         TM    devta+2,UCB3DACC                  check for dasd device
         BNO   Enotdasd1                          error if not on dasd
         MVC   openl,m_openl                     copy model open list
         OPEN  (sysut1,INPUT),MODE=31,MF=(E,openl) open the cckd file
         TM    ut1.DCBOFLGS,DCBOFOPN             did cckd file open ?
         BNO   Eopenerr                           no, open error
         CLC   ut1.DCBBLKSI,=Y(16384)       check block size    CZV70
         BNE   Ebadblksz                    error if not 16384  CZV70
         MVC   pl(l_tcpl),m_tcpl                 copy model parm list
         TRKCALC FUNCTN=TRKCAP,TYPE=devta+3,RKDD==x'01004000',  CZV70  x
               REGSAVE=YES,MF=(E,pl)             calculate blks/trk
         LTR   rf,rf                             test return code
         BNZ   Etrkcalc                           error if non-zero
         ST    r0,bpt                            save blks/trk

*/* -------------------------------------------------------------------
*   read the CKDDASD_DEVHDR
* ------------------------------------------------------------------ */
        #READ  OFFSET=0,LENGTH=CKDDASD_DEVHDR_SIZE,ADDR=devhdr
         USING CKDDASD_DEVHDR,devhdr
         TR    devhdr_devid,A2E
         CLC   devhdr_devid,=C'CKD_C370'         check devid
         BNE   Edevid
        #LLE   r1,devhdr_heads                   get number of heads
         ST    r1,heads
        #LLE   r1,devhdr_trksize                 get trk size
         ST    r1,trklen
         IC    r1,devhdr_devtype                 get device type
         STC   r1,devtype+1
         STC   r1,devtype
         TR    devtype(1),devtype_table          get 1st byte
         CLI   devtype,0                         known type ?
         BE    Ebaddevt                           no, error

*/* -------------------------------------------------------------------
*   read the CCKDDASD_DEVHDR
* ------------------------------------------------------------------ */
        #READ  OFFSET=CKDDASD_DEVHDR_SIZE,LENGTH=CCKDDASD_DEVHDR_SIZE, x
               ADDR=cdevhdr
         USING CCKDDASD_DEVHDR,cdevhdr
         TM    cdevhdr_options,CCKD_OPENED       was file closed ?
         BNO   openok                             yes, continue
        #MSG   'Warning... cckd file was not closed'
         MVC   result,=A(4)
openok   DS    0H
        #LC    r1,cdevhdr_cyls                   number of cylinders
         ST    r1,cyls
        #LC    r2,cdevhdr_numl1tab               l1 table entries
         ST    r2,numl1tab

*/* -------------------------------------------------------------------
*   read the CCKD_L1TAB
* ------------------------------------------------------------------ */
         SLL   r2,2                              size of l1tab
         STORAGE OBTAIN,LENGTH=(r2)              get l1tab storage
         LR    r3,r1
         ST    r3,l1tab
        #READ  OFFSET=CCKD_L1TAB_POS,LENGTH=(r2),ADDR=(r3)

*/* -------------------------------------------------------------------
*   find the last used track and cylinder
* ------------------------------------------------------------------ */
         ALR   r2,r3                             end of l1tab
lastl1   SH    r2,=Y(CCKD_L1ENT_SIZE)            backup an entry
         CLR   r2,r3                             before the beginning ?
         BL    Eempty                             yes, empty file
        #LC    r4,0(r2)                          get l2tab offset
         LTR   r4,r4                             empty ?
         BZ    lastl1                             yes, keep looking
        #READ  OFFSET=(r4),LENGTH=CCKD_L2TAB_SIZE,ADDR=l2tab
         LA    r4,l2tab                          beginning of l2tab
         LA    r5,CCKD_L2TAB_SIZE(,r4)           end of l2tab
lastl2   SH    r5,=Y(CCKD_L2ENT_SIZE)            backup an entry
         CLR   r5,r4                             before the beginning ?
         BL    lastl1                             yes, keep looking
         USING CCKD_L2ENT,r5
        #LC    r0,l2ent_pos                      load trk offset
         LTR   r0,r0                             empty ?
         BZ    lastl2                             yes, keep looking
         SR    r2,r3                             each 4-byte l1tab
         SRL   r2,2                               entry represents
         SLL   r2,8                                256 tracks
         SR    r5,r4                             each 8-byte l2tab
         SRL   r5,3                               entry is a track
         AR    r5,r2                             have last used trk
         ST    r5,lasttrk
         SLR   r4,r4
         D     r4,heads                          have last used cyl
         ST    r5,lastcyl
         DROP  r5

        #MSG   'cckd file is a %x4:2 cyls %d heads %d trklen %d; cyl %dx
                is the last used cylinder',                            x
               devtype,cyls,heads,trklen,lastcyl

*/* -------------------------------------------------------------------
*   `fake-open' the offline device
* ------------------------------------------------------------------ */

*/* -------------------------------------------------------------------
*   look for the ucb for the unit & make sure it's an offline dasd
* ------------------------------------------------------------------ */
         MVC   pl(l_ulpl),m_ulpl                 copy parm list
         MODESET MODE=SUP
         UCBLOOK DEVN=unit,UCBPTR=ucbaddr,PIN,PTOKEN=ptoken,           x
               DYNAMIC=YES,RANGE=ALL,LOC=ANY,MF=(E,pl),                x
               TEXT==C'cckddump offline dasd lookup'
         STM   rf,r0,retcd                       save ret/rsn codes
         MODESET MODE=PROB
         LM    rf,r0,retcd
         LTR   rf,rf                             check return code
         BNZ   Ebaducbl                           ucblook error
         OI    flags,ucbpin
         L     r2,ucbaddr
         USING UCBOB,r2
         CLI   UCBTBYT3,UCB3DACC                 check for dasd ucb
         BNE   Ebaducbt                           not a dasd unit
         TM    UCBSTAT,UCBONLI                   is device online ?
         BO    Ebaducbs                           unit is not offline

*/* -------------------------------------------------------------------
*   if we got a 31-bit address then we need to `capture' a 24-bit addr
* ------------------------------------------------------------------ */
         MVC   cucbaddr,ucbaddr                  copy ucb addr
         TM    ucbaddr,X'ff'                     31 bit address ?
         BZ    cucbok                             no, continue
         MVC   pl(l_cupl),m_cupl                 copy parm list
         MODESET MODE=SUP
         IOSCAPU CAPTUCB,UCBPTR=ucbaddr,CAPTPTR=cucbaddr,              x
               MF=(E,pl)                         capture 24 bit addr
         STM   rf,r0,retcd                       save ret/rsn codes
         MODESET MODE=PROB
         LM    rf,r0,retcd
         LTR   rf,rf                             check return code
         BNZ   Ebaducbc                           ioscapu error
         OI    flags,captucb
cucbok   DS    0H

*/* -------------------------------------------------------------------
*   build a dcb for the offline dasd
* ------------------------------------------------------------------ */
         MVC   unitdcb,m_unitdcb                 copy model dcb
udcb     USING IHADCB,unitdcb
         MVC   udcb.DCBMACRF,udcb.DCBMACR        copy macr

*/* -------------------------------------------------------------------
*   build a deb for the offline dasd
* ------------------------------------------------------------------ */
         MODESET MODE=SUP,KEY=ZERO
         GETMAIN RU,LV=DEBLENGTH,SP=230,LOC=BELOW
         ST    r1,debaddr                        save deb address
         XC    0(DEBLENGTH,r1),0(r1)             clear the deb
         LR    r3,r1                             app vector table
         USING DEBAVT,r3
         LA    r4,DEBBASND-DEBAVT(,r3)           debdasd section
         USING DEBDASD,r4
         LA    r5,DEBDASDE-DEBDASD(,r4)          deb ext section
         USING DEBXTN,r5
         L     r6,CVTPTR                         get cvt address
         USING CVT,r6
         L     rf,CVTXAPG                        ios app vector table
         MVC   DEBAVT(DEBPREFX-DEBAVT),0(rf)     copy vector table
         ST    r5,DEBXTNP                        set ext address
         USING PSA,r0
         L     r7,PSATOLD                        get tcb address
         USING TCB,r7
         ST    r7,DEBTCBAD                       set tcb address
         OI    DEBFLGS1,DEBXTNIN                 indicate ext exists
         LA    r0,unitdcb                        get dcb address
         ST    r0,DEBDCBAD                       set dcb address
         MVI   DEBDEBID,15                       set deb identifier
         OC    DEBPROTG,TCBPKF                   set protection key
         ST    r3,DEBAPPAD                       set app table address
         MVC   DEBUCBA,cucbaddr+1                set ucb address
         MVC   DEBXLNGH,=Y(DEBXLEN)              set ext length
         LA    r1,DEBBASIC                       get basic address
         STCM  r1,7,udcb.DCBDEBA                 set deb addr in dcb
         SETLOCK OBTAIN,TYPE=LOCAL,REGS=STDSAVE,MODE=UNCOND
         MVC   DEBDEBB,TCBDEB+1                  set addr next deb
         LA    r1,DEBBASIC                       get basic addr
         ST    r1,TCBDEB                         chain deb to the tcb
         SETLOCK RELEASE,TYPE=LOCAL,REGS=STDSAVE

*/* -------------------------------------------------------------------
*   add the deb to the deb list
* ------------------------------------------------------------------ */
         DEBCHK unitdcb,TYPE=ADD,AM=EXCP
         STM   rf,r0,retcd
         MODESET MODE=PROB,KEY=NZERO
         LM    rf,r0,retcd
         LTR   rf,rf                             test return code
         BNZ   Ebaddeba                           debchk add failed
         OI    flags,debadded

*/* -------------------------------------------------------------------
*   build the dasd extent
* ------------------------------------------------------------------ */
         MODESET MODE=SUP,KEY=ZERO
         MVC   DEBUCBAD,cucbaddr                 set 24-bit ucb addr
         MVI   DEBDVMOD,0                        set device modifier
         MVC   DEBENDCC,=X'7fff'                 set end cylinder
         MVC   DEBENDHH,=X'00ff'                 set end head
         MVC   DEBNMTRK,=X'7fff'                 set nbr trks in extent
         MODESET MODE=PROB,KEY=NZERO

         DROP  r0,r2,r3,r4,r6,r7

*/* -------------------------------------------------------------------
*   build a couple of iobs
* ------------------------------------------------------------------ */
i1       USING IOBSTDRD,iob1
         OI    i1.IOBFLAG1,IOBDATCH+IOBCMDCH+IOBUNREL
         LA    r1,ecb1
         ST    r1,i1.IOBECBPT
         LA    r1,ccws
         ST    r1,i1.IOBSTART
         LA    r1,unitdcb
         ST    r1,i1.IOBDCBPT
i2       USING IOBSTDRD,iob2
         OI    i2.IOBFLAG1,IOBDATCH+IOBCMDCH+IOBUNREL
         LA    r1,ecb2
         ST    r1,i2.IOBECBPT
         LA    r1,ccws
         LA    r1,ccwl(,r1)
         ST    r1,i2.IOBSTART
         LA    r1,unitdcb
         ST    r1,i2.IOBDCBPT

*/* -------------------------------------------------------------------
*   turn off the `not ready' bit
* ------------------------------------------------------------------ */
         L     r2,ucbaddr                        load ucb addr
         USING UCBOB,r2
         TM    UCBFLA,UCBNRY                     `not ready' bit on ?
         BNO   nryok                              no, continue
         MODESET MODE=SUP,KEY=ZERO
         NI    UCBFLA,255-UCBNRY                 turn off `not ready'
         MODESET MODE=PROB,KEY=NZERO
         DROP  r2
         OI    flags,notready
nryok    DS    0H

*/* -------------------------------------------------------------------
*   sense the offline device
* ------------------------------------------------------------------ */
         LA    r2,ccws
         USING CCW0,r2

         MODESET MODE=SUP,KEY=ZERO
         OI    DEBXFLG2,DEBCHCMP+DEBBYP
         MODESET MODE=PROB,KEY=NZERO

*/* seek                                                            */
         XC    CCW0(8),CCW0
         MVI   CCW0CMD,SK
         LA    r1,zeros
         STCM  r1,7,CCW0ADDR
         MVI   CCW0FLAG,CCW0SLI
         MVC   CCW0CNT,=Y(6)
         EXCP  iob1
         WAIT  1,ECB=ecb1
         CLI   ecb1,ECBNORM
         BNE   Esnserr

*/* Sense ID                                                        */
         XC    ecb1,ecb1
         XC    CCW0(8),CCW0
         MVI   CCW0CMD,SNSID
         LA    r1,snsidarea
         STCM  r1,7,CCW0ADDR
         MVI   CCW0FLAG,CCW0SLI
         MVC   CCW0CNT,=Y(L'snsidarea)
         EXCP  iob1
         WAIT  1,ECB=ecb1
         CLI   ecb1,ECBNORM
         BNE   Esnserr

*/* Sense                                                           */
         XC    ecb1,ecb1
         XC    CCW0(8),CCW0
         MVI   CCW0CMD,SNS
         LA    r1,snsarea
         STCM  r1,7,CCW0ADDR
         MVI   CCW0FLAG,CCW0SLI
         MVC   CCW0CNT,=Y(L'snsarea)
         EXCP  iob1
         WAIT  1,ECB=ecb1
         CLI   ecb1,ECBNORM
         BNE   Esnserr

*/* Read Device Characteristics                                     */
         XC    ecb1,ecb1
         XC    CCW0(8),CCW0
         MVI   CCW0CMD,RDC
         LA    r1,rdcarea
         STCM  r1,7,CCW0ADDR
         MVI   CCW0FLAG,0
         MVC   CCW0CNT,=Y(L'rdcarea)
         EXCP  iob1
         WAIT  1,ECB=ecb1
         CLI   ecb1,ECBNORM
         BNE   Esnserr

*/* Sense Subsystem Status
         XC    ecb1,ecb1
         XC    CCW0(8),CCW0
         MVI   CCW0CMD,SNSS
         LA    r1,snssarea
         STCM  r1,7,CCW0ADDR
         MVI   CCW0FLAG,CCW0SLI
         MVC   CCW0CNT,=Y(L'snssarea)
         EXCP  iob1
         WAIT  1,ECB=ecb1
         CLI   ecb1,ECBNORM
         BNE   Esnserr

         MODESET MODE=SUP,KEY=ZERO
         NI    DEBXFLG2,255-DEBBYP
         MODESET MODE=PROB,KEY=NZERO
         DROP  r2,r5

*/* -------------------------------------------------------------------
*   perform some sanity checks
* ------------------------------------------------------------------ */
         USING RDCinfo,rdcarea
         MVC   pl(l_tcpl),m_tcpl                 copy model parm list
         L     r2,cucbaddr
         TRKCALC FUNCTN=TRKBAL,UCB=(r2),RKDD==A(x'0100ffff'),          x
               MAXSIZE=YES,REGSAVE=YES,MF=(E,pl)
         CH    rf,=Y(8)
         BNE   Ebadcap                           unexpected return code
         LR    r1,r0                             round up 512
         LA    r1,511(,r1)
         N     r1,=A(x'fffffe00')
         ST    r1,utrklen
        #MSG   'unit %x4:2 is a %x4:2 cyls %d:2 heads %d:2 trklen %d', x
               unit,RDCdevt,RDCprime,RDCheads,utrklen
         CLC   RDCdevt,devtype
         BNE   Emisdevt
         CLC   RDCheads,heads+2
         BNE   Emisheads
         CLC   trklen,utrklen
         BNE   Emislen
         CLC   RDCprime,lastcyl+2
         BH    cylok
        #MSG   'Warning... cckd file uses more cylinders than availablex
                on %x4:2; extras will be omitted',unit
         MVC   result,=A(4)
cylok    DS    0H
*/* Dump tracks thru last used cylinder, or thru last cylinder on    */
*/* on the output device, whichever is lower                         */
         L     r3,lastcyl
         LA    r3,1(,r3)
         M     r2,heads
         ST    r3,tracks
         SLR   r3,r3
         ICM   r3,3,RDCprime
         M     r2,heads
         C     r3,tracks
         BH    *+8
         ST    r3,tracks                         tracks to write
        #MSG   '%d tracks will be written',tracks
         L     r3,tracks                         tracks to write
         D     r2,=A(10)
         LA    r3,99(,r3)
         SLR   r2,r2
         D     r2,=A(100)
         LTR   r3,r3
         BNZ   *+8
         LA    r3,1                              10% of tracks to be
         MH    r3,=Y(100)                         written rounded up
         ST    r3,trk10pct                         to next 100
         SLR   r2,r2                                for status msg
         L     r3,tracks
         D     r2,heads
         ST    r3,cyls

*/* -------------------------------------------------------------------
*   get area for the buffers
* ------------------------------------------------------------------ */
         L     r2,trklen
         SLL   r2,2                              space for 4 buffers
         STORAGE OBTAIN,LENGTH=(r2)
         ST    r1,buf1
         AL    r1,trklen
         ST    r1,buf2
         AL    r1,trklen
         ST    r1,buf3
         AL    r1,trklen
         ST    r1,buf4

*/* -------------------------------------------------------------------
*   create a persistent c environment
* ------------------------------------------------------------------ */
         LA    r2,handle
         LA    r3,=A(32*1024)
         LA    r4,=A(1)
         STM   r2,r4,pl
         OI    pl+8,X'80'
         LA    r1,pl
         L     rf,=V(EDCXHOTL)           create persistent c environ
         BALR  re,rf
******* #MSG   'persistent c environment created, handle=0x%x',handle

*/* -------------------------------------------------------------------
*   setup the output channel programs
* ------------------------------------------------------------------ */
         LA    r2,ccws            point to 1st ccws
         USING CCW0,r2
         LA    r3,lrparm1         point to 1st LR parameters
         USING LRparm,r3
         LA    r4,idaw1           point to 1st idaw list
         LA    rf,2               build 2 sets of ccws
bldcp    XC    CCW0(8),CCW0       clear the ccw
         MVI   CCW0CMD,DX         set define extent command
         LA    r1,dxarea          address of dx area
         STCM  r1,7,CCW0ADDR      set address
         MVI   CCW0FLAG,CCW0CC    command chaining
         MVC   CCW0CNT,=Y(L'dxarea) set length
         LA    r2,CCW0END         to next ccw
         XC    CCW0(8),CCW0       clear the ccw
         MVI   CCW0CMD,TIC        set transfer-in-control command
         LA    r1,CCW0END         address of next ccw
         STCM  r1,7,CCW0ADDR      set next ccw address
         LA    r2,CCW0END         to next ccw
         XC    CCW0(8),CCW0       clear the ccw
         MVI   CCW0CMD,LR         set locate record command
         STCM  r3,7,CCW0ADDR      set address in locate record ccw
         OI    CCW0FLAG,CCW0CC    command chaining
         MVC   CCW0CNT,=Y(LRparml) set length
         MVI   LRop,LRocount+LRfwrite set operation byte
         LA    r0,255             build 255 write ccws
bldcp2   LA    r2,CCW0END         point to next ccw
         XC    CCW0(8),CCW0       clear the ccw
         MVI   CCW0CMD,WCKD       set read track command
         STCM  r4,7,CCW0ADDR      set address for idaw
         LA    r4,4(,r4)          point to next idaw
         BCT   r0,bldcp2          loop back
         LA    r2,ccws            point to 2nd
         LA    r2,ccwl(,r2)        channel program
         LA    r3,lrparm2         point to 2nd LR parameters
         LA    r4,idaw2           point to 2nd idaw list
         BCT   rf,bldcp           build 2nd channel program
         DROP  r2,r3

*/* -------------------------------------------------------------------
*   setup the output define extent area
* ------------------------------------------------------------------ */
         MVI   dxarea,X'c0'       permit all write operations
         MVI   dxarea+1,X'c0'     eckd
         L     r1,cyls            low extent is cyl 0 head 0
         BCTR  r1,0 set high extent
         stcm  r1,3,dxarea+12
         ICM   r1,3,RDCheads
         BCTR  r1,0
         STCM  r1,3,dxarea+14

*/* -------------------------------------------------------------------
*   Read/write each track image
* ------------------------------------------------------------------ */
         SLR   r2,r2              init buffer switch
         SLR   r3,r3              init l1tab index
         MVC   trkstat,trk10pct init status

rwloop   DS    0H

*/* Read the next l2tab                                              */
         LR    r4,r3
         SLL   r4,2
         AL    r4,l1tab
        #LC    r5,0(r4)
         LTR   r4,r5
         BZ    l2null
        #READ  OFFSET=(r4),LENGTH=CCKD_L2TAB_SIZE,ADDR=l2tab
         B     l2ok
l2null   LA    r0,l2tab
         LA    r1,CCKD_L2TAB_SIZE
         SLR   rf,rf
         MVCL  re,r0
l2ok     DS    0H

*/* Loop for each entry in the l2tab, exit if all tracks processed   */
         SLR   r4,r4
rwloop2  LR    rf,r3
         SLL   rf,8
         AR    rf,r4
         CL    rf,tracks
         BNL   rwexit
         ST    rf,track

*/* Get offset/length of the track image from the l2tab entry        */
         LR    r5,r4
         SLL   r5,3
         LA    r5,l2tab(r5)
         USING CCKD_L2ENT,r5
        #LC    r6,l2ent_pos
        #LHC   r7,l2ent_len
         DROP  r5

         L     r5,bufs(r2)

*/* Read the track image unless its a null track                     */
         LTR   r6,r6
         BZ    trknull
        #READ  OFFSET=(r6),LENGTH=(r7),ADDR=(r5)
         B     trkok
trknull  XC    0(CCKD_NULLTRK_SIZE,r5),0(r5)
*/* Build a null trk: 0cchh cchh0008 00000000 cchh1000 ffffffff      */
         SLR   re,re
         L     rf,track
         D     re,heads
         STCM  rf,3,1(r5)
         STCM  re,3,3(r5)
         MVC   5(4,r5),1(r5)
         MVI   8(r5),8
         MVC   21(4,r5),1(r5)
         MVI   25(r5),1
         MVC   29(8,r5),eightFF
trkok    DS    0H

         CLI   0(r5),CCKD_COMPRESS_MAX
         BNH   compok
        #MSG   'Trk %d unknown compression: %d:1',track,0(r5)
         MVC   result,=A(8)
         B     trknull
compok   DS    0H

*/* Uncompress the track image                                       */
         SLR   rf,rf
         IC    rf,0(,r5)
         SLL   rf,2
         B     *+4(rf)
         B     compnone              0 - not compressed
         B     compzlib              1 - zlib compression
         B     compbz2               2 - bz2 compression

*/* Not compressed                                                   */
compnone LR    r6,r5
         B     compdone

*/* zlib compression                                                 */
compzlib LR    r6,r5
         AL    r6,trklen
         MVC   0(CKDDASD_TRKHDR_SIZE,r6),0(r5)
         LA    re,handle
         LA    rf,=V(UNCOMPRE)
         LA    r0,CKDDASD_TRKHDR_SIZE(,r6)
         L     r1,trklen
         SH    r1,=Y(CKDDASD_TRKHDR_SIZE)
         ST    r1,complen
         LA    r1,complen
         STM   re,r1,pl
         LA    re,CKDDASD_TRKHDR_SIZE(,r5)
         LR    rf,r7
         SH    rf,=Y(CKDDASD_TRKHDR_SIZE)
         STM   re,rf,pl+16
         LA    r1,pl
         L     rf,=V(EDCXHOTU)
         BALR  re,rf
         LTR   rf,rf
         BZ    compdone
         ST    rf,retcd
        #MSG   'trk %d zlib uncompress error: %d',track,retcd
         MVC   result,=A(8)
         B     trknull

*/* bzip2 compression                                                */
compbz2  LR    r6,r5
         AL    r6,trklen
         MVC   0(CKDDASD_TRKHDR_SIZE,r6),0(r5)
         LA    re,handle
         LA    rf,=V(bzbuffd)
         LA    r0,CKDDASD_TRKHDR_SIZE(,r6)
         L     r1,trklen
         SH    r1,=Y(CKDDASD_TRKHDR_SIZE)
         ST    r1,complen
         LA    r1,complen
         STM   re,r1,pl
         LA    re,CKDDASD_TRKHDR_SIZE(,r5)
         LR    rf,r7
         SH    rf,=Y(CKDDASD_TRKHDR_SIZE)
         SLR   r0,r0
         SLR   r1,r1
         STM   re,r1,pl+16
         LA    r1,pl
         L     rf,=V(EDCXHOTU)
         BALR  re,rf
         LTR   rf,rf
         BZ    compdone
         ST    rf,retcd
        #MSG   'trk %d bzip2 decompress error: %d',track,retcd
         MVC   result,=A(8)
         B     trknull

compdone DS    0H

*/* Schedule the track image to be written                           */
        #WRITE ADDR=(r6)

*/* Write status message if it's time                                */
         CLC   track,trkstat
         BL    rwnext2
        #MSG   '%d tracks written',track
         L     r1,trkstat
         AL    r1,trk10pct
         ST    r1,trkstat

rwnext2  X     r2,=A(8)                       flip/flop buffers
         LA    r4,1(,r4)
         CH    r4,=Y(256)
         BL    rwloop2

rwnext   LA    r3,1(,r3)
         B     rwloop
rwexit   DS    0H

         TIME  DEC
         STM   r0,r1,ctime
         LA    r1,ctime
         LA    r0,dtime
         BAL   re,datetime
        #MSG   '%d tracks written at %s:20, max code: %d',             x
               tracks,dtime,result

*/* -------------------------------------------------------------------
*   cleanup and terminate
* ------------------------------------------------------------------ */

terminate DS   0H

*/* Make sure all write i/o has completed                            */
        #WRITE ADDR=0

*/* Terminate the persistant c environment                           */
         CLC   =A(0),handle
         BE    term1
         LA    r1,handle
         ST    r1,pl
         OI    pl,X'80'
         LA    r1,pl
         L     rf,=V(EDCXHOTT)
         BALR  re,rf
term1    DS    0H

*/* Close the cckd file                                              */
         TM    ut1.DCBOFLGS,DCBOFOPN
         BNO   term2
         MVC   openl,m_openl
         CLOSE (sysut1),MODE=31,MF=(E,openl)
term2    DS    0H

*/* Free the i/o areas                                               */
         L     r1,buf1
         LTR   r1,r1
         BZ    term3
         L     r2,trklen
         SLL   r2,2
         STORAGE RELEASE,ADDR=(1),LENGTH=(r2)
term3    DS    0H

*/* Free the l1tab                                                   */
         L     r1,l1tab
         LTR   r1,r1
         BZ    term4
         L     r2,numl1tab
         SLL   r2,2
         STORAGE RELEASE,ADDR=(1),LENGTH=(r2)
term4    DS    0H

*/* Call debchk to delete the deb                                    */
         TM    flags,debadded
         BNO   term5
         MODESET MODE=SUP,KEY=ZERO
         DEBCHK unitdcb,TYPE=DELETE,AM=EXCP delete the deb
         MODESET MODE=PROB,KEY=NZERO
term5    DS    0H

         L     r2,debaddr
         LTR   r2,r2
         BZ    term6

*/* Remove the deb from the deb chain                                */
         USING DEBAVT,r2
         LA    r3,DEBBASIC
         DROP  r2
         L     r4,PSATOLD-PSA
         USING TCB,r4
         LA    r5,TCBDEB-(DEBDEBAD-DEBBASIC)
         USING DEBBASIC,r4
         MODESET MODE=SUP,KEY=ZERO
         SETLOCK OBTAIN,TYPE=LOCAL,REGS=STDSAVE,MODE=UNCOND
         SPKA  X'80'
termdeb  LR    r4,r5
         SLR   r5,r5
         ICM   r5,7,DEBDEBB
         BZ    termdebx
         CLR   r3,r5
         BNE   termdeb
         SPKA  0
         MVC   DEBDEBB,DEBDEBB-DEBBASIC(r5)
         DROP  r4
termdebx SPKA  0
         SETLOCK RELEASE,TYPE=LOCAL,REGS=STDSAVE
         MODESET MODE=PROB,KEY=NZERO

*/* Free deb storage                                                */
         MODESET MODE=SUP,KEY=ZERO
         FREEMAIN RU,A=(r2),LV=DEBLENGTH,SP=230
         MODESET MODE=PROB,KEY=NZERO
term6    DS    0H

*/* Turn the ucb `not ready' bit back on if we turned it off         */
         TM    flags,notready
         BNO   term7
         L     r2,ucbaddr
         USING UCBOB,r2
         MODESET MODE=SUP,KEY=ZERO
         OI    UCBFLA,UCBNRY
         MODESET MODE=PROB,KEY=NZERO
         DROP  r2
term7    DS    0H

*/* Uncapture the ucb                                                */
         TM    flags,captucb
         BNO   term8
         MVC   pl(l_cupl),m_cupl
         MODESET MODE=SUP
         IOSCAPU UCAPTUCB,CAPTPTR=cucbaddr,MF=(E,pl)
         MODESET MODE=PROB
term8    DS    0H

*/* Unpin the ucb                                                    */
         TM    flags,ucbpin
         BNO   term9
         MVC   pl(l_uupl),m_uupl
         MODESET MODE=SUP
         UCBPIN UNPIN,PTOKEN=ptoken,MF=(E,pl)
         MODESET MODE=PROB
term9    DS    0H

*/* Close the sysprint file                                          */
pdcb     USING IHADCB,prtdcb
         TM    pdcb.DCBOFLGS,DCBOFOPN
         BNO   term10
         MVC   openl,m_openl
         CLOSE (prtdcb),MODE=31,MF=(E,openl)
term10   DS    0H

*/* Free the work areas                                              */
         STORAGE RELEASE,ADDR=(rb),LENGTH=work24l
         LR    r1,rd
         L     r2,result
         L     rd,4(,rd)
         STORAGE RELEASE,ADDR=(1),LENGTH=workl

*/* Return                                                           */
         LR    rf,r2
         RETURN (14,12),RC=(15)

*/* -------------------------------------------------------------------
*   format date & time
* ------------------------------------------------------------------ */
datetime STM   re,r2,12(rd)       save some regs
         LR    r2,r0              copy output area address
         MVI   0(r2),C' '         blank the output area
         MVC   1(19,r2),0(r2)
         MVC   11(9,r2),=X'4021207a20207a2020' edit pattern for time
         ED    11(9,r2),0(r1)     edited time
         XC    dw,dw              clear double word work area
         SLR   rf,rf
         ICM   rf,3,4(r1)         decimal year
         SLL   rf,4               shift over a nibble
         ST    rf,dw+4            store in the double word
         OI    dw+7,X'0f'         set bottom nibble
         AP    dw,=P'1900'        calculate the year
         OI    dw+7,X'0f'         fix bottom nibble for unpk
         UNPK  7(4,r2),dw         set the year
         CVB   rf,dw              get binary year
         N     rf,=A(3)           test for leap year
         BZ    *+8                 jumps if leap year
         LA    rf,2                 else set non-leapyr offset
         ZAP   dw,6(2,r1)         get julian day in double word
         CVB   r0,dw              get julian day binary
         LA    re,dtjtab          point to julian table
dtfind   CH    r0,8(rf,re)        found table entry ?
         BNH   dtfound             yes, exit loop
         LA    re,8(,re)          point to next entry
         B     dtfind              and loop back
dtfound  MVC   3(3,r2),4(re)      set month from the table
         SH    r0,0(rf,re)        calculate day of month
         CVD   r0,dw              get day of month packed
         L     r0,dw+4            load packed day
         SLL   r0,20              shift out hi bits
         SRL   r0,28              shift down
         STC   r0,0(,r2)          set 1st digit of the month
         OI    0(r2),C'0'         convert to ebcdic character
         L     r0,dw+4            load packed day
         SLL   r0,24              shift out hi bits
         SRL   r0,28              shift down
         STC   r0,1(,r2)          set 2nd digit of the month
         OI    1(r2),C'0'         convert to ebcdic character
         LM    re,r2,12(rd)       restore regs
         BR    re                  and thankfully return
dtjtab   DC    Y(0,0),C'Jan '     Julian date table
         DC    Y(31,31),C'Feb '
         DC    Y(60,59),C'Mar '
         DC    Y(91,90),C'Apr '
         DC    Y(121,120),C'May '
         DC    Y(152,151),C'Jun '
         DC    Y(182,181),C'Jul '
         DC    Y(213,212),C'Aug '
         DC    Y(244,243),C'Sep '
         DC    Y(274,273),C'Oct '
         DC    Y(305,304),C'Nov '
         DC    Y(335,334),C'Dec '
         DC    Y(999,999),C'??? '

*/* -------------------------------------------------------------------
*   error routines
* ------------------------------------------------------------------ */
Enoparm #MSG   '** Unit address not specified'
         B     Eexit
Ebadparm MVC   dw,=CL8' '
         CH    r4,=Y(8)
         BNH   *+8
         LA    r4,8
         SH    r4,=Y(1)
         BM    *+4+4+6
         EX    r4,*+4
         MVC   dw(0),0(r3)
        #MSG   '** Invalid unit address: %s:8',dw
         B     Eexit
Edevid  #MSG   '** SYSUT1 is not a cckd file; devid validation failed'
         B     Eexit
Esynad1 #MSG   '** SYSUT1 fatal error, Synad EP loaded'    CZV70
         B     Eexit                                       CZV70
Edevterr STM   rf,r0,retcd
         CLC   retcd(8),=A(4,4)     missing ddname ?
         BE    Enoddn                yes, noddn error
        #MSG   '** SYSUT1 DEVTYPE error: rc=%d, reason=%d',            X
               retcd,rsncd
         B     Eexit
Enoddn  #MSG   '** SYSUT1 ddname not found'
         B     Eexit
Enotdasd1 #MSG '** SYSUT1 not a dasd file'
         B     Eexit
Eopenerr #MSG  '** SYSUT1 did not open'
         B     Eexit
Ebadblksz #MSG '** SYSUT1 blksz is not 16384'              CZV70
         B     Eexit
Etrkcalc ST    rf,retcd
        #MSG   '** TRKCAP failed for SYSUT1: rc=%d',retcd
         B     Eexit
Ebaddevt #MSG  '** cckd dasd devtype not supported: 0x%x2:1',devtype+1
         B     Eexit
Eempty   #MSG  '** cckd file contains all null tracks'
         B     Eexit
Epoint   ST    rf,retcd
        #MSG   '** SYSUT1 point error: rc=%d ttr=%x6:3',retcd,ttr
         B     Eexit
Ebaducbl CH    RF,=Y(4)
         BE    Enoucb
        #MSG   '** UCBLOOK error for unit %x4:2: rc 0x%x rsn 0x%x',    X
               unit,retcd,rsncd
         B     Eexit
Enoucb  #MSG   '** UCB not found for unit %x4:2',unit
         B     Eexit
Ebaducbt L     r2,ucbaddr
         USING UCBOB,r2
        #MSG   '** UCB for unit %x4:2 is not dasd, type is %x:1',      X
               unit,UCBTBYT3
         B     Eexit
         DROP  r2
Ebaducbs #MSG  '** Device %x4:2 is not offline',unit
         B     Eexit
Ebaducbc #MSG  '** IOSCAPU CAPTUCB failed for %x4:2; rc=0x%x rsn=0x%x',X
               unit,retcd,rsncd
         B     Eexit
Ebaddeba #MSG  '** DEBCHK ADD for %x4:2 failed; rc=0x%x',              X
               unit,retcd
         B     Eexit
Esnserr #MSG   '** Sense failed for %x4:2: command %x2:1, CC 0x%x2:1, SX
               tat 0x%x4:2',unit,ccws,ecb1,i1.IOBSTBYT
         B     Eexit
Ebadcap  ST    rf,retcd
        #MSG   '** TRKBAL for %x4:2 unexpected return code; rc=0x%x',  X
               unit,retcd
         B     Eexit
Emisdevt #MSG  '** devtype mismatch %x4:2=%x4:2, cckd=%x4:2',          X
               unit,RDCdevt,devtype
         B     Eexit
Emisheads #MSG '** number heads mismatch %x4:2=%d:2, cckd=%d',         X
               unit,RDCheads,heads
         B     Eexit
Emislen #MSG   '** trklen mismatch %x4:2=%d, cckd=%d',                 X
               unit,utrklen,trklen
         B     Eexit
Eioerr   SLR   r2,r2
         ICM   r2,7,waitecb+1
         LA    r0,ecb1
         LA    r3,iob1
         CLR   r0,r2
         BE    *+8
         LA    r3,iob2
         USING ECB,r2
         USING IOBSTDRD,r3
        #MSG   '** I/O error %x4:2 CCHH %x8: CC %x2:1, Stat %x4:2',    X
               unit,prevcchh,ECBCC,IOBSTBYT
         DROP  r2,r3
         B     Eexit

Eexit    MVC   result,=A(12)
         B     terminate

*/* -------------------------------------------------------------------
*   literals and constants
* ------------------------------------------------------------------ */
          LTORG ,
parmmvc   MVC   dw(0),0(r3)        *** executed ***
parmhexc  TRT   dw(0),hexchars     *** executed ***
parmhex   TR    dw(0),hextab       *** executed ***
parmpack  PACK  dw2,dw(0)          *** executed ***
m_unitdcb DCB   DDNAME=0,DSORG=PS,MACRF=E
l_unitdcb EQU   *-m_unitdcb
m_sysut1  DCB   DDNAME=SYSUT1,DSORG=PS,MACRF=RP,DCBE=m_sysut1e,RECFM=F
l_sysut1  EQU   *-m_sysut1
m_sysut1e DCBE  RMODE31=BUFF,SYNAD=Esynad1,BLOCKTOKENSIZE=LARGE CZV70
l_sysut1e EQU   *-m_sysut1e
m_prtdcb  DCB   DDNAME=SYSPRINT,DSORG=PS,MACRF=PL,DCBE=m_prtdcbe
l_prtdcb  EQU   *-m_prtdcb
m_prtdcbe DCBE  RMODE31=BUFF
l_prtdcbe EQU   *-m_prtdcbe
m_openl   OPEN  (0),MODE=31,MF=L
l_openl   EQU   *-m_openl
          UCBLOOK MF=(L,m_ulpl)
l_ulpl    EQU   *-m_ulpl
          UCBPIN MF=(L,m_uupl)
l_uupl    EQU   *-m_uupl
          IOSCAPU MF=(L,m_cupl)
l_cupl    EQU   *-m_cupl
m_tcpl    TRKCALC MF=L
l_tcpl    EQU   *-m_tcpl
eightFF   DC    X'ffffffffffffffff'
devtype_table   DC 256X'00'
          ORG   devtype_table+x'80'
          DC    X'33'
          ORG   devtype_table+x'90'
          DC    X'33'
          ORG   devtype_table+x'45'
          DC    X'93'
          ORG   devtype_table+256
hextab    DC    256X'00'
          ORG   hextab+C'0'
          DC    AL1(0,1,2,3,4,5,6,7,8,9)
          ORG   hextab+C'a'
          DC    AL1(10,11,12,13,14,15)
          ORG   hextab+C'A'
          DC    AL1(10,11,12,13,14,15)
          ORG   hextab+256
hexchars  DC    256x'ff'
          ORG   hexchars+C'a'
          DC    6x'0'
          ORG   hexchars+C'A'
          DC    6x'0'
          ORG   hexchars+C'0'
          DC    10x'0'
          ORG   hexchars+256
upcase    DC    C' ',255AL1(*-upcase)
          ORG   upcase+c'a'
          DC    C'ABCDEFGHI'
          ORG   upcase+c'j'
          DC    C'JKLMNOPQR'
          ORG   upcase+c's'
          DC    C'STUVWXYZ'
          ORG   upcase+256
A2E       DS    0D
*      0 1 2 3 4 5 6 7 8 9 a b c d e f
 DC X'00010203372D2E2F1605250B0C0D0E0F' 0
 DC X'101112133C3D322618193F27221D351F' 1
 DC X'405A7F7B5B6C507D4D5D5C4E6B604B61' 2
 DC X'F0F1F2F3F4F5F6F7F8F97A5E4C7E6E6F' 3
 DC X'7CC1C2C3C4C5C6C7C8C9D1D2D3D4D5D6' 4
 DC X'D7D8D9E2E3E4E5E6E7E8E9ADE0BD5F6D' 5
 DC X'79818283848586878889919293949596' 6
 DC X'979899A2A3A4A5A6A7A8A9C04FD0A107' 7
 DC X'00010203372D2E2F1605250B0C0D0E0F' 8
 DC X'101112133C3D322618193F27221D351F' 9
 DC X'405A7F7B5B6C507D4D5D5C4E6B604B61' a
 DC X'F0F1F2F3F4F5F6F7F8F97A5E4C7E6E6F' b
 DC X'7CC1C2C3C4C5C6C7C8C9D1D2D3D4D5D6' c
 DC X'D7D8D9E2E3E4E5E6E7E8E9ADE0BD5F6D' d
 DC X'79818283848586878889919293949596' e
 DC X'979899A2A3A4A5A6A7A8A9C04FD0A107' f
hex2char  EQU   *-240
          DC    C'0123456789ABCDEF'
          DROP  ,
mainend   DS    0D

*/* -------------------------------------------------------------------
*   Subroutine to read the cckd file
* ------------------------------------------------------------------ */
          USING readr,r9
          USING work,rd
          USING work24,rb
          USING main,rc
          USING (main+4095,mainend),ra
readr     STM  r0,rf,save1
          LR   r9,rf

          LM   r2,r4,0(r1)          load offset, length, address

*/* Read the first block into the tempbuf                            */
          LR   r7,r2                copy the offset
          SRL  r7,14                get the block number   CZV70
          LTR  r2,r2                test offset
          BZ   r_getblk1            always read 1st block for offset 0
          CL   r7,lastblk           already have the 1st block ?
          BE   r_gotblk1             yes, continue
          ST   r7,lastblk           remember this block
          SLR  r6,r6
          D    r6,bpt               calculate ttr
          STCM r7,7,ttr                                    CZV70
          LA   r6,1(,r6)
          STC  r6,ttr+3                                    CZV70
          POINT sysut1,ttr          position to the block
          LTR  rf,rf
          BNZ  Epoint
r_getblk1 READ ut1decb,SF,sysut1,tempbuf,'S',MF=E
          CHECK ut1decb             read the block
r_gotblk1 DS   0H

*/* Copy data from the first block to the caller's buffer            */
          LR   r5,r2                calculate data offset
          N    r5,=A(X'00003fff')    in the first block    CZV70
          LH   r6,=Y(16384)         calculate data length  CZV70
          SR   r6,r5                 in the first block
          AR   r2,r6                new offset
          LR   re,r4                target address
          LR   rf,r6                data length in the first block
          CR   rf,r3                if requested length is less
          BL   *+6                   then use that instead
          LR   rf,r3
          LA   r0,tempbuf(r5)       source address
          LR   r1,rf                length to copy
          AR   r4,rf                adjust target address
          SR   r3,rf                adjust target length
          MVCL re,r0                copy data from the 1st block

*/* Read the intermediate blocks directly into the caller's buffer   */
r_getint  LTR  r3,r3                test length left to read
          BZ   r_return             return if everything read
          CH   r3,=Y(16384)   able to read a full block ?  CZV70
          BL   r_getlast             no, special processing for last
          READ ut1decb,SF,sysut1,(r4),'S',MF=E
          CHECK ut1decb             read an intermediate block
          AH   r2,=Y(16384)         adjust the offset      CZV70
          SH   r3,=Y(16384)         adjust the length left CZV70
          AH   r4,=Y(16384)         adjust buffer position CZV70
          B    r_getint             read some more

*/* Read the last block into the tempbuf                             */
r_getlast SRL  r2,14       change offset to block number   CZV70
          ST   r2,lastblk            and save it
          READ ut1decb,SF,sysut1,tempbuf,'S',MF=E
          CHECK ut1decb
          LR   re,r4                target address
          LR   rf,r3                target length
          LA   r0,tempbuf           source address
          LR   r1,rf                source length
          MVCL re,r0                copy data from the last block

r_return  LM   r0,rf,save1
          BR   re

          LTORG ,
          DROP ,

*/* -------------------------------------------------------------------
*   Subroutine to write track images to the offline dasd unit
* ------------------------------------------------------------------ */
          USING writer,r9
          USING work,rd
          USING work24,rb
          USING main,rc
          USING (main+4095,mainend),ra
writer    STM  r0,rf,save1
          LR   r9,rf

*/* If buffer address is zero then we simply wait on the last I/O    */
          LTR  r1,r1
          BZ   w_finish

*/* Get the IOB we will use                                          */
          L    r2,iobswtch          0 = iob1, 1 = iob2
          LA   r3,iob1              presume iob1
          LTR  r2,r2
          BZ   *+8
          LA   r3,iob2              use iob2 if switch is non-zero
          USING IOBSTDRD,r3
          X    r2,=A(1)             flip/flop the switch
          ST   r2,iobswtch

*/* Complete the channel program                                     */
          MVC  prevcchh,curcchh     copy last cchh scheculed
          MVC  curcchh,1(r1)        current cchh (from HA)
          MVC  IOBCC(4),curcchh     set extent in the iob
          SLR  r2,r2
          ICM  r2,7,IOBECBPB
          USING ECB,r2
          XC   ECB,ECB              clear the ecb

*/* If record 1 is end-of-track then make it eof then eot            */
          CLC  eightFF,5+8+8(r1)    check for end-of-track
          BNE  w_wnoteot             continue if not
          MVC  5+8+8(8,r1),5(r1)      else copy r0 t0 r1
          MVI  5+8+8+4(r1),1           and set r to 1
          MVI  5+8+8+7(r1),0            and data len to 0
          MVC  5+8+8+8(8,r1),eightFF     now set the eot
w_wnoteot DS   0h

          LA   r1,5+8+8(,r1)        point to record 1
          SLR  rf,rf                clear record count
          SLR  r4,r4
          ICM  r4,7,IOBSTRTB        address of the channel program
          USING CCW0,r4
          LA   r4,CCW0END           point past dx ccw
          LA   r4,CCW0END           point past tic ccw
          SLR  r5,r5
          ICM  r5,7,CCW0ADDR        locate record parm addr
          USING LRparm,r5
          MVC  LRseek,IOBCC
          MVC  LRsearch,IOBCC
w_wckd    LA   r4,CCW0END           point to next ccw
          LA   rf,1(,rf)            increment record count
          SLR  r6,r6
          ICM  r6,7,CCW0ADDR        load IDAW address
          ST   r1,0(,r6)            set record addr in the IDAW
          SLR  r0,r0
          IC   r0,5(,r1)            key length
          SLR  re,re
          ICM  re,3,6(r1)           data length
          AR   re,r0
          LA   re,8(,re)            cound-key-data-length
          STCM re,3,CCW0CNT
          OI   CCW0FLAG,CCW0CC+CCW0IDA set chain & idaw bits
          AR   r1,re                point to the next record
          CLC  eightFF,0(r1)        at end of the track ?
          BNE  w_wckd                no, keep building
          NI   CCW0FLAG,255-CCW0CC  turn off chain bit for last ccw
          STC  rf,LRcount           set count of WCKD ccws

*/* Schedule this channel program and wait for the previous one      */
          LR   rf,r2                copy ecb address
          L    r2,waitecb           load ecb address to wait on
          ST   rf,waitecb           set new ecb address to wait on
          EXCP IOBSTDRD             schedule the i/o
          LTR  r2,r2                any ecb to wait on ?
          BZ   w_return              no, just return
          WAIT 1,ECB=ECB            wait for previous i/o
          CLI  ECBCC,ECBNORM        successful completion ?
          BNE  Eioerr                no, i/o error
          B    w_return

*/* Wait for the last i/o to finish                                  */
w_finish  L    r2,waitecb           ecb for last i/o
          LTR  r2,r2                 is it set ?
          BZ   w_return               no, just return
          XC   waitecb,waitecb
          WAIT 1,ECB=ECB            wait for the last i/o
          CLI  ECBCC,ECBNORM         normal completion ?
          BNE  Eioerr                 no, i/o error

w_return  LM   r0,rf,save1
          BR   re

          LTORG ,
          DROP ,

*/* -------------------------------------------------------------------
*   Subroutine to issue messages
* ------------------------------------------------------------------ */
          USING msgr,r9
          USING work,rd
          USING work24,rb
          USING main,rc
          USING (main+4095,mainend),ra
msgr      STM  r0,rf,save2
          LR   r9,rf
prt       USING IHADCB,prtdcb
          TM   prt.DCBOFLGS,DCBOFOPN
          BO   mr_opened            continue if message file is opened

          LR   r2,r1                save reg 1
          TM   flags,noprint        test if no print file
          BO   mr_ret                return if not
          MVC  prtdcb,m_prtdcb      copy the model print dcb
          MVC  prtdcbe,m_prtdcbe    copy model print dcbe
          LA   r1,prtdcbe           set dcbe address
          ST   r1,prt.DCBDCBE        in the dcb
          OI   flags,noprint        presume no print
          DEVTYPE prt.DCBDDNAM,dw   issue devtype for the ddname
          LTR  rf,rf                test devtype return code
          BNZ  mr_ret                return if some error
          L    r1,=A(mr_oxit)       get address of the open exit
          LA   rf,mr_oxitl          get open exit length
          BCTR rf,0                 decrement
          EX   rf,*+4               copy the open exit
          MVC  openxit(0),0(r1)     *** executed ***
          LA   r1,openxit           get open exit addr
          ST   r1,exlst             set in exit list
          MVI  exlst,x'85'          set exit type
          LA   r1,exlst             point to exit list
          STCM r1,7,prt.DCBEXLSA    set exlst addr in the dcb
          MVC  openl,m_openl        copy model open list
          OPEN (prtdcb,OUTPUT),MODE=31,MF=(E,openl)
          TM   prt.DCBOFLGS,DCBOFOPN did the file open ?
          BNO  mr_ret                 no, return
          NI   flags,255-noprint       else turn off `noprt' bit
          LR   r1,r2                restore reg 1

mr_opened LM   r4,r5,0(r1)          pattern addr, length

          BCTR r5,0
          LA   r3,8(,r1)            first parameter
          LA   r6,msg
          MVI  msg,C' '             init msg to blanks
          MVC  msg+1(L'msg-1),msg

mr_loop   LTR  r5,r5
          BM   mr_exit
          LA   r1,1(r4,r5)
          SLR  r2,r2
          EX   r5,mr_trt1
          SR   r1,r4                length scanned
          BNP  mr_skip1
          LR   rf,r1
          BCTR rf,0
          EX   rf,mr_mvc1           copy literal text
          AR   r6,r1
mr_skip1  AR   r4,r1
          SR   r5,r1
          BM   mr_exit
          BP   mr_skip2

          MVC  0(1,r6),0(r4)        string ends in special char
          LA   r6,1(,r6)
          B    mr_exit

mr_skip2  B    *(r2)                br on special char type
          B    mr_pct               '%'
          B    mr_bs                '\'

mr_pct    CLI  1(r4),C's'
          BE   mr_pct_s
          CLI  1(r4),C'x'
          BE   mr_pct_x
          CLI  1(r4),C'd'
          BE   mr_pct_d
          MVC  0(1,r6),0(r4)        treat '%' as any other char
          LA   r6,1(,r6)
          LA   r4,1(,r4)
          BCTR r5,0
          B    mr_loop
mr_pct_s  L    r7,0(,r3)            load string ptr
          LA   r3,4(,r3)
          LA   r4,2(,r4)            point past '%s'
          SH   r5,=Y(2)
          BAL  re,mr_op             r1 - target len, r2 - source len
          LTR  r2,r2
          BNZ  mr_pct_s3
          LR   r2,r7                source len = 0, find end of string
mr_pct_s1 CLI  0(r2),C' '
          BNH  mr_pct_s2
          LA   r2,1(,r2)
          B    mr_pct_s1
mr_pct_s2 SR   r2,r7
          BNP  mr_loop
mr_pct_s3 LR   rf,r2                copy source string to the msg
          BCTR rf,0
          EX   rf,mr_mvc2
          LTR  r1,r1
          BNZ  mr_pct_s5
          AR   r6,r2                truncate trailing spaces if
mr_pct_s4 BCTR r6,0                  target len is 0
          CLI  0(r6),C' '
          BNH  mr_pct_s4
          LA   r6,1(,r6)
          B    mr_loop
mr_pct_s5 CR   r1,r2
          BH   mr_pct_s6
          AR   r6,r1                truncate the string
          B    mr_loop
mr_pct_s6 AR   r6,r2                pad string with trailing blanks
          SR   r1,r2
mr_pct_s7 MVI  0(r6),C' '
          LA   r6,1(,r6)
          BCT  r1,mr_pct_s7
          B    mr_loop

mr_pct_x  L    r7,0(,r3)            load hex ptr
          LA   r3,4(,r3)
          LA   r4,2(,r4)            point past '%x'
          SH   r5,=Y(2)
          BAL  re,mr_op             r1 - target len, r2 - source len
          LTR  r2,r2
          BNZ  *+8
          LA   r2,4                 default source len is 4
          EX   r2,mr_pct_x_unpk
          TR   dw,mr_hextab
          LTR  r1,r1
          BNZ  mr_pct_x1
          LA   r1,8                 determine default target len
          CLC  =C'00',dw
          BNE  mr_pct_x1
          LA   r1,6
          CLC  =C'0000',dw
          BNE  mr_pct_x1
          LA   r1,4
          CLC  =C'000000',dw
          BNE  mr_pct_x1
          LA   r1,2
mr_pct_x1 LA   r7,dw+8              copy the hex string to the msg
          SR   r7,r1
          BCTR r1,0
          EX   r1,mr_mvc2
          LA   r6,1(r1,r6)
          B    mr_loop

mr_pct_d  L    r7,0(,r3)            load decimal ptr
          LA   r3,4(,r3)
          LA   r4,2(,r4)            point past '%d'
          SH   r5,=Y(2)
          BAL  re,mr_op             r1 - target len, r2 - source len
          LTR  r2,r2
          BNZ  *+8
          LA   r2,4                 default source len is 4
          LA   rf,4
          SR   rf,r2
          LA   re,15
          SRL  re,0(rf)
          EX   re,mr_pct_d_icm
          CVD  rf,dw
          MVC  dw2(16),=X'40202020202020202020202020202120'
          ED   dw2(16),dw
          LTR  r1,r1
          BNZ  mr_pct_d2
          LA   rf,dw2+16            default length -
mr_pct_d1 BCTR rf,0                  truncate leading spaces
          CLI  0(rf),C' '
          BH   mr_pct_d1
          LA   r1,dw2+15
          SR   r1,rf
mr_pct_d2 LA   r7,dw2+16
          SR   r7,r1
          BCTR r1,0
          EX   r1,mr_mvc2
          LA   r6,1(r1,r6)
          B    mr_loop

mr_bs     MVC  0(1,r6),1(r4)        copy char following '\'
          LA   r6,1(,r6)
          LA   r4,2(,r4)
          SH   r5,=Y(2)
          B    mr_loop

mr_exit   LA   r1,msg
          SR   r6,r1                calculate msg length
          BNP  mr_ret
          TM   prt.DCBRECFM,DCBRECCA+DCBRECCM
          BZ   *+8
          LA   r6,1(,r6)            increment for carriage control

          TM   prt.DCBRECFM,DCBRECU
          BO   mr_u
          TM   prt.DCBRECFM,DCBRECF
          BO   mr_f
          TM   prt.DCBRECFM,DCBRECV
          BO   mr_v

mr_u      CH   r6,prt.DCBBLKSI
          BNH  *+8
          LH   r6,prt.DCBBLKSI
          STH  r6,prt.DCBLRECL
          PUT  prtdcb
          TM   prt.DCBRECFM,DCBRECCA+DCBRECCM
          BZ   mr_u1
          MVI  0(r1),C' '
          LA   r1,1(,r1)
          BCTR r6,0
          TM   prt.DCBRECFM,DCBRECCA
          BO   mr_u1
          BCTR r1,0
          MVI  0(r1),X'09'
          LA   r1,1(,r1)
mr_u1     BCTR r6,0
          EX   r6,mr_mvc3
          B    mr_ret

mr_f      CH   r6,prt.DCBLRECL
          BNH  *+8
          LH   r6,prt.DCBLRECL
          PUT  prtdcb
          TM   prt.DCBRECFM,DCBRECCA+DCBRECCM
          BZ   mr_f1
          MVI  0(r1),C' '
          LA   r1,1(,r1)
          BCTR r6,0
          TM   prt.DCBRECFM,DCBRECCA
          BO   mr_f1
          BCTR r1,0
          MVI  0(r1),X'09'
          LA   r1,1(,r1)
mr_f1     BCTR r6,0
          EX   r6,mr_mvc3
          B    mr_ret

mr_v      LA   r6,4(,r6)
          LH   r1,prt.DCBBLKSI
          SH   r1,=Y(4)
          CR   r6,r1
          BNH  *+6
          LR   r6,r1
          STH  r6,prt.DCBLRECL
          PUT  prtdcb
          STH  r6,0(,r1)
          XC   2(2,r1),2(r1)
          LA   r1,4(,r1)
          SH   r6,=Y(4)
          TM   prt.DCBRECFM,DCBRECCA+DCBRECCM
          BZ   mr_v1
          MVI  0(r1),C' '
          LA   r1,1(,r1)
          BCTR r6,0
          TM   prt.DCBRECFM,DCBRECCA
          BO   mr_v1
          BCTR r1,0
          MVI  0(r1),X'09'
          LA   r1,1(,r1)
mr_v1     BCTR r6,0
          EX   r6,mr_mvc3
          B    mr_ret

mr_ret    LM   r0,rf,save2
          BR   re

*/* -------------------------------------------------------------------
* message subroutine to get operand lengths
* ------------------------------------------------------------------ */

mr_op     SLR  r1,r1
          SLR  r2,r2
mr_op1    LTR  r5,r5                first number is target length
          BMR  re
          CLI  0(r4),C'0'
          BL   mr_op2
          IC   rf,0(,r4)
          N    rf,=A(X'0000000f')
          MH   r1,=Y(10)
          AR   r1,rf
          LA   r4,1(,r4)
          BCTR r5,0
          B    mr_op1
mr_op2    CLI  0(r4),C':'          second number follows a ':'
          BNER re
mr_op3    LA   r4,1(,r4)           second number is source length
          SH   r5,=Y(1)
          BMR  re
          CLI  0(r4),C'0'
          BLR  re
          IC   rf,0(,r4)
          N    rf,=A(X'0000000f')
          MH   r2,=Y(10)
          AR   r2,rf
          B    mr_op3

*/* ---------------------------------------------------------------- */

mr_mvc1   MVC  0(0,r6),0(r4)
mr_trt1   TRT  0(0,r4),mr_tab1
mr_mvc2   MVC  0(0,r6),0(r7)
mr_mvc3   MVC  0(0,r1),msg
mr_pct_x_unpk  UNPK dw(9),0(0,r7)
mr_pct_d_icm   ICM rf,0,0(r7)
mr_tab1   DC   XL256'0'
          ORG  mr_tab1+C'%'
          DC   AL1(4)
          ORG  mr_tab1+C'\'
          DC   AL1(8)
          ORG  mr_tab1+256
mr_hextab EQU  *-240
          DC   C'0123456789abcdef'
          LTORG ,
         #MSG  TYPE=GEN           messages
          DROP ,

*/* -------------------------------------------------------------------
*   message open exit - relocated to 24 bit storage
* ------------------------------------------------------------------ */

         USING mr_oxit,rf
         USING IHADCB,R1
mr_oxit  CLI   DCBRECFM,0          any record format ?
         BNE   *+8                  jumps if yes
         MVI   DCBRECFM,DCBRECV+DCBRECBR else set to `vb'

         SLR   r0,r0               get a zero
         CH    r0,DCBLRECL         any lrecl
         BNE   *+10                 jumps if yes
         MVC   DCBLRECL,=Y(125)      copy default lrecl

         CH    r0,DCBBLKSI         any blksize
         BNE   *+10                 jumps if yes
         MVC   DCBBLKSI,=Y(16384)    copy default blksize  CZV70

         TM    DCBRECFM,DCBRECU    test record type
         BO    mr_oxitu             undefined
         TM    DCBRECFM,DCBRECV    test record type
         BO    mr_oxitv             variable
         TM    DCBRECFM,DCBRECF    test record type
         BO    mr_oxitf             fixed
         B     mr_oxit0            unknown, return

mr_oxitu MVC   DCBLRECL,DCBBLKSI   undefined, set lrecl from blksize
         B     mr_oxit0            return

mr_oxitv LH    r3,DCBBLKSI         variable, load blksize
         LA    r0,4                calculate maximum
         SR    r3,r0                lrecl
         CH    r3,DCBLRECL         check against lrecl
         BNL   mr_oxit0             return if not too high
         STH   r3,DCBLRECL           else reset to max
         B     mr_oxit0            return

mr_oxitf LH    r3,DCBBLKSI         fixed, load blksize
         SLR   r2,r2               clear for divide
         LH    r0,DCBLRECL         load lrecl
         DR    r2,r0               divide lrecl into blksize
         LTR   r2,r2               test if any remainder
         BZ    mr_oxit0            return if not
         MH    r3,DCBLRECL         calculate new blksize
         STH   r3,DCBBLKSI         set new blksize

mr_oxit0 BR    re
         LTORG ,
mr_oxitl EQU   *-mr_oxit
         DROP  ,

*/* -------------------------------------------------------------------
*   workareas
* ------------------------------------------------------------------ */
work     DSECT ,
workid   DS    0CL4                     identifier
save     DS    18F                      standard save area
save1    DS    16F                      save area for read/write
save2    DS    16F                      save area for subroutines
result   DS    F                        result (return) value
flags    DS    X                        flag bits
ucbpin   EQU   X'80'                    offline dasd ucb pinned
captucb  EQU   X'40'                    offline dasd ucb captured
debadded EQU   X'20'                    offline dasd ucb deb added
notready EQU   X'10'                    offline ucb `not ready' bit
noprint  EQU   X'01'                    print ddname not present
unit     DS    H                        offline unit address
bpt      DS    F                        cckd file blocks per track
heads    DS    F                        cckd heads per cylinder
trklen   DS    F                        cckd track length
utrklen  DS    F                        unit track length
complen  DS    F                        compression length
devtype  DS    H                        cckd device type
numl1tab DS    F                        number l1tab entries
lasttrk  DS    F                        last track
lastcyl  DS    F                        last cylinder
cyls     DS    F                        cylinders to write
tracks   DS    F                        tracks to write
track    DS    F                        tracks being written
trk10pct DS    F                        tracks per status message
trkstat  DS    F                        write status msg at this trk
handle   DS    F                        persistent c handle
prevcchh DS    F                        previous cchh written
curcchh  DS    F                        current cchh being written
waitecb  DS    A                        address of ecb to wait on
iobswtch DS    F                        iob flip/flop indicator
retcd    DS    F                        return code
rsncd    DS    F                        reason code
ucbaddr  DS    A                        ucb address
cucbaddr DS    A                        captured ucb address
debaddr  DS    A                        deb address
bufs     DS    0A                       i/o area address
buf1     DS    A
buf2     DS    A
buf3     DS    A
buf4     DS    A
ptoken   DS    D                        ucb pin token
devta    DS    D                        devtype area
ctime    DS    D                        current date/time
dtime    DS    CL20                     date/time display area
lastblk  DS    F               last cckd 16384 block read  CZV70
ttr      DS    F                        ttr for cckd block
dw       DS    D                        double word work areas
dw2      DS    D
dw3      DS    D
dw4      DS    D
sysut1e  DS    XL(l_sysut1e)            cckd file dcbe
prtdcbe  DS    XL(l_prtdcbe)            print dcbe
pl       DS    32F                      general parameter list
openl    DS    XL(l_openl)              open parameter list
devhdr   DS    0XL(CKDDASD_DEVHDR_SIZE) device header
cdevhdr  DS    XL(CCKDDASD_DEVHDR_SIZE) compressed device header
l1tab    DS    A                        l1tab address
l2tab    DS    XL(CCKD_L2TAB_SIZE)      l2tab
msg      DS    CL256                    message
tempbuf  DS    XL16384          temp buffer for cckd read  CZV70
workl    EQU   *-work

work24    DSECT ,                  24-bit work area
work24id  DS    CL4                identifier
zeros     DS    XL16               24-bit zeroes
unitdcb   DS    XL(l_unitdcb)      offline dasd dcb
sysut1    DS    XL(l_sysut1)       sysut1 dcb
          READ  ut1decb,SF,MF=L    sysut1 decb
prtdcb    DS    XL(l_prtdcb)       sysprint dcb
exlst     DS    F                  dcb exit list
snsidarea DS    XL20               device snsid info
snsarea   DS    XL32               device sense
rdcarea   DS    XL64               device characteristics
snssarea  DS    XL40               device snss info
ecb1      DS    F                  output ecb 1
ecb2      DS    F                  output ecb 2
iob1      DS    XL40               output iob 1
iob2      DS    XL40               output iob 2
lrparm1   DS    XL16               locate record parameter area 1
lrparm2   DS    XL16               locate record parameter area 2
dxarea    DS    XL16               define extent area
openxit   DS    XL256              relocated message open exit
idaw1     DS    255A               idaws 1
idaw2     DS    255A               idaws 2
ccws      DS    258D               channel program 1
ccwl      EQU   *-ccws             channel program length
ccw2      DS    258D               channel program 2
work24l   EQU   *-work24

RDCinfo  DSECT ,                  read device characteristics info
RDCsdt   DS    XL2                storage director type
RDCsdmi  DS    X                  storage director model information
RDCdevt  DS    XL2                device type
RDCdevm  DS    X                  device model
RDCdasdf DS    XL4                device & storage director facilities
RDCclass DS    X                  device class code
RDCtype  DS    X                  device type code
RDCprime DS    XL2                number of primary cylinders
RDCheads DS    XL2                tracks per cylinde
RDCsctrs DS    X                  number of sectors
RDCtrkln DS    XL3                total track length (usable)
RDChar0  DS    XL2                length of ha and r0
RDCtccf  DS    X                  track capacity calculation formula
RDCfctrs DS    XL5                track capacity calculation factors
RDCacyl  DS    XL2                address of first alternate cylinder
RDCacyln DS    XL2                number of alternate tracks
RDCdcyl  DS    XL2                address of first diagnostic cylinder
RDCdcyln DS    XL2                number of diagnostic tracks
RDCscyl  DS    XL2                address of first device support cyl
RDCscyln DS    XL2                number of device support tracks
RDCmdrid DS    X                  mdr record id
RDCobrid DS    X                  obr record id
RDCsdtc  DS    X                  storage director type code
RDCrtspl DS    X                  read trackset parameter length
RDCmaxr0 DS    XL2                maximum record zero data length
         DS    X                  (reserved)
RDCtss   DS    X                  track set size
RDCatccf DS    X                  additional track capacity calc. factr
RDCrps   DS    XL2                rps sector calculation factors
         DS    XL3                (reserved)
RDCgdff  DS    X                  generic device/cu functions/features
         DS    X                  (reserved -- zeroes)
RDCrduc  DS    X                  real control unit code
RDCrdc   DS    X                  real device code
         DS    XL6                (reserved)
RDCinfol EQU   *-RDCinfo

LRparm   DSECT ,                  locate record paramete
LRop     DS    X                  operation byte
LRocount EQU   B'00000000'        orient count
LRohome  EQU   B'01000000'        orient home
LRodata  EQU   B'10000000'        orient data
LRoindex EQU   B'11000000'        orient index
LRorient EQU   X'00'              orient
LRwrite  EQU   X'01'              write data
LRfwrite EQU   X'03'              format write
LRread   EQU   X'06'              read data
LRwt     EQU   X'0b'              write track
LRrt     EQU   X'0c'              read tracks
LRrd     EQU   X'16'              read
LRaux    DS    X                  auxiliary byte
LRusetlf EQU   B'10000000'        transfer length factor specified
LRrcccw  EQU   B'00000001'        a read count ccw is suffixed
         DS    X
LRcount  DS    X                  count parameter
LRseek   DS    0XL4               seek addr
LRseekcc DS    XL2
LRseekhh DS    XL2
LRsearch DS    0XL5               search arg
LRsrchcc DS    XL2
LRsrchhh DS    XL2
LRsrchr  DS    X
LRsector DS    X
LRtlf    DS    XL2                transfer length factor
LRparml  EQU   *-LRparm

CKDDASD_DEVHDR   DSECT ,
devhdr_devid     DS    CL8
devhdr_heads     DS    F
devhdr_trksize   DS    F
devhdr_devtype   DS    X
devhdr_fileseq   DS    X
devhdr_highcyl   DS    H
                 DS    XL492
CKDDASD_DEVHDR_SIZE    EQU *-CKDDASD_DEVHDR

CKDDASD_TRKHDR   DSECT ,
trkhdr_bin       DS    X
trkhdr_cyl       DS    XL2
trkhdr_head      DS    XL2
CKDDASD_TRKHDR_SIZE    EQU *-CKDDASD_TRKHDR

CCKDDASD_DEVHDR  DSECT   ,
cdevhdr_vrm      DS      XL3
cdevhdr_options  DS      X
cdevhdr_numl1tab DS      F
cdevhdr_numl2tab DS      F
cdevhdr_size     DS      F
cdevhdr_used     DS      F
cdevhdr_free     DS      F
cdevhdr_free_total    DS F
cdevhdr_free_largest  DS F
cdevhdr_free_number   DS F
cdevhdr_free_imbed    DS F
cdevhdr_cyls     DS      F
                 DS      X
cdevhdr_compress DS      X
cdevhdr_compress_parm DS H
                 DS      XL464
CCKDDASD_DEVHDR_SIZE EQU *-CCKDDASD_DEVHDR

CCKD_VERSION     EQU   0
CCKD_RELEASE     EQU   2
CCKD_MODLVL      EQU   1

CCKD_NOFUDGE     EQU   1
CCKD_BIGENDIAN   EQU   2
CCKD_OPENED      EQU   128

CCKD_COMPRESS_NONE  EQU 0
CCKD_COMPRESS_ZLIB  EQU 1
CCKD_COMPRESS_BZIP2 EQU 2
CCKD_COMPRESS_MAX   EQU CCKD_COMPRESS_BZIP2

CCKD_L1TAB_POS      EQU CKDDASD_DEVHDR_SIZE+CCKDDASD_DEVHDR_SIZE
CCKD_L1ENT_SIZE     EQU 4
CCKD_NULLTRK_SIZE   EQU 37

CCKD_L2ENT       DSECT   ,
l2ent_pos        DS      F
l2ent_len        DS      H
l2ent_size       DS      H
CCKD_L2ENT_SIZE  EQU     *-CCKD_L2ENT
CCKD_L2TAB_SIZE  EQU     256*CCKD_L2ENT_SIZE

*/* -------------------------------------------------------------------
*   dsects
* ------------------------------------------------------------------ */
         PRINT NOGEN
         DCBD  DSORG=PS
         IHADCBE ,
UCBDSECT DSECT ,
         IEFUCBOB ,
         IEZDEB ,
DEBLENGTH EQU  (DEBBASND-DEBAVT)+(DEBDASDE-DEBDASD)+DEBXLEN
         IEZIOB ,
         IHAECB ,
         IOSDCCW ,
         CVT   DSECT=YES
         IHAPSA ,
         IKJTCB ,
STAR     TRKCALC MF=D

*/* -------------------------------------------------------------------
*   equates
* ------------------------------------------------------------------ */
SK    EQU X'07'
SNSID EQU X'e4'
SNS   EQU X'04'
RDC   EQU X'64'
SNSS  EQU X'54'
RT    EQU X'de'
DX    EQU X'63'
LR    EQU X'47'
WR0   EQU X'15'
WCKD  EQU X'1d'
TIC   EQU X'08'

r0 EQU 0
r1 EQU 1
r2 EQU 2
r3 EQU 3
r4 EQU 4
r5 EQU 5
r6 EQU 6
r7 EQU 7
r8 EQU 8
r9 EQU 9
ra EQU 10
rb EQU 11
rc EQU 12
rd EQU 13
re EQU 14
rf EQU 15

   END ,