*COPY                                                 IKTUTL            05000000
         CHECKVER IKTUTL,4.3                                   @SC90072 05000500
         TITLE 'CWDSET/DSPACE Routines - set/show working directory'    05001000
* Set new 'working directory', i.e., DSN prefix                         05001500
* Entry: SCANPTR string has option                                      05002000
* Exit: R15=0 if ok, R15=1 if error or help needed. ERRNUM unchanged.   05002500
CWDSET   ENTER                                                 @SC86164 05003000
         SR    5,5                                             @SC86299 05003500
         MVI   IFILE+44,C' '                                   @SC86299 05004000
         NTOKN N=CWDLEN,H=CWDERR                               @SC86299 05004500
         LA    1,0(7,6)      End of string                     @SC86299 05005000
         BCTR  1,0                                             @SC86299 05005500
         CLC   =C'()',0(1)   Prefix is PDS name?               @SC86299 05006000
         BNE   CWDTL         No                                @SC86299 05006500
         S     7,F2          Yes, remove null member name      @SC86299 05007000
         BM    CWDERR                                          @SC86299 05007500
         MVI   IFILE+44,C'.' Indicate PDS wanted               @SC86299 05008000
CWDTL    LA    7,1(7)        Token length                      @SC86299 05008500
         CH    7,LA44+2      Suitable?                         @SC86299 05009000
         BH    CWDERR        Too long                          @SC86299 05009500
         LR    5,7                                             @SC86299 05010000
         ICM   7,8,BLANK                                       @SC86299 05010500
         LA    0,IFILE                                         @SC86299 05011000
LA44     LA    1,44          Length of DSN alone               @SC86299 05011500
         MVCL  0,6           Copy to filename buffer           @SC86299 05012000
         TR    IFILE,UPCASE  And upcase it                     @SC87034 05012500
       NXTFSET IFILE,CWD,E=CWDERR                              @SC86295 05013000
CWDLEN   MVC   DEST(45),IFILE Save new prefix                  @SC86299 05013500
         STH   5,DESTL                                         @SC86299 05014000
         B     RTRN0                                           @SC86295 05014500
CWDERR   PTEXT '&CWDERRM'                                      @SC86299 05015000
         B     SUBERR                                          @SC86295 05015500
*                                                                       05016000
*        DSPACE Routine - display available disk space         @SC86164 05016500
*                                                                       05017000
* Show space available in 'working directory' or other area             05017500
* Entry: SCANPTR string has option (none => working directory)          05018000
* Exit: R15=0 if ok, R15=1 if error or help needed. ERRNUM unchanged    05018500
DSPACE   ENTER ALT                                             @SC86164 05019000
* * * * * * * * * * * * * * * * * * * * * *                             05019500
         PTEXT '&SPACERR'                                      @SC86299 05020000
         B     SUBERR                                          @SC86299 05020500
* * * * * * * * * * * * * * * * * * * * * *                             05021000
         B     RTRN0                                           @SC86295 05021500
         LOCALS ,                                              @SC86295 05022000
         EXIT  ,                                               @SC86295 05022500
         TITLE 'FSPEC Routine - extract filespec from scan string'      05023000
*                                                                       05023500
* Entry: R1->name field, R0=flags selecting operation (see below)       05024000
*        For parse operations, SCANPTR defines the input string.        05024500
*        For getting foreign or display filespec, R7->output buffer     05025000
* Exit: if not FFNEW, then R15=0 if ok, 1 if ?, 2 if bad.               05025500
*        For R15=1 or 2 R3,R4 give message.  ERRNUM may be leftover.    05026000
*                                                                       05026500
*                                 Flags:                  Notes:        05027000
*   Tasks:               FFRCF FFSND FFGET FFNEW                        05027500
* Parse RECV               X                     set ROVR properly      05028000
* Parse SEND 1st                 X                                      05028500
* Parse SEND 2nd           X     X                                      05029000
* Parse GET 1st                        X                                05029500
* Parse GET 2nd            X           X         set ROVR properly      05030000
* Parse F-packet   (FFHDR) X     X     X                                05030500
* Parse for Generic(FFUTL)       X     X         FFWLD: allow partial   05031000
* Parse TAKE                                                            05031500
*                                                                       05032000
* Get unique name                            X     R15: 0=>ok, 1=>bad   05032500
* Interactive name check               X     X     R15: 0=>ok, 1=>bad   05033000
* Get foreign name (FFENC) X                 X     R15->end of string   05033500
* Get display form (FFDSP)       X           X     R15->end of string   05034000
*                                                                       05034500
FSPEC    ENTER                                                 @SC86295 05035000
         STC   0,FSPFLG                                        @SC86295 05035500
         LR    5,0                                             @SC88049 05036000
         SRL   5,4           Convert flags to index            @SC88049 05036500
         LR    0,1           Copy ptr to filespec              @SC86295 05037000
         TM    FSPFLG,FFNEW                                    @SC86295 05037500
         BO    FSPWRN                                          @SC86295 05038000
         LR    8,1           Save ptr to DSN field             @SC86299 05038500
         XC    0(52,8),0(8)  Clear DSN field                   @SC86299 05039000
         MVC   52(8,8),=CL8' ' Clear password                  @SC88342 05039500
         PTEXT '&BADFSPC'                                      @SC86299 05040000
         MVI   ERRNUM,ERRFNE Assume bad file name              @SC86158 05040500
         IC    5,FSP0(5)     Get dispatch adr                  @SC88049 05041000
         B     FSP0(5)       Go to proper handler              @SC88049 05041500
*               TAKE        GET 1st    SEND 1st    Generic     @SC88049 05042000
FSP0    DC AL1(FSPCPY-FSP0,FSPSN2-FSP0,FSPASC-FSP0,FSPUTL-FSP0) SC88049 05042500
*               RECEIVE     GET 2nd    SEND 2nd    F-packet    @SC88049 05043000
        DC AL1(FSPRC-FSP0,FSPRC-FSP0,FSPSN2-FSP0,FSPHD-FSP0)   @SC88049 05043500
FSPUTL   TM    FSPFLG,FFWLD  Utility: default to all files?    @SC88049 05044000
         BZ    FSPASC        No                                @SC86295 05044500
         LA    1,LFID                                          @SC88043 05045000
         LA    14,DEST       Default to prefix                 @SC88043 05045500
         LH    15,DESTL                                        @SC88043 05046000
         BAL   2,FSPBPAD     Copy with blank fill              @SC88070 05046500
         LR    0,8           Restore ptr to name field         @SC88043 05047000
FSPASC   TM    FL2,SRV       Server mode?                      @SC86295 05047500
         BZ    FSPCPY        No, don't need to convert         @SC86295 05048000
         ICM   15,15,LEN     Get length                        @SC86295 05048500
         BZ    FSPCPY                                          @SC86295 05049000
         BCTR  15,0          Correct for EX                    @SC86158 05049500
         L     5,ADR         Get string ptr                    @SC89215 05050000
         EX    15,FSPTRAE    Change to EBCDIC                  @SC89215 05050500
         EX    15,FSPTRUP    Upcase and dot to space           @SC89215 05051000
         B     FSPCPY                                          @SC86295 05051500
FSPTRAE  TR    0(,5),ATOED                                     @SC89301 05052000
FSPTRUP  TR    0(,5),UPCASE                                    @SC89215 05052500
FSPRC    NI    FL1,255-ROVR  Setup for RECEIVE                 @SC86295 05053000
         NI    FL4,255-NMOK-NMCHNG  Collision not checked yet  @SC90033 05053500
         MVI   0(1),C'$'     Allow missing DSN                 @SC86299 05054000
         B     FSPCPY                                          @SC86295 05054500
FSPHD    MVI   0(1),1        Use default if missing DSN        @SC86299 05055000
         B     FSPCPY                                          @SC86299 05055500
FSPSN2   CLI   BRK,C','                                        @SC88306 05056000
         BE    RTRN0         No foreign name: multiple format  @SC88306 05056500
         NTOKN H=FSP2H,N=RTRN0                                 @SC88306 05057000
         LA    7,1(,7)       Get token length                  @SC89179 05057500
         LA    1,L'JFNAM                                       @SC86295 05058000
         CR    7,1           Does it fit?                      @SC89179 05058500
         BNH   *+6           Yes                               @SC86224 05059000
         LR    7,1           Use what we can                   @SC86224 05059500
         LR    3,0                                             @SC86295 05060000
         STC   7,0(3)        Save length                       @SC86224 05060500
         LA    0,1(3)                                          @SC86295 05061000
         MVCL  0,6           Get fn, at least                  @SC86224 05061500
         B     RTRN0                                           @SC86295 05062000
*                                                                       05062500
FSPSLSH  TRT   0(,6),FSPTRSL Find slash, if any                @SC88342 05063000
FSPPSMV  MVC   52(,8),1(1)   Copy password into field          @SC88342 05063500
*                                                                       05064000
FSPCPY   NTOKN H=FSPH,N=FSPZ                                   @SC86299 05064500
FSPCP2   MVC   FSPCH1,0(6)   Save 1st char                     @SC88043 05065000
         MVI   TRTBL+C'.',1  Set to intercept these            @SC88043 05065500
         MVI   TRTBL+C'(',2                                    @SC86299 05066000
         KCALL FOPSTR,LFID(,8),E=FSPINV                        @SC89218 05066500
         LR    2,7           Save length-1                     @SC88342 05067000
         LA    15,44         Length of DSN proper              @SC86299 05067500
         AR    7,6           Last char of string               @SC86299 05068000
         LR    1,7                                             @SC88342 05068500
         EX    2,FSPSLSH     Look for '/'                      @SC88342 05069000
         BZ    FSPPSZ        No password                       @SC88342 05069500
         SR    7,1           Get length                        @SC88342 05070000
         BNP   FSPPSY        None after all                    @SC88342 05070500
         CH    7,*+10        Check against maximum             @SC88342 05071000
         BNH   *+8           Ok                                @SC88342 05071500
         LA    7,8           Max length                        @SC88342 05072000
         BCTR  7,0           Prepare for MVC                   @SC88342 05072500
         EX    7,FSPPSMV     Move password to output field     @SC88342 05073000
FSPPSY   LR    7,1           Remove password from string       @SC88342 05073500
         BCTR  7,0           Remove '/' too                    @SC88342 05074000
FSPPSZ   DS    0H                                              @SC88342 05074500
         CLI   0(6),C''''    Full name?                        @SC86299 05075000
         BNE   FSPPRE        No, add prefix                    @SC86299 05075500
         LA    6,1(6)        Yes, skip over quote              @SC86299 05076000
         CLI   0(7),C''''    Must have close quote as well     @SC86299 05076500
         BNE   *+6                                             @SC86299 05077000
         BCTR  7,0           Back up over it                   @SC86299 05077500
         BE    *+8                                             @SC86299 05078000
         BAL   9,FSPTU       Missing: quit if user typed this  @SC86299 05078500
         B     FSPPREZ                                         @SC86299 05079000
FSPPRE   CLI   0(7),C''''    Better not be trailing quote      @SC86299 05079500
         BNE   *+10          Ok                                @SC86299 05080000
          BAL  9,FSPTU       Error                             @SC86299 05080500
          BCTR 7,0           Didn't quit, so patch it up       @SC86299 05081000
         LH    1,DESTL       Length of prefix                  @SC86299 05081500
         LTR   1,1           Any?                              @SC86299 05082000
         BZ    FSPPREZ       No                                @SC86299 05082500
         LA    14,DEST       Ptr to prefix string              @SC86299 05083000
         MVCL  0,14          Copy prefix to name field         @SC86299 05083500
         CLI   DESTP,C'.'    PDS?                              @SC86299 05084000
         BNE   FSPDOT        No, join with a dot               @SC88070 05084500
         BAL   2,FSPBFIL     Yes, prefix is entire DSN         @SC88070 05085000
         TM    FSPFLG,FFHDR  Reading from header packet?       @SC88070 05085500
         BNO   FSPCPP        No, user must have entered it     @SC88070 05086000
         BAL   9,FSPFDOT     Ok, find file type, if any        @SC88070 05086500
         LR    7,1           And skip it                       @SC88070 05087000
         B     FSPCPG                                          @SC88070 05087500
FSPDOT   LA    14,LOCASE+C'.'                                  @SC86299 05088000
         LA    1,1                                             @SC86299 05088500
         MVCL  0,14          Append a dot                      @SC86299 05089000
FSPPREZ  BAL   2,FSPANAT     Add '#' if numeric char next      @SC86299 05089500
FSPCPA   BAL   9,FSPFDOT     Find a break (dot or end)         @SC88070 05090000
         SR    1,6           Length of token                   @SC86299 05090500
         BP    *+8                                             @SC86299 05091000
          BAL  9,FSPTU       Null token                        @SC86299 05091500
         LR    14,6          Save start of token               @SC86299 05092000
         AR    6,1           Ptr to break                      @SC86299 05092500
         CR    1,5           Max allowed for this token        @SC86299 05093000
         BNH   *+10          Ok                                @SC86299 05093500
          BAL  9,FSPTU       Too long                          @SC86299 05094000
          LR   1,5           Use max                           @SC86299 05094500
         CR    1,15          Room left in name field?          @SC86299 05095000
         BNH   FSPCPC        Ok                                @SC86299 05095500
         BAL   9,FSPTU       Overfilled                        @SC86299 05096000
         MVI   TRTBL+C'.',0  Keep going, but ignore further tok@SC86299 05096500
         LR    1,15                                            @SC86299 05097000
FSPCPC   MVCL  0,14          Copy token                        @SC86299 05097500
         BCT   2,FSPCPF      Go if reached end of name         @SC86299 05098000
         LA    6,1(6)        Skip over dot                     @SC86299 05098500
         CR    6,7           Was dot the last char?            @SC86299 05099000
         BH    FSPCPE        Yes, oops                         @SC86299 05099500
         C     15,F1         Room for another token?           @SC86299 05100000
         BH    FSPDOT        Ok, keep going                    @SC86299 05100500
         SR    5,5           No, suppress further tokens       @SC86299 05101000
         BAL   9,FSPTU       Quit if user typed it             @SC86299 05101500
         B     FSPCPA        Keep going                        @SC86299 05102000
FSPTRT   TRT   0(,6),TRTBL   Find end of token                 @SC86299 05102500
FSPCPE   BAL   9,FSPTU       Quit if user type it              @SC86299 05103000
FSPCPF   CR    6,7                                             @SC92147 05103500
         BNL   FSNOTGDG      End of name, definitely not GDG   @SC92147 05104000
         CH    15,=H'9'      Room for last GDG index?          @SC92147 05104500
         BL    FSNOTGDG      No, definitely not GDG            @SC92147 05105000
         CLI   1(6),C'+'                                       @GA92147 05105500
         BE    FSCPGDG                                         @GA92147 05106000
         CLI   1(6),C'-'                                       @GA92147 05106500
         BE    FSCPGDG                                         @GA92147 05107000
         CLI   1(6),C'0'                                       @GA92147 05107500
         BNE   FSNOTGDG                                        @GA92147 05108000
FSCPGDG  SR    7,6           Get source length in R7           @GA92147 05108500
         LA    7,1(,7)       Bump length by 1                  @GA92147 05109000
         ICM   7,8,BLANK     For padding                       @GA92147 05109500
         LR    1,15          Dest length remaining             @GA92147 05110000
         MVCL  0,6           Move GDG 'member'                 @GA92147 05110500
         CLM   7,7,F0        Any overflow?                     @SC92147 05111000
         BE    *+12          No, continue                      @SC92147 05111500
          BAL  9,FSPTU       Error                             @SC92147 05112000
          MVI  43(8),C')'    Try to repair it, if possible     @SC92147 05112500
         LR    7,6           Reset "end" ptr                   @SC92147 05113000
         LA    5,FSPTBGDG    Use table for GDG names           @SC92147 05113500
         B     FSPCPG        Go fill member field with blanks  @SC92147 05114000
FSNOTGDG BAL   2,FSPBFIL     Fill the rest with blanks         @GA92147 05114500
         LA    5,FSPTAB      Use table for normal DSNAMEs      @SC92147 05115000
         BCTR  6,0           Back up to last char of DSN       @SC86299 05115500
         CR    6,7                                             @SC86299 05116000
         BE    FSPCPG        No member name                    @SC86299 05116500
         LA    6,2(6)        Ptr to member name                @SC86299 05117000
         CLI   0(7),C')'     Must be matching paren            @SC86299 05117500
         BE    FSPCPG        Ok                                @SC86299 05118000
         BAL   9,FSPTU       Oops                              @SC86299 05118500
FSPCPP   LA    7,1(7)        Pretend it's there                @SC86299 05119000
FSPCPG   SR    7,6           Length of member name             @SC86299 05119500
         LA    15,8          Length of member name, if any     @SC88070 05120000
         BZ    FSPCPM        None, forget it                   @SC86299 05120500
         ST    5,FSPDSN      Save table ptr                    @SC92147 05121000
         BAL   2,FSPANAT     '#' if numeric char next          @SC86299 05121500
         L     5,FSPDSN      Restore                           @SC92147 05122000
FSPCPM   LR    14,0                                            @SC86299 05122500
         ICM   7,8,BLANK                                       @SC86299 05123000
         MVCL  14,6          Copy member name                  @SC86299 05123500
         CLM   7,7,F0        Did it fit?                       @SC86299 05124000
         BE    *+8                                             @SC86299 05124500
          BAL  9,FSPTU       Oops                              @SC86299 05125000
         MVC   FSPDSN,0(8)   Save raw name                     @SC86299 05125500
         TR    FSPDSN,UPCASE Upcase it                         @SC87034 05126000
         TR    0(52,8),0(5)  Convert to valid chars, if nec.   @SC92147 05126500
         TR    44(8,8),FSPMTAB Stricter limits on member name  @SC86299 05127000
         TR    52(8,8),UPCASE Upcase password, if any          @SC88342 05127500
         CLI   FSPFLG,FFUTL  DELETE?                           @SC88096 05128000
         BE    FSPTCNV       Yes, allow '*'                    @SC88096 05128500
         CLI   FSPFLG,FFSND  Send request?                     @SC88096 05129000
         BE    FSPTCNV       Yes, allow '*'                    @SC88096 05129500
         TR    0(52,8),FSPSTAB  Convert asterisk to pound sign @SC88096 05130000
FSPTCNV  DS    0H                                              @SC88096 05130500
         CLC   FSPDSN,0(8)   Any conversions?                  @SC86299 05131000
         BE    *+8           No, ok                            @SC86299 05131500
          BAL  9,FSPTU       Yes, quit if user typed it        @SC86299 05132000
         OI    FL1,ROVR      Found a name                      @SC86299 05132500
         MVI   TRTBL+C'.',0  Restore table                     @SC86299 05133000
         MVI   TRTBL+C'(',0                                    @SC86299 05133500
         TM    FSPFLG,FFHDR  Parse for TAKE?                   @SC88043 05134000
         BNZ   RTRN0         No, fine                          @SC88043 05134500
         CLI   FSPCH1,C''''  Fully qualified?                  @SC88043 05135000
         BE    RTRN0         Yes, honor it                     @SC88043 05135500
         LA    1,44(8)       No, find end of name              @SC88043 05136000
         LR    14,1                                            @SC88043 05136500
         TRT   0(44,8),TRTBL Get ptr to end+1 in R1            @SC88043 05137000
         SR    14,1          Length remaining                  @SC88043 05137500
         CH    14,=H'5'                                        @SC88043 05138000
         BL    RTRN0         Too short anyway                  @SC88043 05138500
         S     1,F8                                            @SC88043 05139000
         CLC   0(8,1),DKERMINI Is it .KERMINI?                 @SC88113 05139500
         BE    RTRN0         Yes, that's ok                    @SC88043 05140000
         CLC   =C'.TAKE',3(1) Or is is .TAKE?                  @SC88043 05140500
         BE    RTRN0         That's ok too                     @SC88043 05141000
         MVC   8(5,1),=C'.TAKE' No, use default type           @SC88043 05141500
         B     RTRN0                                           @SC87034 05142000
*                                                                       05142500
FSPZ     LA    6,=C'$.$'     In case we must use default       @SC87338 05143000
         LA    7,3-1                                           @SC87338 05143500
         CLI   0(8),1                                          @SC86299 05144000
         BE    FSPCP2        Get default DSN 'prefix.$.$'      @SC87338 05144500
         BH    RTRN0         Don't insist                      @SC86299 05145000
         PTEXT '&NOFSPEC'                                      @SC86299 05145500
         B     FSPINV                                          @SC86299 05146000
FSPTU    TM    FSPFLG,FFHDR                                    @SC86299 05146500
         BOR   9             From other Kermit, accept it      @SC86299 05147000
FSPINV   MVI   TRTBL+C'.',0  Restore table                     @SC86299 05147500
         MVI   TRTBL+C'(',0                                    @SC86299 05148000
         LA    15,2                                            @SC86299 05148500
         B     FSPPTRS                                         @SC86295 05149000
*                                                                       05149500
FSPBFIL  LR    1,15          Length remaining                  @SC88070 05150000
         SR    15,15         Set up just to pad                @SC88070 05150500
FSPBPAD  ICM   15,8,BLANK                                      @SC88070 05151000
         MVCL  0,14          Copy with blank fill              @SC88070 05151500
         BR    2                                               @SC88070 05152000
*                                                                       05152500
FSPFDOT  LA    1,1(7)        End of string                     @SC88070 05153000
         LA    2,2           In case no breaks                 @SC86299 05153500
         SR    7,6                                             @SC86299 05154000
         EX    7,FSPTRT      Find break                        @SC86299 05154500
         AR    7,6           Restore ptr to last char          @SC86299 05155000
         BR    9                                               @SC88070 05155500
*                                                                       05156000
FSPH     PTEXT '&FMTFSPC&FSPCPRM'                              @SC91224 05156500
         CLI   FSPFLG,FFSND  SEND 1st?                         @SC89261 05157000
         BE    *+8           Yes, use whole message            @SC89261 05157500
          SH   4,=H'&FMTOPT' Chop off option part              @SC91224 05158000
         B     FSP0H                                           @SC86295 05158500
FSP2H    PTEXT '&FORFSPC'                                      @SC86295 05159000
FSP0H    LA    15,1                                            @SC86295 05159500
FSPPTRS  RETREG 3,4          Return msg ptrs                   @SC86295 05160000
FSPRET   RET   ,                                               @SC86295 05160500
*                                                                       05161000
* Non-parsing functions . . .                                           05161500
*                                                                       05162000
* Get unique filespec                                                   05162500
FSPWRN   LR    4,1           Save name ptr                     @SC86295 05163000
         TM    FSPFLG,FFENC                                    @SC86295 05163500
         BO    FSPENC        Encode name into buffer           @SC86295 05164000
         TM    FSPFLG,FFDSP                                    @SC86295 05164500
         BO    FSPDSP        Copy name into buffer for display @SC86295 05165000
         TM    FL4,NMOK      Already checked?                  @SC87012 05165500
         BO    RTRN0         Yes, ok                           @SC87012 05166000
         MVC   XFILE,0(4)    Save original name                @SC90033 05166500
* This routine checks to see if the old data set is a PDS.     @TS86001 05167000
* If so, it then allocates and opens the data set and does a   @TS86001 05167500
* FIND to determine if the member is present.                  @TS86001 05168000
         LA    5,10          Allowed retries (0-9)             @SC88125 05168500
         LA    7,C'0'        Extra character                   @BS86001 05169000
         MVC   FSPDSN,0(4)                                     @SC87015 05169500
         BAL   9,FSPTOPN                                       @SC87015 05170000
         USING FDBD,1                                          @SC87015 05170500
         CLI   FSPDSMB,C' '  Member specified?                 @SC87015 05171000
         BE    FSPNOPDS      No, be sure it isn't a PDS        @SC87015 05171500
         TM    FDBFLGS,PDSF  Yes, be sure it is                @SC87015 05172000
         BZ    RTRN1         Too bad                           @SC87015 05172500
         XC    FSPDSMB,FSPDSMB Signal DSORG=PO for allocation  @SC88119 05173000
         OPENF I,FSPDSN,FILFDB,PDSPTR,E=FSPDERM                @SC88049 05173500
         MVC   FSPDSMB,44(4) Copy requested member name        @SC87015 05174000
         LA    1,FSPDSMB+7   Last char of member               @SC87015 05174500
         TRT   FSPDSMB,TRTBL Find blank                        @SC87015 05175000
         LR    6,1           Tentative byte to modify          @SC86299 05175500
         BAL   3,FSPRMPT     Set up rechecking via R3          @SC88125 05176000
FSPTFND  L     1,PDSPTR                                        @SC87015 05176500
         FIND  (1),FSPDSMB,D Search for member name            @SC87015 05177000
         B     *+4(15)       Branch on return code             @TS86001 05177500
         B     0(9)          0  - member was found             @TS86001 05178000
         B     FSPNOKM       4  - member not found             @TS86001 05178500
         B     FSPDERR       8  - I/O error or lack of memory  @TS86001 05179000
FSPTOPN  OPENF T,FSPDSN,E=FSPNOKD No collision                 @SC87015 05179500
         BR    9                                               @SC87015 05180000
FSPNOPDS TM    FDBFLGS,PDSF  Be sure it isn't a PDS            @SC87015 05180500
         BO    FSPDERM       Too bad                           @SC88076 05181000
         LA    3,FSPTOPN     Just test DSN for existence       @SC87015 05181500
         MVI   TRTBL+C'.',1                                    @SC87015 05182000
         TRT   FSPDSN(9),TRTBL Find end of 1st index           @SC87015 05182500
         LR    6,1                                             @SC87015 05183000
         LA    1,8(6)        Last possible end of 2nd          @SC87015 05183500
         TRT   2(7,6),TRTBL                                    @SC87015 05184000
         MVI   TRTBL+C'.',0  Restore TRT                       @SC87015 05184500
         LR    6,1           Byte to modify                    @SC87015 05185000
         BZ    FSPRMPT       Index level was 8 bytes           @SC87015 05185500
         CLI   FSPDSN+43,C' ' Exactly 44 bytes already?        @SC88125 05186000
         BE    *+10          No, there's some room             @SC88125 05186500
          BCTR 6,0           Yes, can't shift name over        @SC88020 05187000
          B    FSPRMPT                                         @SC88020 05187500
         LA    1,FSPDSN                                        @SC87015 05188000
         MVC   1(43,1),0(4)  Shift name over one               @SC87015 05188500
         SR    6,1                                             @SC87015 05189000
         EX    6,FSPMVDS     And copy beginning back           @SC87015 05189500
         AR    6,1                                             @SC87015 05190000
FSPRMPT  OI    FL4,NMCHNG    Yes, remember collision occurred  @SC90033 05190500
         CLI   CLSNFL,C'O'   Old-fashioned WARNING ON?         @SC90033 05191000
         BNE   FSPSTA        No, concoct unique name           @SC90033 05191500
         TM    FSPFLG,FFGET  User typed it?                    @SC87015 05192000
         BO    FSPRMP2       Yes                               @TS86001 05192500
FSPSTA   STC   7,0(6)        Modify DSN                        @SC88125 05193000
         BALR  9,3           See if still a conflict           @SC88125 05193500
         LA    7,1(7)        Bump counter                      @BS86001 05194000
         BCT   5,FSPSTA                                        @BS86001 05194500
FSPDERR  CLOSF PDSPTR        Close the data set                @SC87015 05195000
FSPDERM  PTEXT '&FILCLSN'                                      @SC88049 05195500
         L     1,EMSGP       Explanatory message               @SC88049 05196000
         MVC   0(21,1),0(3)                                    @SC88049 05196500
         ST    4,EMSGL                                         @SC88049 05197000
         B     FSP0H         Return ptrs and rc=1              @SC88049 05197500
FSPMVDS  MVC   0(,1),0(4)                                      @SC88020 05198000
FSPNOKM  MVC   44(8,4),FSPDSMB                                 @SC87015 05198500
FSPNOKD  MVC   0(44,4),FSPDSN Copy name back                   @SC87015 05199000
FSPNOK   OI    FL4,NMOK                                        @SC87015 05199500
         CLOSF PDSPTR                                          @SC87015 05200000
         B     RTRN0                                           @SC87015 05200500
FSPRMP2  LA    7,CMD                                           @SC87015 05201000
         LA    0,FFDSP                                         @SC87015 05201500
         KCALL FSPEC,(4)     Format DSN for message            @SC87015 05202000
         PTEXT '&QQWRITE',AREG=0,LREG=1  Ask if ok             @SC92300 05202500
         LR    2,15                                            @SC92300 05203000
         LR    3,1                                             @SC92300 05203500
         MVCL  2,0                                             @SC92300 05204000
         SR    2,7                                             @SC92300 05204500
         RTEXT (7),PROMPT=((7),(2))                            @SC92300 05205000
         LTR   0,0           Length of reply                   @SC87015 05205500
         BNP   FSPDERR       If zero give up                   @SC88076 05206000
         TR    0(9,7),UPCASE Upcase 1st chars of reply         @SC87015 05206500
         CLC   =C'&AAAAAOK',0(7)   Was reply "ok"?             @SC88076 05207000
         BNE   FSPDERR       No, abort operation               @SC88076 05207500
         B     FSPNOK                                          @SC87015 05208000
*                                                                       05208500
* Encode name at (R1) into (R7) buffer (in ASCII), possibly with        05209000
*  substitution from JFSPEC, but disable subsequent subst.              05209500
*  Return updated ptr in R15                                            05210000
FSPENC   LA    1,JFSPEC      Complex string?                   @SC86224 05210500
         BAL   14,PAKFOR                                       @SC86224 05211000
         BNZ   FSPECPZ       Yes, name overridden              @SC86299 05211500
         CLI   44(4),C' '    Member?                           @SC86299 05212000
         BE    FSPENT        No, get name and type from DSN    @SC86299 05212500
         MVC   0(8,7),44(4)  Yes, use member name              @SC88070 05213000
         LA    1,8(7)        Possible end                      @SC88070 05213500
         TRT   0(8,7),TRTBL  Find end of name                  @SC88070 05214000
         LR    5,1           Save                              @SC88070 05214500
         BAL   9,FSPESCNS    Find last DSN qualifier           @SC88070 05215000
         MVI   0(5),C'.'     Join to member name               @SC88070 05215500
         MVC   1(8,5),0(3)   Copy the qualifier                @SC88070 05216000
         SR    5,7           Length of member name             @SC88070 05216500
         LA    1,1(5,1)      Adjust effective end of DSN       @SC88070 05217000
         B     FSPENTR       Done, convert to ASCII            @SC88070 05217500
FSPENT   BAL   9,FSPESCNS    Find last qualifier               @SC88070 05218000
         BCTR  3,0           Move back to separating dot       @SC88070 05218500
         BAL   9,FSPESCN     Back to previous qualifier        @SC88070 05219000
         MVC   0(17,7),0(3)  At most 2 tokens + dot            @SC86299 05219500
         B     FSPENTR       Done, convert to ASCII            @SC88070 05220000
*                                                                       05220500
FSPESCNS LA    1,44(4)                                         @SC86299 05221000
         TRT   0(44,4),TRTBL Find end of DSN                   @SC86299 05221500
         LR    3,1                                             @SC92147 05222000
         BCTR  3,0           Check to see if relative GDG      @SC92147 05222500
         CLI   0(3),C')'                                       @SC92147 05223000
         BNE   FSPESCN2      No, that's fine                   @SC92147 05223500
FSPESCNL BCTR  3,0           Look back for opening parenthesis @SC92147 05224000
         CR    3,4           Past beginning of DSN?            @SC92147 05224500
         BL    FSPESCN2      Yes, must be weird                @SC92147 05225000
         CLI   0(3),C'('                                       @SC92147 05225500
         BNE   FSPESCNL      Keep looking                      @SC92147 05226000
         LR    1,3           Found it, lop off relative number @SC92147 05226500
FSPESCN2 DS    0H                                              @SC92147 05227000
         LR    3,1                                             @SC86299 05227500
FSPESCN  BCTR  3,0           Scan back for dots                @SC86299 05228000
         CR    3,4           Past beginning of DSN?            @SC86299 05228500
         BL    FSPECP        Yes, use all                      @SC86299 05229000
         CLI   0(3),C'.'     No, found dot?                    @SC86299 05229500
         BNE   FSPESCN       No, keep looking                  @SC86299 05230000
FSPECP   LA    3,1(3)        Stuff to copy                     @SC86299 05230500
         BR    9                                               @SC88070 05231000
FSPENTR  DS    0H            Translate and adjust ptr          @SC88070 05231500
         TR    0(17,7),ETOAD                                   @SC89301 05232000
         SR    1,3           Length of stuff copied            @SC86299 05232500
         AR    7,1           Advance ptr                       @SC86299 05233000
FSPECPZ  MVI   JFSPEC,0      Turn off string                   @SC86299 05233500
FSPENR   LR    15,7          Save ptr                          @SC86295 05234000
         B     FSPRET                                          @SC86295 05234500
*                                                                       05235000
* Copy name at (R1) into (R7) buffer in display form                    05235500
*  Return updated ptr in R15                                            05236000
FSPDSP   LR    14,7          Copy output ptr                   @SC86299 05236500
         LA    2,DEST        Check if prefix exists            @SC86299 05237000
         LH    3,DESTL                                         @SC86299 05237500
         LTR   3,3                                             @SC86299 05238000
         BZ    FSPDCP        No prefix, skip quotes            @SC86299 05238500
         LA    1,1(3)        One extra for dot                 @SC86299 05239000
         ICM   3,8,LOCASE+C'.'                                 @SC86299 05239500
         CLCL  0,2           Does it match prefix?             @SC86299 05240000
         BE    FSPDCP        Yes, chop it off                  @SC86299 05240500
         LR    0,4           No, use quotes for whole name     @SC86299 05241000
         MVI   0(14),C''''                                     @SC86299 05241500
         LA    14,1(14)                                        @SC86299 05242000
FSPDCP   LA    1,44(4)                                         @SC86299 05242500
         TRT   0(44,4),TRTBL Find end of name                  @SC86299 05243000
         SR    1,0           Length                            @SC86299 05243500
         LR    15,1                                            @SC86299 05244000
         MVCL  14,0          Copy name to buffer               @SC86299 05244500
         CLI   44(4),C' '    Member name, too?                 @SC86299 05245000
         BE    FSPDCY        No, done                          @SC86299 05245500
         MVI   0(14),C'('    Yes, insert in parens             @SC86299 05246000
         MVC   1(8,14),44(4) Copy name to buffer               @SC86299 05246500
         LA    1,9(14)                                         @SC86299 05247000
         TRT   1(8,14),TRTBL Find end of member name           @SC86299 05247500
         MVI   0(1),C')'     Close member name                 @SC86299 05248000
         LA    14,1(1)                                         @SC86299 05248500
FSPDCY   LR    15,14         Return output ptr                 @SC86299 05249000
         CLI   0(7),C''''    Need close quote?                 @SC86299 05249500
         BNE   *+12          No, that's all                    @SC86299 05250000
         MVI   0(15),C''''   Yes, do it                        @SC86299 05250500
         LA    15,1(15)                                        @SC86299 05251000
         B     FSPRET                                          @SC86299 05251500
*                                                                       05252000
* Insert '#' if token would otherwise begin with a digit       @SC86299 05252500
FSPANAT  LA    5,8           Tentative token length            @SC86299 05253000
         CLI   0(6),C'0'     Digit?                            @SC86299 05253500
         BLR   2             No, ok                            @SC86299 05254000
         CLI   0(6),C'9'     Really?                           @SC86299 05254500
         BHR   2             No, but illegal anyway            @SC86299 05255000
         BAL   9,FSPTU       Bad form                          @SC86299 05255500
         LA    14,LOCASE+C'#'                                  @SC86299 05256000
         LA    1,1                                             @SC86299 05256500
         MVCL  0,14          Copy '#'                          @SC86299 05257000
         BCTR  5,0           Now allow only 7                  @SC86299 05257500
         BR    2                                               @SC86299 05258000
*                                                                       05258500
FSPTRSL  DC    XL256'00'     For finding a '/'                 @SC88342 05259000
         ORG   FSPTRSL+C'/'                                    @SC88342 05259500
         DC    X'1'                                            @SC88342 05260000
         ORG   ,                                               @SC88342 05260500
*                                                                       05261000
* Valid DSN characters                                         @SC86299 05261500
FSPTAB   DC    64C'#',C' '           space                     @SC86299 05262000
         DC    10C'#',C'.'           dot                       @SC86299 05262500
         DC    15C'#',C'$*'          dollar sign, asterisk     @SC86299 05263000
         DC    03C'#',C'-'           hyphen                    @SC86299 05263500
         DC    26C'#',C'#@'          pound sign, at sign       @SC86299 05264000
         DC    04C'#',C'ABCDEFGHI'   a-i                       @SC86299 05264500
         DC    07C'#',C'JKLMNOPQR'   j-r                       @SC86299 05265000
         DC    08C'#',C'STUVWXYZ'    s-z                       @SC86299 05265500
         DC    22C'#',C'{ABCDEFGHI'  {,A-I                     @SC86299 05266000
         DC    07C'#',C'JKLMNOPQR'   J-R                       @SC86299 05266500
         DC    08C'#',C'STUVWXYZ'    S-Z                       @SC86299 05267000
         DC    06C'#',C'0123456789'  0-9                       @SC86299 05267500
         DC    06C'#'                                          @SC86299 05268000
* Valid GDG name characters                                    @SC92147 05268500
FSPTBGDG DC    64C'#',C' '           space                     @SC92147 05269000
         DC    10C'#',C'.'           dot                       @SC92147 05269500
         DC    01C'#',C'(+'          paren, plus (for GDGs)    @GA92147 05270000
         DC    12C'#',C'$*)'         dollar, asterisk, paren   @GA92147 05270500
         DC    02C'#',C'-'           hyphen                    @GA92147 05271000
         DC    26C'#',C'#@'          pound sign, at sign       @SC92147 05271500
         DC    04C'#',C'ABCDEFGHI'   a-i                       @SC92147 05272000
         DC    07C'#',C'JKLMNOPQR'   j-r                       @SC92147 05272500
         DC    08C'#',C'STUVWXYZ'    s-z                       @SC92147 05273000
         DC    22C'#',C'{ABCDEFGHI'  {,A-I                     @SC92147 05273500
         DC    07C'#',C'JKLMNOPQR'   J-R                       @SC92147 05274000
         DC    08C'#',C'STUVWXYZ'    S-Z                       @SC92147 05274500
         DC    06C'#',C'0123456789'  0-9                       @SC92147 05275000
         DC    06C'#'                                          @SC92147 05275500
* Valid member name characters                                 @SC86299 05276000
FSPMTAB  DC    75AL1(*-FSPMTAB),C'#' dot                       @SC86299 05276500
         DC    20AL1(*-FSPMTAB),C'#' hyphen                    @SC88096 05277000
         DC    95AL1(*-FSPMTAB),C'#' {                         @SC86299 05277500
         DC    63AL1(*-FSPMTAB)                                @SC86299 05278000
* Replace asterisks if not a send request                      @SC88096 05278500
FSPSTAB  DC    92AL1(*-FSPSTAB),C'#' asterisk                  @SC88096 05279000
         DC    163AL1(*-FSPSTAB)                               @SC88096 05279500
         LOCALS ,                                              @SC86295 05280000
PDSPTR   DS    A             Ticket for PDS testing            @SC87015 05280500
FSPDSN   DS    0CL60         Temp for name field               @SC88342 05281000
PDSNM    DS    CL44          Test DSN                          @SC87015 05281500
FSPDSMB  DS    CL8           Test member                       @SC87015 05282000
FSPPASS  DS    CL8           Password                          @SC88342 05282500
FSPFLG   DS    X             Filespec flags                    @SC86295 05283000
FSPCH1   DS    C             Saved 1st char of spec.           @SC88043 05283500
FSPEC    EXIT                                                  @SC86295 05284000
         TITLE 'KHELP routine - perform HELP command'                   05284500
* Handle HELP command, rest of string given by SCANPTR.                 05285000
* On entry, R6->help command string                                     05285500
KHELP    ENTER ,                                               @SC86355 05286000
         LR    8,6           Save ptr to command               @SC88043 05286500
         NTOKN N=KHLI        See if subcommand given           @SC86355 05287000
         L     1,=A(USNCMD)  Command table                     @SC87117 05287500
         SCAN  (1),KHLF,NODISP                                 @SC86355 05288000
         WTEXT '&BADSBCM'   Not found                          @SC86355 05288500
         RET   ,                                               @SC86355 05289000
KHLF     CLM   7,8,F0        Just '?'                          @SC86355 05289500
         BE    RTRN          Yes, done                         @SC86355 05290000
KHLI     LM    6,7,SCANPTR   Rest of string                    @SC88043 05290500
         AR    6,7           Ptr to end                        @SC88043 05291000
         LR    0,8           Start of command                  @SC88043 05291500
         SR    6,0           Total length                      @SC88043 05292000
         NI    FL4,255-UCMD                                    @SC88043 05292500
         KCALL SUPFNC,3      Do it                             @SC86355 05293000
         RET   ,                                               @SC86355 05293500
         LOCALS ,                                                       05294000
KHELP    EXIT  ,                                               @SC87007 05294500
         TITLE 'SUPFNC Routine - various supervisor functions' @SC86158 05295000
SUPFNC   ENTER                                                 @SC86295 05295500
*  On entry, R1 = operation code, R0 = possible ptr            @SC86158 05296000
* Exit: R15 set (0 => ok, <0 => illegal cmd, >0 => depends)             05296500
*       ERRNUM set appropriately (R1=1,3,4) or unchanged (2,5-11)       05297000
* 1 -> Start typeout interception.  N.B.  &MAXLR >> 2048 for this       05297500
* 2 -> Clean up afterwards and stop interception                        05298000
* 3 -> Execute host command with or without interception                05298500
*      If UCMD set, SCANPTR gives text, else R0->text,R6=len            05299000
* 4 -> (not used)                                                       05299500
* 5 -> Stop interception if going                                       05300000
* 6 -> Retrieve original cmd parm string into CBUF (R15=1 if null)      05300500
* 7 -> Test for stacked lines, return number in R15                     05301000
* 8 -> Log off (must return to TMP)                                     05301500
* 9 -> Wait specified time                                              05302000
* 10-> Return clock time in R15 (centisec)                              05302500
* 11-> Setup up new prompt string at (R0)                               05303000
         STC   1,SFCFLGS                                       @SC92342 05303500
         AR    1,1                                             @SC92342 05304000
         LH    1,SFCT-2(1)                                     @SC92342 05304500
         B     SFCT(1)                                         @SC92342 05305000
SFCT     DC    Y(ICPBEG-SFCT,ICPFIN-SFCT,ICPHST-SFCT)  1-3     @SC92342 05305500
         DC    Y(ICPCMIL-SFCT,ICPRST-SFCT,SFCLIN-SFCT) 4-6     @SC92342 05306000
         DC    Y(SFCSTK-SFCT,SFCKIL-SFCT,SFCWT-SFCT)   7-9     @SC92342 05306500
         DC    Y(SFCCLK-SFCT,SFCRET-SFCT,SFCRET-SFCT) 10-12    @SC92342 05307000
*                                                                       05307500
* Start interception, initialize ptrs                          @SC86158 05308000
ICPBEG   DS    0H                                              @SC92342 05308500
         MVI   ERRNUM,ERRNOE OK                                @SC86158 05309000
         L     1,WBUF        Output buffer                     @SC90264 05309500
         LA    0,2048(,1)    Skip over some, to be safe        @SC90264 05310000
         A     1,F64KP       End of buffer                     @SC90264 05310500
         LR    15,0                                            @SC86158 05311000
         STM   15,0,TXTPTR   Save                              @SC86158 05311500
         STM   0,1,SVCOPTR                                     @SC86158 05312000
         SR    1,0           Get length                        @SC86158 05312500
         L     15,=X'15000000'                                 @SC86158 05313000
         MVCL  0,14          Fill with NL (X'15')              @SC86158 05313500
* ------------ determine if SVC screen is possible             @SC88026 05314000
* -            if so, then do it                               @SC88026 05314500
         B     ICPSTK                                          @SC88026 05315000
         MVI   ICPFL,2       Now intercepting subtask SVC's    @SC88026 05315500
SFCRET   DS    0H                                              @SC92342 05316000
         B     RTRN0                                           @SC88026 05316500
*          Can't screen SVC's, create a STACK element          @SC88026 05317000
ICPSTK   OPENF T,STKDSN,E=ICPST2 See if any previous output    @SC88026 05317500
         USING FDBD,1        Yes, clear it                     @SC88106 05318000
         SR    3,3                                             @SC88106 05318500
         LA    4,FDBDEVT-2   Create volume list (n,type,vol)   @SC88106 05319000
         MVC   0(2,4),F1+2   Just one volume                   @SC88106 05319500
         STM   2,4,SFCDEL+4  Simulate CAMLST                   @SC88106 05320000
         MVI   SFCDEL,X'0C'  Code for UNCAT                    @SC88106 05320500
         CATALOG SFCDEL                                        @SC88106 05321000
         MVI   SFCDEL,X'41'  Codes for SCRATCH                 @SC88106 05321500
         MVI   SFCDEL+2,X'40'                                  @SC88106 05322000
         SCRATCH SFCDEL                                        @SC88106 05322500
         DROP  1                                               @SC88106 05323000
ICPST2   LA    1,STKDSN      Get ptrs to DYNALC arguments      @SC88026 05323500
         LA    2,STKDD                                         @SC88026 05324000
         LA    3,FILUNT                                        @SC88026 05324500
         LA    4,FILVOL                                        @SC88026 05325000
         LA    5,=X'42'      NEW,CATLG                         @SC88026 05325500
         LA    6,FILTRKAL                                      @SC88026 05326000
         LA    7,STKDRC                                        @SC88026 05326500
         STM   1,7,STKDYN    Set up calling sequence           @SC88026 05327000
         OI    STKDYN+24,X'80'  No buffer ptr                  @SC88119 05327500
         KCALL DYNALC,STKDYN,EXT Allocate output file          @SC88026 05328000
         MVI   CPECB,0       Clear ECB (for neatness)          @SC88076 05328500
         STACK MF=(E,IOPLAREA),PARM=STKA  Create STACK elt.    @SC88026 05329000
         MVI   ICPFL,1       Now intercepting                  @SC87020 05329500
         B     RTRN0                                           @SC86295 05330000
* Clean up after interception                                  @SC86295 05330500
ICPFIN   DS    0H                                              @SC92342 05331000
         L     5,SVCOPTR     End of text                       @SC86158 05331500
         ST    5,TXTPTR+4    Save                              @SC86158 05332000
ICPRST   CLI   ICPFL,2       Were we intercepting SVC's?       @SC92342 05332500
         BNE   ICPFINST      No, see if STACK                  @SC88026 05333000
*---------- stop snagging SVC's                                @SC88026 05333500
         B     ICPRST1       Ok                                @SC88026 05334000
ICPFINST CLI   ICPFL,1       Were we intercepting via STACK?   @SC88026 05334500
         BNE   ICPRST1       No, fine                          @SC88026 05335000
         MVI   CPECB,0       Clear ECB (for neatness)          @SC88076 05335500
         STACK MF=(E,IOPLAREA),PARM=STKZ Yes, remove STACK elt.@SC88026 05336000
         CLI   SFCFLGS,5     Stop intercepting without cleanup?@SC92342 05336500
         BE    ICPRST1       Yes, quit now                     @SC92342 05337000
*          Copy output to buffer                               @SC88026 05337500
         OPENF I,STKDSN,FILFDB,STKTKT,E=ICPRST1                @SC88026 05338000
         L     3,STKTKT      Ptr to FAB                        @SC88106 05338500
         USING FABD,3                                          @SC88106 05339000
         L     5,TXTPTR+4    Buffer ptr                        @SC88026 05339500
ICPSTLP  READF STKTKT,BUFFER=(5),BSIZE=255,E=ICPSTZ            @SC88026 05340000
         TM    FDBFLGS,FABRECCC Carriage control?              @SC88246 05340500
         BZ    *+8           No, that's fine                   @SC88106 05341000
         MVI   0(5),C' '     Yes, blank it out                 @SC88106 05341500
         AR    5,0           Space over data                   @SC88026 05342000
         LA    5,1(5)        Leave one X'15'                   @SC88026 05342500
         B     ICPSTLP       And read more                     @SC88026 05343000
ICPSTZ   CLOSF STKTKT        Done                              @SC88026 05343500
         ST    5,TXTPTR+4    New end of output                 @SC88026 05344000
         DROP  3                                               @SC88106 05344500
ICPRST1  MVI   ICPFL,0                                         @SC87020 05345000
         B     RTRN0                                                    05345500
* Execute TSO command at (R0) with length (R6), unless UCMD set,        05346000
*  in which case string given by SCANPTR                                05346500
ICPHST   DS    0H                                              @SC92342 05347000
         TM    FL4,UCMD      User command?                     @SC86295 05347500
         BO    ICPCM0        Yes, scan already set up          @SC86355 05348000
ICPCMI   ST    0,ADR         Set scan string ptrs              @SC86355 05348500
         ST    6,LEN                                           @SC86355 05349000
ICPCM0   LM    0,1,SCANPTR   Get length and adr                @SC87034 05349500
         LTR   6,0           Copy length                       @SC87034 05350000
         BNP   ICPCMIL       No good                           @SC87034 05350500
         BCTR  6,0                                             @SC87034 05351000
         LA    5,0(6,1)      Point to last character in string @GH89057 05351500
         NTOKN N=ICPCMIL     No good                           @SC86355 05352000
         MVI   SFCBUF+4,C' ' Initialize command buffer ...     @GH89057 05352500
         MVC   SFCBUF+4+1(256-1),SFCBUF+4 ... to blanks        @GH89057 05353000
         SR    5,6           Compute decremented length ...    @GH89057 05353500
         MVC   SFCBUF+4(*-*),0(6)  Copy text to command buffer @GH89057 05354000
         EX    5,*-6         ... and nothing else              @GH89057 05354500
         LR    5,6           Start of command name             @SC86355 05355000
         EX    7,TRUPCAS     Capitalize command name           @GH89112 05355500
         LA    7,1(7)        Length of name                    @SC86355 05356000
         MVC   EXCFLG,0(6)   Copy 1st character (% if implicit)@SC89073 05356500
         CLI   0(6),C'%'     Is it implicit EXEC?              @SC89073 05357000
         BNE   SFCCM1        No                                @SC89073 05357500
          BCT  7,*+8         Yes, chop off '%'                 @SC89073 05358000
           B   ICPCMIL       Oops, name was just '%'           @SC89073 05358500
          LA   6,1(6)                                          @SC89073 05359000
SFCCM1   DS    0H                                              @SC89073 05359500
         ICM   7,8,BLANK     Set up for padding                @SC86355 05360000
         L     2,ORGR1       Get address of kermit CPPL        @TS86001 05360500
         MVC   ATCHCPPL(16),0(2)  initialize attach CPPL       @TS86001 05361000
         LA    2,ATCHCPPL    Get address of attach CPPL        @TS86001 05361500
         USING CPPL,2        Make attach CPPL addressable      @TS86001 05362000
         LA    1,SFCBUF                                        @SC86355 05362500
         ST    1,CPPLCBUF    Put the command buffer into CPPL  @TS86001 05363000
         L     3,CPPLECT     Get the ECT address               @TS86001 05363500
         USING ECT,3         Make it addressable               @TS86001 05364000
         MVC   ECTPCMD,ORGPCMD Initialize, in case sub HELP    @SC89052 05364500
         LA    14,ECTSCMD                                      @SC86355 05365000
         LA    15,L'ECTSCMD                                    @SC86355 05365500
         MVCL  14,6          Copy to subcommand field          @SC86355 05366000
         CLM   7,7,F0                                          @SC88054 05366500
         BNE   ICPCMIL       Command name longer than 8        @SC88054 05367000
         CLI   ECTSCMD,C'H'  Is it HELP?                       @SC88043 05367500
         BNE   *+12          It's not subcommand help          @SC88043 05368000
         TM    FL4,UCMD      It might be (if generated)        @SC88043 05368500
         BZ    *+10          ... yes, HELP as subcommand       @SC88043 05369000
          MVC  ECTPCMD,ECTSCMD This is really a command        @SC88026 05369500
         LR    4,6           Default parameter ptr             @SC86355 05370000
         LR    8,6           Default end of string             @SC86355 05370500
         NTOKN N=SFCNPRM     Find parameters, if any           @SC86355 05371000
         L     8,ADR                                           @SC86355 05371500
         A     8,LEN         True end of string                @SC86355 05372000
         LR    4,6           Start of parameters               @SC86355 05372500
SFCNPRM  SR    4,5           Get offset to parameters          @SC86355 05373000
         STH   4,SFCBUF+2    Save in command buffer            @SC86355 05373500
         MVC   SFCBLDL(4),=H'1,60' Set BLDL count & length     @SC90149 05374000
         SR    8,5           Get total length                  @SC86355 05374500
         LA    8,4(8)        Plus prefix info                  @SC88022 05375000
         STH   8,SFCBUF      Save in command buffer            @SC86355 05375500
         CLI   EXCFLG,C'%'   Check for explicit implicit clist @SC89073 05376000
         BNE   SFCLOCCP      Try for a CP first                @GH89056 05376500
SFCEXEC  XC    SFCBUF+2(2),SFCBUF+2   Indicate implicit clist  @GH89056 05377000
         CLC   ECTSCMD,=CL8'EXEC'     (Avoid looping)          @GH89056 05377500
         BE    ICPCMIL       This shouldn't happen!            @GH89056 05378000
         MVC   SFCBLDL+4(8),ECTSCMD Copy into BLDL list        @GH89050 05378500
         ICM   1,15,SYSPROC  Ptr to CLIST library DCB          @SC89073 05379000
         BZ    ICPCMIL       No such library                   @SC89073 05379500
         BLDL  (1),SFCBLDL                                     @SC89073 05380000
         LTR   15,15                                           @SC89073 05380500
         BNZ   ICPCMIL       Couldn't find the CLIST           @SC89073 05381000
         MVC   ECTPCMD,=CL8'EXEC'  Ok, locate EXEC             @GH89056 05381500
         MVC   ECTSCMD,=CL8'EXEC'                              @GH89056 05382000
SFCLOCCP DS    0H            Come here to try again            @GH89056 05382500
         MVC   SFCBLDL+4(8),ECTSCMD Copy into BLDL list        @GH89050 05383000
         BLDL  0,SFCBLDL     Check for command to ATTACH       @GH89050 05383500
         LTR   15,15         Does command exist?               @GH89050 05384000
         BNZ   SFCEXEC       No: assume a CLIST                @GH89056 05384500
         STAX  SFCATTN,DEFER=NO,REPLACE=NO,MF=(E,SFCSTBL),     @SC88118+05385000
               USADDR=ATCHECB  In case subtask has no STAX     @SC88118 05385500
         ATTACH ECB=ATCHECB,DE=SFCBLDL+4,SHSPV=78,SZERO=NO,            +05386000
               MF=(E,(2)),SF=(E,ATCBLK)                        @SC86355 05386500
         LTR   15,15         Was attach successful?            @TS86001 05387000
         BZ    *+12          Ok                                @SC88118 05387500
          BAL  14,SFCATCLN   Restore everything                @SC88118 05388000
          B    ICPCMIL       No, must not exist                @SC88026 05388500
         ST    1,ATCHTCB     Save TCB address                  @TS86001 05389000
         WAIT  ECB=ATCHECB   Wait for subtask to finish        @TS86001 05389500
         LA    1,ATCTXP      Set up req blk ptr to text list   @SC88087 05390000
         LA    4,ATCTXT      Text list follows RB              @SC88087 05390500
         MVC   0(6,4),=H'1,1,4' Text unit type 1: TCB adr      @SC88087 05391000
         LA    5,ATCDRB      RB ptr follows text list          @SC88087 05391500
         ST    1,ATCDRB+8    Fill in RB                        @SC88087 05392000
         STM   4,5,ATCTXP    Fill in text list + RB ptr        @SC88087 05392500
         MVI   ATCTXP,X'80'  Only item in text list            @SC88087 05393000
         MVC   0(2,5),=AL1(20,5) Finish up RB: length, type    @SC88087 05393500
         MVI   ATCRBP,X'80'                                    @SC88087 05394000
         LA    1,ATCRBP                                        @SC88087 05394500
         SVC   99            DYNALLOC to free allocations      @SC88087 05395000
         DETACH ATCHTCB      Detach the subtask                @TS86001 05395500
         BAL   14,SFCATCLN   Restore everything                @SC88118 05396000
         SR    4,4                                             @SC86355 05396500
         ICM   4,7,ATCHECB+1 Get return code                   @SC86355 05397000
* Issue return code msg if needed                              @SC86295 05397500
         BZ    SFCZRC        RC=0                              @SC86158 05398000
         LR    15,6                                            @SC90264 05398500
         TM    FL4,UCMD      User cmd?                         @SC86316 05399000
         BZ    RTRN          No. No message, just rc in R15    @SC90264 05399500
         MVC   CMD(2),=C'R(' Set up message                    @SC86209 05400000
         LA    15,CMD+2                                        @SC86209 05400500
         BAL   2,EDDEC       Edit RC into msg                  @SC86295 05401000
         MVI   0(15),C')'    Format is R(rc)                   @SC86209 05401500
         LA    0,1(15)                                         @SC86268 05402000
         LA    1,CMD         Start of edited string            @SC86209 05402500
         SR    0,1           Length                            @SC86268 05403000
         WTEXT (1),(0)                                         @SC86268 05403500
SFCZRC   LR    15,4                                            @SC86295 05404000
         MVI   ERRNUM,ERRNOE No errors                         @SC86295 05404500
         B     RTRN                                            @SC86295 05405000
ICPCMIL  MVI   ERRNUM,ERRSYS Illegal system command            @SC86295 05405500
         B     RTRNM1                                          @SC86295 05406000
*                                                                       05406500
SFCATCLN STAX  ,             Restore after ATTACH (saves R14)  @SC88118 05407000
         BR    14                                              @SC88118 05407500
*                                                                       05408000
SFCATTN  STM   14,12,12(13)  Save regs                         @SC88118 05408500
         LR    3,15                                            @SC88118 05409000
         USING SFCATTN,3                                       @SC88118 05409500
         L     4,8(1)        Ptr to ECB                        @SC88118 05410000
         LA    2,4(4)        Ptr to TCB                        @SC88118 05410500
         TM    0(4),X'40'    Already finished?                 @SC88118 05411000
         BO    SFCATTNR      Yes, we just missed it            @SC88118 05411500
         STATUS STOP,TCB=(2) Suppress execution                @SC88118 05412000
         POST  (4)           No, so we just drop it            @SC88118 05412500
SFCATTNR LM    14,12,12(13)  Restore regs                      @SC88118 05413000
         BR    14                                              @SC88118 05413500
         DROP  3                                               @SC88118 05414000
*                                                                       05414500
SFCLIN   DS    0H                                              @SC92342 05415000
* Retrieve original command line arguments, if any             @SC86295 05415500
*   Return code =0 if yes, =1 if no                            @SC86295 05416000
*   Leave string in CBUF buffer (up to 256), length in CLEN    @SC86295 05416500
         L     2,ORGR1       Original R1                       @SC86355 05417000
         L     3,CPPLCBUF    CBUF ptr                          @SC91121 05417500
         LH    5,0(,3)       PARM length                       @SC91121 05418000
         AR    5,3           End of data                       @SC91121 05418500
         LH    4,2(,3)       Parm offset                       @SC91121 05419000
         LA    4,4(4,3)      Start of data                     @SC91121 05419500
         SR    5,4           Length of data                    @SC91121 05420000
         BNP   RTRN1         Nothing there                     @SC86299 05420500
         LA    6,7+4(,5)     Add 4 for overhead and round      @SC91121 05421000
         N     6,=F'-7'      ... to doubleword                 @SC91121 05421500
         GETMAIN R,LV=(6),SP=1                                 @SC91121 05422000
         ST    1,APGPB+GTPBIBUF-GTPB  Save ptr for GETLIN      @SC91121 05422500
         STH   6,0(,1)       Set up new block                  @SC91121 05423000
         SR    6,5           Deduct data length                @SC91121 05423500
         S     6,F4          and overhead                      @SC91121 05424000
         STH   6,2(,1)       The rest is the new offset        @SC91121 05424500
         LA    0,4(6,1)      New starting point for data       @SC91121 05425000
         LR    1,5                                             @SC91121 05425500
         MVCL  0,4           Fill up new block                 @SC91121 05426000
         B     RTRN0                                           @SC86295 05426500
*                                                                       05427000
* Test for stacked commands                                    @SC86295 05427500
*   return code = number of stacked lines                      @SC86295 05428000
SFCSTK   DS    0H                                              @SC92342 05428500
         LA    2,APGPB                                         @NW86330 05429000
         USING GTPB,2                                          @NW86330 05429500
         ICM   1,15,GTPBIBUF Ptr to input buffer, if any       @SC87015 05430000
         BNZ   RTRN1         Yes, line is stacked              @SC87015 05430500
         SR    0,0                                             @SC91205 05431000
         IC    0,ERRNUM      Get current status code           @SC91205 05431500
         C     0,F1                                            @SC91205 05432000
         BH    *+6                                             @SC91205 05432500
          SR   0,0           Treat 1 as if 0                   @SC91205 05433000
         L     1,ORGR1       Get ptr to CPPL                   @SC91205 05433500
         USING CPPL,1                                          @SC91205 05434000
         L     1,CPPLECT     Get ECT ptr                       @SC91205 05434500
         USING ECT,1                                           @SC91205 05435000
         STCM  0,7,ECTRTCD   Set CC for any CLIST running      @SC91205 05435500
         DROP  1                                               @SC91205 05436000
         MVI   CPECB,0       Clear ECB                         @SC88119 05436500
         L     15,GETLINAD   Entry point for GETLINE routine   @NW86330 05437000
         GETLINE PARM=(2),TERMGET=(EDIT,NOWAIT),ENTRY=(15),            +05437500
               MF=(E,IOPLAREA)                                 @SC87015 05438000
         C     15,F4         Check return code                 @SC87015 05438500
         BNH   RTRN1         Got one now                       @SC88095 05439000
         MVC   GTPBIBUF,F0   Clear it, just in case            @SC88095 05439500
         B     RTRN0         Nothing stacked                   @SC88095 05440000
         DROP  2                                               @SC90264 05440500
*                                                                       05441000
* Log out                                                      @SC86295 05441500
SFCKIL   DS    0H                                              @SC92342 05442000
         LR    3,13                                            @SC88026 05442500
         L     3,4(3)        Look back through save areas      @SC88026 05443000
         CLC   =A(USNTRF),16(3) Find main loop                 @SC89215 05443500
         BNE   *-10                                            @SC88026 05444000
         L     3,8(3)        Ptr to main save area             @SC88026 05444500
         OI    KFLG-USNTRFSV(3),CMDC Set flag to quit          @SC88026 05445000
         PTEXT 'LOGOFF',AREG=0,LREG=6                          @SC88026 05445500
         NI    FL4,255-UCMD  Internal                          @SC86355 05446000
         B     ICPCMI        Do it                             @SC86355 05446500
*                                                                       05447000
* Wait specified time in R0 (sec)                                       05447500
SFCWT    DS    0H                                              @SC92342 05448000
         MH    0,=H'100'     Convert to centisec               @SC86299 05448500
         ST    0,TMPDW                                         @SC86299 05449000
        STIMER WAIT,BINTVL=TMPDW                               @SC86299 05449500
         B     RTRN0                                           @SC86295 05450000
*                                                                       05450500
* Return time in centisec in R15                                        05451000
SFCCLK   DS    0H                                              @SC92342 05451500
         STCK  TMPDW         Store TOD clock                   @SC86295 05452000
         LM    14,15,TMPDW                                     @SC86295 05452500
         SLDL  14,8          Take mod 204 days                 @SC86295 05453000
         SRDL  14,20         Get in microsec                   @SC86295 05453500
         D     14,=F'10000'  Get in centisec                   @SC86295 05454000
         B     RTRN                                            @SC86295 05454500
*                                                                       05455000
         TITLE 'SVC interceptor,  executed in system protect key'       05455500
         USING ICPTYP,15                                       @SC86283 05456000
ICPTYP   STM   12,14,SVCSV1  Save regs                         @SC86283 05456500
         LR    13,15         Addressability                    @SC87020 05457000
         DROP  15                                                       05457500
         USING ICPTYP,13                                       @SC87020 05458000
ICPTGO   LM    14,15,SVCOPTR Output ptrs                       @SC86158 05458500
         SR    15,14         Length left                       @SC86158 05459000
         LA    12,255        Limit                             @SC86158 05459500
         CLR   12,0          Buffer length                     @SC87020 05460000
         BNH   *+8           Too big                           @SC86158 05460500
         LR    12,0          Ok, use it                        @SC87020 05461000
         LTR   12,12                                           @SC86158 05461500
         BNP   ICPTRET                                         @SC86283 05462000
         CR    12,15         Enough room?                      @SC86283 05462500
         BH    ICPTRET       No                                @SC86283 05463000
         BCTR  12,0          Set up for mvc                    @SC86158 05463500
         EX    12,SVCCOPY    Move to WBUF                      @SC86158 05464000
         LA    14,2(12,14)   New end                           @SC86158 05464500
         ST    14,SVCOPTR                                      @SC86158 05465000
ICPTRET  SR    15,15         Success                           @SC86283 05465500
         LM    12,14,SVCSV1  Restore regs                      @SC86283 05466000
         BR    14            Return                            @SC86283 05466500
SVCCOPY  MVC   0(,14),0(1)                                     @SC87020 05467000
*                                                                       05467500
* Storage for SVC interception                                 @SC86158 05468000
SVCSV1   DS    2F            Saved 12,13                       @SC86158 05468500
SVCSV2   DS    2F            Saved 14,15                       @SC86158 05469000
SVCOPTR  DS    2F            Buffer output and end ptrs        @SC86158 05469500
STKA     STACK MF=L,DATASET=(*,OUTDD=STKDD)                    @SC88026 05470000
STKZ     STACK MF=L,DELETE=TOP                                 @SC88026 05470500
STKDD    DC    CL8'K999999Y' DD name for STACK interception    @SC88026 05471000
         LOCALS ,                                              @SC86295 05471500
ATCHCPPL DS    4F            Subtask CPPL area                 @TS86001 05472000
SFCSTBL  STAX  MF=L          ATTN during subtask execution     @SC88118 05472500
ATCBLK   ATTACH SF=L         ATTACH parameter list             @SC88022 05473000
ATCHECB  DS    F             Subtask ECB                       @TS86001 05473500
         DS    6X            Leave some space for text unit    @SC88291 05474000
ATCHTCB  DS    F             Subtask TCB ptr                   @TS86001 05474500
ATCTXT   EQU   ATCHTCB-6,6   Prefix to TCB ptr (watch overlap!)@SC88087 05475000
SFCBUF   DS    F,CL256       Command buffer                    @GH89057 05475500
SFCBLDL  DS    2H            BLDL list: count & length         @GH89050 05476000
         DS    CL8,XL52      BLDL list: membername, TTRC, etc. @GH89050 05476500
SFCDEL   DS    0F            CAMLST overlays...                @SC88106 05477000
STKDYN   DS    7F            DYNALC calling sequence           @SC88026 05477500
*               - Also used for CAMLST UNCAT/SCRATCH & DYNALLOC@SC88106 05478000
STKDRC   DS    F             DYNALC return code                @SC88026 05478500
STKTKT   DS    A             Ptr to STACK file FAB             @SC88026 05479000
         ORG   STKDYN        Overlay interception stuff        @SC88087 05479500
ATCDRB   DS    5F            DYNALLOC RB (init to zeroes)      @SC88087 05480000
ATCTXP   DS    A             Text unit list (ATCTXT)           @SC88087 05480500
ATCRBP   DS    A             Ptr to RB                         @SC88087 05481000
         ORG   ,                                               @SC88087 05481500
EXCFLG   DS    C             Flag for implicit EXEC            @SC89073 05482000
SFCFLGS  DS    X             Type of call to SUPFNC            @SC92342 05482500
SUPFNC   EXIT                                                  @SC86158 05483000
         TITLE 'TERMIO Routine - Handle terminal I/O'                   05483500
* R1 points to a pair of (adr,len) for read or write.  If I/O is        05484000
* successfull, R15 returns transferred byte count (else returns -1).    05484500
*               Command code is in R0:                                  05485000
* 1 => Open line for I/O            4 => Write packet                   05485500
* 2 => Close line                   5 => Read packet                    05486000
* 3 => Reset line status after    ( 6 => Write message ) not used       05486500
*      environment changes                                              05487000
*                                                                       05487500
TERMIO   ENTER                                                          05488000
         SR    15,15         OK                                @SC86295 05488500
         STC   0,CONSOPR                                       @SC92180 05489000
         BCT   0,TRMCLS                                        @SC86295 05489500
* Open terminal line for protocol                                       05490000
         STAX  BR14,REPLACE=NO  Ingore attention interrupts    @SC88118 05490500
         MVI   RIOC,X'80'    Nothing saved                     @SC86295 05491000
         MVI   TRMFLG,X'FF'  Initialize w/r flag               @SC87275 05491500
         CLI   TRMTP,C'F'    Non-transparent full-screen?      @SC92030 05492000
         BNE   RTRN0         No, all set                       @SC92030 05492500
         STFSMODE ON,INITIAL=YES,NOEDIT=YES Full-screen mode   @SC92030 05493000
         LA    1,TRMFULA1    Set up introducer: adr            @SC92030 05493500
         LA    2,TRMFULL1    Length                            @SC92030 05494000
         STM   1,2,WRCMD                                       @SC92030 05494500
         LA    0,TRMFULL1+TRMFULL2                             @SC92030 05495000
         ICM   1,8,=X'03'    FULLSCR (for VTAM)                @SC92030 05495500
         BAL   8,TRMLOG                                        @SC92180 05496000
         TPUT  (1),(0),R     Clear and format                  @SC92030 05496500
         B     RTRN0                                           @SC86295 05497000
* Close terminal line after protocol transfer                           05497500
TRMCLS   BCT   0,TRMRSET                                       @SC86295 05498000
         STAX                                                           05498500
         CLI   TRMTP,C'F'    Non-transparent full-screen?      @SC92030 05499000
         BNE   RTRN0         No, all set                       @SC92030 05499500
         STFSMODE OFF                                          @SC92030 05500000
         SR    0,0                                             @SC92030 05500500
         KCALL SCRNIO        One final CLEAR                   @SC92030 05501000
         B     RTRN0                                           @SC86295 05501500
* (Re)set terminal characteristics to suit environment                  05502000
TRMRSET  BCT   0,TRMRW                                         @SC86295 05502500
         B     RTRN0                                           @SC86295 05503000
*                                                                       05503500
*  Perform I/O request                                                  05504000
TRMRW    BCT   0,TRMRD                                         @SC87015 05504500
         CLI   WRRD,0        Write/read?                       @SC87275 05505000
         BNE   *+8           Yes                               @SC87275 05505500
         MVI   TRMFLG,0      Indicate no action on follow-up   @SC87275 05506000
         L     0,4(1)        Get length                        @SC87015 05506500
         L     1,0(1)        and address                       @SC87015 05507000
         CLI   TRMTP,C'F'    Full-screen non-transparent?      @SC92030 05507500
         BNE   TRMW0         No                                @SC92030 05508000
         LA    2,TRMFULA2    Stuff to append to stream         @SC92030 05508500
         XI    FL3,FCLRF     Flip switch for clearing          @SC92030 05509000
         TM    FL3,FCLRF     Clearing now?                     @SC92030 05509500
         BO    TRMWAP        Yes, finish stream                @SC92030 05510000
         LA    2,TRMFULB2    Stuff to append if not clearing   @SC92030 05510500
         MVC   0(TRMFULL1,1),TRMFULB1 Replace introducer       @SC92030 05511000
TRMWAP   LR    3,0                                             @SC92030 05511500
         AR    3,1           End of data                       @SC92030 05512000
         MVC   0(TRMFULL2,3),0(2) Append extra commands        @SC92030 05512500
         AH    0,=Y(TRMFULL2) Add length of extra              @SC92030 05513000
         B     TRMW1                                           @SC92030 05513500
TRMW0    DS    0H                                              @SC92030 05514000
         ICM   1,8,=X'02'    CONTROL                           @SC87317 05514500
         CLI   TRMTP,C'V'                                      @SC88323 05515000
         BNE   *+8                                             @SC87317 05515500
TRMW1    DS    0H                                              @SC92030 05516000
         ICM   1,8,=X'03'    FULLSCR (for VTAM)                @SC88323 05516500
         BAL   8,TRMLOG                                        @SC92180 05517000
         TPUT  (1),(0),R     Flags already set                 @SC87317 05517500
         B     RTRN0                                           @SC87317 05518000
*                                                                       05518500
* TRMLOG: Dump command parameters and data buffer              @SC92180 05519000
* Return via R8.  R3, R7, and R14-R15 destroyed.               @SC92180 05519500
TRMLOG   STM   0,1,TRMLRS    Save ptrs                         @SC92180 05520000
         LA    1,TRMLRS      Get plist ptr                     @SC92180 05520500
         SLR   2,2           Convert op. code to log label     @SC92180 05521000
         IC    2,CONSOPR                                       @SC92180 05521500
         LA    2,CONSOPRS(2)                                   @SC92180 05522000
         IC    0,0(,2)                                         @SC92180 05522500
         LA    2,8           Size of plist                     @SC92180 05523000
         BAL   7,SCRLOG      Log it                            @SC92180 05523500
         LM    0,1,TRMLRS    Restore R1                        @SC92180 05524000
         LA    2,C'd'                                          @SC92180 05524500
         BAL   7,SCRLOG      Log it                            @SC92180 05525000
         LM    0,1,TRMLRS    Restore R1                        @SC92180 05525500
         BR    8                                               @SC92180 05526000
*                                                                       05526500
* Read from terminal                                                    05527000
TRMRD    MVC   KTGETT(8),0(1) Copy adr,len                     @SC87015 05527500
         TS    TRMFLG                                          @SC87275 05528000
         BZ    RTRN0         Just a follow-up. 0-length read   @SC87275 05528500
         MVI   ECBTGET,0     Clear ECB                         @SC87015 05529000
         SR    5,5           Set flag 'no timing'              @SC87015 05529500
         ICM   5,1,TIMOSRV   Timing allowed?                   @SC90045 05530000
         BZ    TRMPST                                          @NW86330 05530500
         ICM   5,1,TIMOUT    Any timing requested?             @SC87015 05531000
         BZ    TRMPST        No, just wait                     @SC87015 05531500
         MH    5,=H'100'                                       @SC87015 05532000
         ST    5,TMPDW                                         @SC87015 05532500
         LA    1,ECBTGET     ECB for timer to post             @SC88299 05533000
         STCM  1,15,TMXPT    Set up addressibility             @SC88299 05533500
         STIMER REAL,TMXIT,BINTVL=TMPDW                        @SC88299 05534000
TRMPST   POST  ECBREAD       Tell async sub to go for it       @NW86330 05534500
         WAIT  ECB=ECBTGET                                     @NW86330 05535000
         CLI   ECBTGET+3,0   Check return code                 @NW86330 05535500
         BNE   TRMTIM                                          @NW86330 05536000
         LTR   5,5           Timing enabled?                   @SC87015 05536500
         BZ    TRMRET        No, fine                          @SC87015 05537000
         TTIMER CANCEL       Yes, kill timer                   @SC87015 05537500
TRMRET   DS    0H                                              @SC92030 05538000
         L     0,KTGETT+4                                      @SC92030 05538500
         L     1,KTGETT                                        @SC92030 05539000
         BAL   8,TRMLOG      Log data read                     @SC92180 05539500
         L     15,KTGETT+4   Get length read                   @SC92030 05540000
         S     15,WRCMDL+4   Deduct 3 for buffer adr           @SC92030 05540500
         B     RTRN                                            @SC87015 05541000
TRMTIM   DETACH TASKADD      Blow off task                     @NW86330 05541500
         MVI   ECBREAD,0     Zero out read ECB                 @NW86330 05542000
         ATTACH EP=KERMTGET,MF=(E,COMPTR)                      @NW86330 05542500
         ST    1,TASKADD     Save adr for detach               @NW86330 05543000
         L     1,APKT        Ptr to data buffer                @SC87015 05543500
         MVI   0(1),AT       Timed out                         @SC87015 05544000
         B     RTRN1         Set count to one                  @SC87015 05544500
*                                                                       05545000
TRMFULA1 DC    X'C2,11,4040,3C,4040,00,1D60,11,C150'           @SC92030 05545500
TRMFULL1 EQU   *-TRMFULA1                                      @SC92030 05546000
TRMFULA2 DC    X'11,C36F,1D40,13'                              @SC92030 05546500
TRMFULL2 EQU   *-TRMFULA2                                      @SC92030 05547000
TRMFULB1 DC    X'C2,11,4040,3C,4040,00,1D60,11,C650'           @SC92030 05547500
TRMFULB2 DC    X'11,C86F,1D40,13'                              @SC92030 05548000
         LTORG                                                 @SC92180 05548500
         TITLE 'KERMTGET Routine - Read from terminal (timed)'          05549000
*  ECB's control timing flow                                   @NW86330 05549500
KERMTGET CSECT                                                 @SC87015 05550000
         USING *,12                                            @SC88299 05550500
         SAVE  (14,12),,*                                      @SC87015 05551000
         LR    12,15                                           @SC88299 05551500
         LM    10,11,0(1)    Set up addressibility             @SC87015 05552000
KTGLP0   WAIT  ECB=ECBREAD                                     @NW86330 05552500
         MVI   ECBREAD,0     Zero ECB                          @NW86330 05553000
         L     1,KTGETT      Adr of buffer to put in           @NW86330 05553500
         L     0,KTGETT+4    Max TGET (although tcam's 4k)     @NW86330 05554000
         TGET  (1),(0),ASIS                                    @NW86330 05554500
         LTR   15,15                                           @NW86330 05555000
         BZ    KTGLEN        Ok                                @NW86330 05555500
         C     15,F12                                          @NW86330 05556000
         BE    KTGLEN        Ok                                @NW86330 05556500
         CH    15,=H'24'                                       @SC92030 05557000
         BE    KTGLEN        Ok, Full-screen                   @SC92030 05557500
         SR    1,1           Error                             @NW86330 05558000
         BCTR  1,0                                             @NW86330 05558500
KTGLEN   ST    1,KTGETT+4    Save length                       @SC87015 05559000
         POST  ECBTGET       Tell em we read it                @NW86330 05559500
         B     KTGLP0        Keep repeating                    @NW86330 05560000
         LTORG                                                 @SC87015 05560500
         TITLE 'GETLIN Routine - Get a line from terminal'     @SC87015 05561000
* Entry: R1->buffer of length 256                              @SC87015 05561500
* Exit: Buffer filled, R0=length, R15=0 if ok. Else R15=1.     @SC87015 05562000
GETLIN   ENTER                                                 @SC87015 05562500
         LR    8,1           Save buffer ptr                   @SC88095 05563000
         LA    9,256         For copying                       @SC88095 05563500
         LA    3,APGPB       Ptr to GETLINE block              @SC88095 05564000
         USING GTPB,3                                          @SC88095 05564500
         ICM   5,15,GTPBIBUF Already got something?            @SC88095 05565000
         BNZ   GTL1          Yes, return it                    @SC87015 05565500
         SR    0,0                                             @SC91205 05566000
         IC    0,ERRNUM      Get current status code           @SC91205 05566500
         C     0,F1                                            @SC91205 05567000
         BH    *+6                                             @SC91205 05567500
          SR   0,0           Treat 1 as if 0                   @SC91205 05568000
         L     1,ORGR1       Get ptr to CPPL                   @SC91205 05568500
         USING CPPL,1                                          @SC91205 05569000
         L     1,CPPLECT     Get ECT ptr                       @SC91205 05569500
         USING ECT,1                                           @SC91205 05570000
         STCM  0,7,ECTRTCD   Set CC for any CLIST running      @SC91205 05570500
         DROP  1                                               @SC91205 05571000
         MVI   CPECB,0       Clear ECB                         @SC88119 05571500
         L     15,GETLINAD   Entry point for GETLINE routine   @NW86330 05572000
         GETLINE PARM=(3),TERMGET=(EDIT,WAIT),ENTRY=(15),      @SC88095+05572500
               MF=(E,IOPLAREA)                                 @SC87015 05573000
         SR    2,2                                             @SC88095 05573500
         C     15,F4         Problem?                          @SC87015 05574000
         BH    GTLA          Yes, give up with len=0           @SC87015 05574500
         L     5,GTPBIBUF    Ptr to input buffer               @SC88095 05575000
GTL1     LH    1,0(5)        Length of stuff (inc. header)     @SC88095 05575500
         AR    1,5           End of buffer                     @SC88095 05576000
         LR    0,1           Save end                          @SC88095 05576500
         LH    6,2(5)        Get starting offset (init. 0)     @SC88095 05577000
         LA    6,4(6,5)      Ptr into buffer                   @SC88095 05577500
         LR    2,1                                             @SC88095 05578000
         SR    2,6           Length of text remaining          @SC88095 05578500
         BNP   GTLFRE        None, return length 0             @SC88095 05579000
         SR    4,4                                             @SC88095 05579500
         IC    4,LNDLM       Get delimiter                     @SC88095 05580000
         LA    4,TRTBL(4)    Ptr to delimiter char             @SC88095 05580500
         MVI   0(4),1        Set up to snag delims             @SC88095 05581000
         MVI   TRTBL+C' ',0  And ignore blanks                 @SC88095 05581500
         CR    2,9           Get shorter of 256 and string     @SC88095 05582000
         BNH   *+6                                             @SC88095 05582500
          LR   2,9                                             @SC88095 05583000
         BCTR  2,0           Set up for EX                     @SC88095 05583500
         EX    2,GTLTRT                                        @SC88095 05584000
         MVI   0(4),0        Now clear out table               @SC88095 05584500
         MVI   TRTBL+C' ',1  And restore                       @SC88095 05585000
         SR    1,6           Length of line                    @SC88095 05585500
         LR    7,1           Set up MVCL                       @SC88095 05586000
         CR    9,7           Get shorter of 256 and string     @SC88095 05586500
         BNH   *+6                                             @SC88095 05587000
          LR   9,7                                             @SC88095 05587500
         LR    2,9           Length actually copied            @SC88095 05588000
         MVCL  8,6                                             @SC88095 05588500
         AR    6,7           In case we couldn't use it all    @SC88095 05589000
         CR    6,0           Finished input?                   @SC88095 05589500
         BNL   GTLFRE        Yes, release it                   @SC88095 05590000
         S     6,F3          + 1 - 4: skip over linend char    @SC88095 05590500
         SR    6,5           New offset ptr                    @SC88095 05591000
         STH   6,2(5)                                          @SC88095 05591500
         B     GTLZ          Return                            @SC88095 05592000
GTLFRE   LR    1,5           This buffer is used up            @SC88095 05592500
         LH    0,0(1)        Get total length                  @SC88095 05593000
         FREEMAIN RC,LV=(0),A=(1),SP=1 Free input buffer       @NW86330 05593500
GTLA     MVC   GTPBIBUF,F0   Clear input indicator             @SC87015 05594000
GTLZ     RETREG (0,2)        Return (2) as R0                  @SC89218 05594500
         B     RTRN0                                           @SC87015 05595000
         DROP  3                                               @SC88095 05595500
GTLTRT   TRT   0(,6),TRTBL   Find a delimiter                  @SC88095 05596000
         LOCALS ,                                              @SC87015 05596500
GETLIN   EXIT  ,                                               @SC87015 05597000
         TITLE 'SCRNIO Routine - Handle screen I/O via Series/1'        05597500
* R1 points to a pair of (adr,len) for read or write.  If I/O is        05598000
* successfull, R15 returns transferred byte count (else returns -1).    05598500
*               Command code is in R0:                                  05599000
* 0 => Clear screen on console (not comm line)                 @SC90045 05599500
* 1 => Open screen for I/O            4 => Write packet (gets ATTN)     05600000
* 2 => Close screen                   5 => Read packet                  05600500
* 3 => Reset screen status after      6 => Write message (no ATTN)      05601000
*      environment changes                                              05601500
*                                                                       05602000
TERMIO   ENTER AGAIN                                           @SC92180 05602500
SCRNIO   ENTER ALT                                             @SC92180 05603000
         LA    8,SCRPLST     Get PLST ptr                      @SC90222 05603500
         LR    6,1           Save ptr to plist                 @SC90222 05604000
         LTR   0,0                                             @SC90045 05604500
         BZ    SCRCLR                                          @SC90045 05605000
         STC   0,CONSOPR     Save command code                 @LP88158 05605500
         BCT   0,SCRCLS                                        @SC86295 05606000
* Set up for transparent I/O                                            05606500
         L     1,=A(IDEFS)   CSECT of initializations          @SC90173 05607000
         USING DEFS,1        Mapped via DSECT                  @SC90173 05607500
         LA    2,S1DATA      Series/1 introducer               @SC90173 05608000
         LA    3,S1ORDL+2    Length + 2                        @SC90173 05608500
         CLI   TRMTP,C'S'                                      @SC90173 05609000
         BE    SCRPRSET      Do it                             @SC90173 05609500
         LA    2,GRDATA      Graphics introducer               @SC90173 05610000
         LA    3,GRDL+2      Length + 2                        @SC90173 05610500
         CLI   TRMTP,C'G'                                      @SC90173 05611000
         BE    SCRPRSET      Do it                             @SC90173 05611500
         LA    2,AEADAT      AEA introducer                    @SC90173 05612000
         LA    3,AEAL+2                                        @SC90173 05612500
         DROP  1                                               @SC90173 05613000
SCRPRSET LR    5,3                                             @SC90173 05613500
         LA    4,S1EOL+2     Get start of command buffer       @SC90173 05614000
         SR    4,5                                             @SC90173 05614500
         STM   4,5,S1XOPL    Set up prompt plist               @SC90173 05615000
         S     5,F2          Deduct stuff already there        @SC90173 05615500
         MVCL  4,2                                             @SC90173 05616000
         MVI   SCRLST,0      Clear op code                     @SC88091 05616500
         STFSMODE ON,INITIAL=YES,NOEDIT=YES Full-screen mode   @TS86001 05617000
         LA    6,CLRSPLST                                      @SC90222 05617500
         BAL   9,SCRNEXW     Clear screan                      @SC90222 05618000
         B     RTRN0                                           @SC86295 05618500
SCRCLR   CLI   TRMTP,C'T'    Is it a TTY terminal?             @SC90045 05619000
         BE    RTRN0         Yes, can't clear screen           @SC90045 05619500
         CLI   TRMTP,C'V'    Is it a TTY terminal?             @SC90045 05620000
         BE    RTRN0         Yes, can't clear screen           @SC90045 05620500
         CLI   TRMTP,C'F'    Is it some full-screen?           @SC92030 05621000
         BE    *+12          Yes, must clear frequently        @SC92030 05621500
         TM    FL2,PROTO     In protocol mode?                 @SC90045 05622000
         BO    RTRN0         Yes, skip clearing screen         @SC90045 05622500
         STFSMODE ON,INITIAL=YES,NOEDIT=YES Full-screen mode   @SC91246 05623000
         B     SCRCLRB       Do it                             @SC91246 05623500
SCRCLS   BCT   0,SCRRSET                                       @SC86295 05624000
* Clean up after I/O                                                    05624500
SCRCLRB  DS    0H                                              @SC91246 05625000
         LA    6,CLRSPLST                                      @SC90222 05625500
         BAL   9,SCRNEXW     Clear screan                      @SC90222 05626000
         STFSMODE OFF                                          @TS86001 05626500
         B     RTRN0                                           @SC86295 05627000
* (Re)set device characteristics to suit environment                    05627500
SCRRSET  BCT   0,SCRRW                                         @SC86295 05628000
         B     RTRN0                                                    05628500
*                                                                       05629000
*  Perform I/O request                                                  05629500
SCRRW    DS    0H                                              @SC90222 05630000
         SR    2,2                                             @SC88091 05630500
         IC    2,SCRLST      1=>Write, 2=>Read, 3=>Wr. msg.    @SC88091 05631000
         STC   0,SCRLST      Save new code                     @SC88091 05631500
         BCT   0,SCRRD       Different handling for each       @SC88019 05632000
SCRWM    DS    0H            Come back here for message        @SC88105 05632500
         BAL   9,SCRNEXW     Write it                          @SC90222 05633000
         ICM   1,15,SCRRC    Check return code                 @SC90222 05633500
         BNZ   RTRNM1        This may never happen             @SC90222 05634000
         B     RTRN0         Assume OK                         @SC88019 05634500
SCRRD    BCT   0,SCRWM       Go if "Write message"             @SC88019 05635000
         C     2,F3          Was last operation a Write msg?   @SC88091 05635500
         BNE   SCRRD1        No, fine                          @SC88091 05636000
         TPG   SCRF6,1       Yes, must trigger a READ MOD      @SC90145 05636500
SCRRD1   DS    0H                                              @SC88091 05637000
         MVI   4(8),X'81'    Flags: TGET                       @SC88019 05637500
SCRE4TRY BAL   9,SCRNEX      Execute internal subr             @SC93159 05638000
         LTR   15,15         Did it fail?                      @LP88188 05638500
         BL    RTRN          Yes, continue                     @LP88188 05639000
         TM    FL2,PROTO     In midst of transfer?             @SC88203 05639500
         BZ    RTRN          No, must be status check          @SC88203 05640000
         L     1,4(,8)       Data address                      @LP88188 05640500
         CLI   0(1),X'E4'    7171 overrun (line error)?        @LP88188 05641000
         BNE   RTRN          No, continue                      @LP88188 05641500
         LA    8,SCRE4RES    Reset transparent mode            @SC93159 05642000
         MVI   CONSOPR,6                                       @SC93159 05642500
         BAL   9,SCRNEXP                                       @SC93159 05643000
         LA    8,SCRE4RET                                      @LP88188 05643500
         MVI   CONSOPR,4     And send a dummy packet           @LP88188 05644000
         BAL   9,SCRNEXP                                       @SC93159 05644500
         MVI   CONSOPR,5     Do the read again                 @LP88188 05645000
         LA    8,SCRPLST     Get PLST ptr                      @SC93159 05645500
         B     SCRE4TRY      Loop until no more E4 reply       @LP88188 05646000
*                                                                       05646500
* SCRLOG: Hexadecimal log of (R2) bytes at address (R1)        @LP88158 05647000
* Log label is taken from R0 low order byte.                   @SC89166 05647500
* Return via R7.  R0-R3 and R15 destroyed.                     @SC89166 05648000
SCRLOG   TM    FL1,DEBUG     Logging in effect?                @SC87286 05648500
         BZR   7             No, that's all                    @SC89166 05649000
         TM    DBGFLG,DBGIO  I/O stuff requested?              @SC88168 05649500
         BZR   7             No, skip it                       @SC89166 05650000
         L     3,LOGBUF      Ptr to buffer                     @LP88158 05650500
         STC   0,0(,3)       Set log label                     @SC89166 05651000
         LA    3,2(,3)       Start of data area                @SC91172 05651500
         TM    DBGFLG,DBGTI  Times requested?                  @SC91172 05652000
         BZ    SCRLOGA       No, just do hex dump              @SC91172 05652500
         ST    1,SCRLR1      Save ptr to block                 @SC91172 05653000
         BAL   14,ACCTTOD    Get time of day in seconds        @SC91172 05653500
         MVI   0(3),C' '     Leave a space                     @SC91172 05654000
         KCALL DUMPTOD,1(3)  Format time into buffer           @SC91172 05654500
         LR    3,15          Get ptr to end of string          @SC91172 05655000
         L     1,SCRLR1      Restore R1                        @SC91172 05655500
SCRLOGA  LA    0,6*9(,3)     End of line buffer                @SC91172 05656000
         TM    DBGFLG,DBGLO  Long buffer requested?            @SC90222 05656500
         BZ    *+8                                             @SC90222 05657000
          LA   0,50*9(,3)    Yes, long buffer                  @SC91172 05657500
SCRLOGLP MVI   0(3),C' '     Add for readability               @LP88158 05658000
         UNPK  1(9,3),0(5,1) Unpack into buffer                @SC88168 05658500
         TR    1(8,3),TRHEX  Convert to printable hex          @SC88168 05659000
         LA    3,9(3)        Advance text ptr                  @SC88168 05659500
         LA    1,4(1)        and data source                   @LP88158 05660000
         S     2,F4          Finished data?                    @SC88168 05660500
         BNP   SCRLGEND      Yes, go write                     @LP88158 05661000
         CR    3,0           Reached text limit?               @LP88158 05661500
         BL    SCRLOGLP      no, loop for more slices          @LP88158 05662000
         MVC   0(3,3),=C'...' Show incomplete                  @LP88158 05662500
         LA    3,3(3)                                          @SC88168 05663000
SCRLGEND DS    0H                                              @LP88158 05663500
         AR    2,2           Check for incomplete slice        @SC88168 05664000
         BNM   *+6           No, ok                            @SC88168 05664500
         AR    3,2           Yes, adjust end of text           @SC88168 05665000
         S     3,LOGBUF      Get length of text                @SC88168 05665500
         WRITF LOGPTR,BSIZE=(3) Log it                         @LP88158 05666000
         TM    DBGFLG,DBGSV  SAVE requested?                   @SC88168 05666500
         BZR   7             No, skip closing log file         @SC89166 05667000
         SAVEF LOGPTR        Update disk directory             @SC88168 05667500
         BR    7                                               @SC89166 05668000
*                                                                       05668500
SCRNEXW  MVI   4(8),X'03'    Flags: FULLSCR/NOEDIT             @SC90222 05669000
         MVI   12(8),X'01'   More flags: NOEDIT for TPUT       @SC90222 05669500
SCRNEX   MVC   5(3,8),1(6)   Copy adr                          @SC90222 05670000
         MVC   2(2,8),6(6)   Copy len                          @SC90222 05670500
         OI    12(8),X'80'   Flag for extended plist           @SC90222 05671000
SCRNEXP  DS    0H                                              @SC93159 05671500
         LR    1,8           Get plist ptr                     @SC90222 05672000
         SLR   2,2           Convert op. code to log label     @LP88158 05672500
         IC    2,CONSOPR                                       @LP88158 05673000
         LA    2,CONSOPRS(2)                                   @LP88158 05673500
         IC    0,0(,2)                                         @SC89166 05674000
         LA    2,16          Size of plist                     @SC90222 05674500
         BAL   7,SCRLOG      Log it                            @SC90222 05675000
         CLI   CONSOPR,5     Read operation?                   @SC90222 05675500
         BE    SCRNEXG       Yes, use registers only           @SC90222 05676000
         ICM   0,8,=X'80'    Set hi bit of R0                  @SC90222 05676500
         LR    1,8           Get ptr for SVC                   @SC90222 05677000
         TPUT  (1),(0),R                                       @SC90222 05677500
         LH    5,2(,8)       Number of chars sent              @SC90222 05678000
         B     SCRNEXT       Now rejoin                        @SC90222 05678500
SCRNEXG  LM    0,1,0(8)      Load up registers for SVC         @SC90222 05679000
         TGET  (1),(0),R                                       @SC90222 05679500
         LR    5,1           Number of chars recv'd            @SC90222 05680000
SCRNEXT  ST    15,SCRRC      Save return code                  @SC90222 05680500
         LTR   15,15                                           @SC90222 05681000
         BZ    SCRNEXD       Ok, log data                      @SC90222 05681500
         CH    15,=H'24'     Check for "ok, but NOEDIT"        @SC91259 05682000
         BE    SCRNEXD       Yup, that's ok                    @SC91259 05682500
         LA    1,SCRRC                                         @SC90222 05683000
         LA    2,4                                             @SC90222 05683500
         LA    0,C'e'        "Error" label                     @SC90222 05684000
         BAL   7,SCRLOG      Log the return code               @SC90222 05684500
SCRNEXD  L     1,4(,8)       Data address                      @SC90222 05685000
         LA    0,C'd'        "Data" label                      @SC89166 05685500
         LR    2,5           Data size                         @SC90222 05686000
         BAL   7,SCRLOG      Log data                          @SC90222 05686500
         LR    15,5                                            @LP88186 05687000
         S     15,WRCMDL+4   Deduct 3 for buffer adr           @SC90173 05687500
         BNMR  9             Presumably ok                     @SC92030 05688000
         CLI   WRRD,0        Was it write-only?                @SC92030 05688500
         BNER  9             No                                @SC92030 05689000
         C     5,F1          If READ, did we get just AID?     @SC92030 05689500
         BNER  9             No                                @SC92030 05690000
         SR    15,15         Yes, assume all is well           @SC92030 05690500
         BR    9                                               @SC86299 05691000
*                                                                       05691500
SCRE4RES TPUT  SCRE4LTM,SCRE4LTL,NOEDIT,MF=L                   @SC93159 05692000
SCRE4RET TPUT  SCRE4DWR,SCRE4DWL,NOEDIT,MF=L                   @SC93159 05692500
SCRE4LTM DC    &S1CMD,AL1(SBA),X'4040',AL1(ICR),X'4040' Reset  @SC93159 05693000
SCRE4LTL EQU   *-SCRE4LTM    Length of command                 @SC88168 05693500
SCRE4DWR DC    &S1CMD,AL1(SBA),X'5D7F',AL1(SBA),X'000180' packe@SC93159 05694000
SCRE4DWL EQU   *-SCRE4DWR    Length of command                 @SC88168 05694500
*                                                                       05695000
CLRSPEC  DC    &S1CMD,AL1(SBA),X'4040',X'3C404000' Clr scrn    @SC90264 05695500
CLRSPECL EQU   *-CLRSPEC     Length of clear screen            @TS86001 05696000
CLRSPLST DC    AL4(CLRSPEC,CLRSPECL)                           @SC90222 05696500
*                                                                       05697000
CONSOPRS DC    C'?ocswrmg'   Console command labels for log    @SC93146 05697500
SCRF6    DC    X'F6'         Cmd to trigger a READ MOD         @SC90145 05698000
         LOCALS ,                                              @SC86299 05698500
SCRPLST  DS    4F            Plist for TPUT/TGET               @SC88019 05699000
TRMLRS   EQU   SCRPLST       Saved registers for logging       @SC92180 05699500
SCRRC    DS    F             Return code from TPUT/TGET        @SC90222 05700000
SCRLR1   DS    F             Saved R1 in SCRLOG                @SC91172 05700500
CONSOPR  DS    XL1           Current I/O operation             @SC89180 05701000
SCRNIO   EXIT  ,                                               @SC86299 05701500
         TITLE 'SETMSG Routine - controls CP breakin'                   05702000
* Entry: R1 selects operation                                           05702500
* Exit: R15=0 if ok                                                     05703000
* 1-> Analyze user environment, determine if suitable.                  05703500
*     Save quantities needed and condition line for entering commands.  05704000
*     Perform any system-dependent initialization.                      05704500
* 2-> Condition line for protocol transfers.                            05705000
* 3-> Decondition line at end of transfer.                              05705500
* 4-> System-dependent clean-up at exit.                                05706000
* 5-> Reperform system-dependent initialization after SET LINE.         05706500
SETMSG   ENTER ,                                               @SC87015 05707000
         BCT   1,STM2                Go if R1 not 1, so no init         05707500
         L     1,ORGR1       Get original R1                   @SC86299 05708000
         TM    0(1),X'80'    Is this a command processor?      @SC86299 05708500
         BO    NOTCP         No, then refuse user              @SC86299 05709000
         USING CPPL,1                                          @SC86299 05709500
         L     2,CPPLUPT     Get ptr to UPT                    @SC86299 05710000
         USING UPT,2                                           @SC86299 05710500
         XR    3,3                                             @SC86299 05711000
         IC    3,UPTPREFL    Get length                        @SC86299 05711500
         STH   3,DESTL       Save for later                    @SC86299 05712000
         MVC   DEST(7),UPTPREFX Move prefix                    @SC86299 05712500
         MVI   DESTP,C' '    Not a PDS                         @SC86299 05713000
         MVC   OLDUPTSW,UPTSWS  Save UPTSWS for later          @TL89181 05713500
         LA    4,IOPLAREA    Get address of IOPL               @TS86001 05714000
         USING IOPL,4        Make it addressable               @TS86001 05714500
         MVC   IOPLUPT,CPPLUPT Copy UPT ptr                    @TS86001 05715000
         L     3,CPPLECT     Copy ECT ptr                      @SC89052 05715500
         ST    3,IOPLECT                                       @SC89052 05716000
         LA    0,CPECB       Get address of ECB                @TS86001 05716500
         ST    0,IOPLECB     Put into IOPL                     @TS86001 05717000
         USING ECT,3                                           @SC89052 05717500
         MVC   ORGPCMD,ECTPCMD Save for Kermit HELP            @SC89052 05718000
         DROP  3,4                                             @SC89052 05718500
         OPENF L,=C'SYSPROC ',,SYSPROC,E=STMS1                 @SC89073 05719000
STMS1    DS    0H                                              @SC89073 05719500
         B     STMOK         Do some more setup                @SC90173 05720000
*                                                                       05720500
STM5X    DS    0H            Now set up controller type        @SC90173 05721000
         MVI   TRMTP,C'&KCONT'  1st assume TTY                 @SC88309 05721500
         GTSIZE ,            Get terminal info                 @SC86299 05722000
         LTR   0,0           Is this a graphics device?        @SC86299 05722500
         BZ    STMSTY        No                                @SC86299 05723000
         GTTERM PRMSZE=GTTSIZ,ATTRIB=GTTATTR,MF=(E,GTTPL)      @DL92073 05723500
         SR    1,1           Assume Query not allowed          @SC91311 05724000
         TM    GTTATTR+3,1                                     @SC91311 05724500
         BZ    STMGRS        Query not allowed                 @SC91311 05725000
         LA    1,STCQBIT     Ok, Query is allowed              @SC91311 05725500
STMGRS   DS    0H                                              @SC91311 05726000
         O     1,=A(&CONOPTS)                        Options   @SC91311 05726500
         KCALL SETCON        Find out just what kind...        @SC91311 05727000
         B     RTRN0                                           @SC90173 05727500
STMSTY  STSIZE SIZE=130      Set up linesize                   @TS86001 05728000
         STCC  ATTN          Try PROFILE(ATTN)                 @GH89042 05728500
         LTR   0,0           Check for LD=ATTN                 @GH89042 05729000
         BM    RTRN0         Must be TCAM TTY                  @SC90173 05729500
         LA    15,X'FF'      Set mask                          @GH89042 05730000
         NR    15,0          Isolate old LD                    @GH89042 05730500
         STCC  LD=(15)       Restore old LD                    @GH89042 05731000
         LTR   0,0           Did first STCC work?              @GH89042 05731500
         BM    RTRN0         Yes: must be TCAM TTY             @SC90173 05732000
         MVI   TRMTP,C'V'    No: must be VTAM TWX              @GH89042 05732500
         B     RTRN0                                           @SC90173 05733000
STMOK    DS    0H                                              @SC88042 05733500
*          Note: KWRKBASE is 11...                             @SC89268 05734000
         STM   10,11,COMPTR  Save ptrs for KERMTGET            @SC87015 05734500
         LA    0,STKDSN      Set up DSN for STACK              @SC88026 05735000
         LH    1,DESTL                                         @SC88026 05735500
         LA    2,DEST        Get userid prefix                 @SC88026 05736000
         LA    3,LFID                                          @SC88026 05736500
         MVCL  0,2           Copy prefix                       @SC88026 05737000
         LR    1,3                                             @SC88026 05737500
         LA    2,=CL8'.KER.BUF'                                @SC88026 05738000
         LA    3,8           Copy rest of name                 @SC88026 05738500
         ICM   3,8,BLANK     Fill with blanks                  @SC88026 05739000
         MVCL  0,2                                             @SC88026 05739500
         LA    5,READATTN    ATTN routine adr (just post ECB)  @SC88118 05740000
         LA    6,CPECB       Ptr to ECB to post on ATTN        @SC88118 05740500
         STAX  (5),MF=(E,STAXPLR),USADDR=(6)                   @SC88118 05741000
         LOAD  EP=IKJGETL    Get line routine adr              @NW86330 05741500
         ST    0,GETLINAD    Store it off                      @NW86330 05742000
         LA    0,PTLLEN                                        @SC88026 05742500
         ST    0,PTPB+4      Set up PUTLINE parameter block    @SC88026 05743000
         LOAD  EP=IKJPUTL    PUTLINE routine adr               @SC88026 05743500
         ST    0,PUTLINAD                                      @SC88026 05744000
         L     5,=A(KERMTGET) Adr of TGET module               @NW86330 05744500
         PTEXT 'IDENTIFY failed.' Just in case                 @SC87015 05745000
         IDENTIFY EP=KERMTGET,ENTRY=(5)                        @NW86330 05745500
         LTR   15,15                                           @NW86330 05746000
         BNZ   SUBERR                                          @SC87015 05746500
         PTEXT 'ATTACH failed.' Just in case                   @SC87015 05747000
         ATTACH EP=KERMTGET,MF=(E,COMPTR)                      @SC87015 05747500
         LTR   15,15                                           @NW86330 05748000
         BNZ   SUBERR                                          @SC87015 05748500
         ST    1,TASKADD     Save adr for detach               @NW86330 05749000
         B     STM5X                                           @SC90173 05749500
*                                                                       05750000
READATTN STM   14,12,12(13)  Save registers                    @SC88118 05750500
         L     1,8(1)        Get ptr to term ECB               @SC88118 05751000
         POST  (1)           Post it                           @SC88118 05751500
         LM    14,12,12(13)  Restore registers                 @SC88118 05752000
         BR    14                                              @SC88118 05752500
*                                                                       05753000
STM2     BCT   1,STM3                Go if R1 was not 2, so not off     05753500
         CLI   S1HND,XON     User wants special one anyway?    @SC87343 05754000
         BNE   STM2X                                           @SC87343 05754500
         BAL   14,TTYCHK     TTY terminals can't change hndshk @SC92030 05755000
          MVI  S1HND,0       System provides the handshake     @SC87343 05755500
STM2X    DS    0H                                              @SC87343 05756000
         TM    FL1,TSTF                                        @SC86295 05756500
         BO    RTRN0         Just testing, don't change it     @SC86295 05757000
         CLI   TRMLIN,C' '   Alternate comm line?              @SC87300 05757500
         BNE   RTRN1         Not allowed!                      @SC87300 05758000
         STCOM NO            Set NOINTERCOM during protocol    @TL89181 05758500
         ICM   1,15,STMUOFF  Turn off, just in case            @SC88042 05759000
         B     STMD                                                     05759500
*                                                                       05760000
STM3     BCT   1,STM4                                          @SC86316 05760500
         TM    OLDUPTSW,UPTNCOM  Chk for NOINTERCOM in old UPT @TL89181 05761000
         BO    STM3A         If so, leave it off               @TL89181 05761500
         STCOM YES           Otherwise, set INTERCOM back on   @TL89181 05762000
STM3A    DS    0H                                              @TL89181 05762500
         ICM   1,3,STMUCH    Restore user's settings           @SC88042 05763000
         ICM   1,12,STMUOFF  Set flags to modify CDEL+LDEL     @SC88042 05763500
STMD     LA    0,7                                             @SC88042 05764000
         SLL   0,24          Set entry code for STCC           @SC88042 05764500
         SVC   94                                              @SC88042 05765000
         STC   0,STMUCH      Save previous LDEL                @SC88042 05765500
         STC   1,STMUCH+1    and CDEL                          @SC88042 05766000
         DROP  1,2                                             @SC88042 05766500
         B     RTRN0                                                    05767000
*                                                                       05767500
STM4     BCT   1,STM5        Special clean-up                  @SC87351 05768000
         DETACH TASKADD      Kill sub-task                     @SC87296 05768500
         CLOSF SYSPROC       Close CLIST library               @SC89073 05769000
         B     RTRN0         Special clean-up done             @SC87296 05769500
*                                                                       05770000
STM5     DS    0H            Re-init after SET LINE            @SC87351 05770500
         MVI   TRMTP,C'N'    Assume bad until validated        @SC90173 05771000
         CLI   TRMLIN,C' '   External line?                    @SC87351 05771500
         BE    STM5X         No, use terminal                  @SC90173 05772000
         B     RTRN1         Other lines not allowed           @SC90173 05772500
*                                                                       05773000
NOTCP    PTEXT '&NOTCPER'                                      @SC86299 05773500
         TPUT  (3),(4)       Simplest output method...         @SC88287 05774000
         B     RTRN1                                           @SC88287 05774500
*                                                                       05775000
STMUOFF  DC    X'3000FFFF'   No char & line delete             @SC88042 05775500
*                                                                       05776000
         LOCALS ,                                              @SC86295 05776500
GTTPL    GTTERM MF=L         Parameter block for GTTERM        @SC91311 05777000
GTTATTR  DS    F             Results from GTTERM               @SC91311 05777500
GTTSIZ   DS    H             GTTERM size response (ignore)     @DL92073 05778000
SETMSG   EXIT                                                           05778500
         TITLE 'DISKIO Routine - performs disk I/O functions'           05779000
* ERRNUM unchanged unless there is a disk error                         05779500
* Function selected on entry by R0:                                     05780000
* 0=> same as 9 (q.v.), but if ok, return R1->buffer,R0=# and remove    05780500
*   the sequence number (if any) from the buffer (used for TAKE files)  05781000
* 1=> open (in): R1->pattern FDB, R2->name.  Returns R0->FAB, R1->FDB   05781500
* 2=> open (out): (same)                                                05782000
* 3=> test name: R2->name.  Returns R1->FDB if file found and  @SC91269 05782500
*     writable (else R15=1)                                    @SC91269 05783000
*       (will say "found" if member given, but it's not a PDS) @SC88043 05783500
*       (will say "not found" if given member of PDS is missing)        05784000
* 4=> close file: R1->adr(FAB).                                         05784500
* 5=> set up search: R1->pattern name.                                  05785000
* 6=> return next file in list:  Returns R1->FDB + sets up FILNAM       05785500
* 7=> close search (if any).                                            05786000
* 8=> test CWD string: R1->string.  Returns R15=0 if ok, else =1.       05786500
* 9=> read: R1->FAB.  Returns R15=12 if EOF, 0 if ok; R0=# data         05787000
* 10=> write: R1->FAB.  Returns R15=13 if disk full, 0 if ok.           05787500
* 11=> test space: R1->pattern FDB (has size in Kbytes),                05788000
*  R2->name (used if FAB not found), R6->adr(FAB). Return R15=0 if ok.  05788500
* 12=> analyze R/W error, set ERRNUM, make EMSG: R1->FAB, TMPDW=code    05789000
*      always returns R15=1                                             05789500
* 13=> directory info on file: R1->name.  Returns R15=0 if ok.          05790000
* 14=> delete file: R1->name.  Returns R15=0 if ok.                     05790500
* 15=> rename file: R1->name, R2->new name.  Returns R15=0 if ok.       05791000
* 16=> copy file: R1->name, R2->new name.  Returns R15=0 if ok.         05791500
* 21=> save file status in directory: R1->FAB.                 @SC88168 05792000
* 22=> open library (in): R2->DDNAME.  Return R15=0 if ok.     @SC89073 05792500
* 23=> point for next read, R1->adr(FDB), R2=records to skip.  @SC89218 05793000
*      Return R15=0 if ok.                                     @SC89218 05793500
* 24=> test name: R2->name.  Returns R1->FDB if file found and @SC91269 05794000
*      readable (else R15=1)                                   @SC91269 05794500
DISKIO   ENTER                                                          05795000
         USING FABD,3                                          @SC86295 05795500
         SR    4,4           Signal no block assigned          @SC86295 05796000
         STC   0,DSKCOD      Save function code (for now)      @SC88101 05796500
         LA    5,DYNDSP                                        @SC86345 05797000
         LA    6,FDBTRKAL-FDBD(1) Use pattern TRKAL            @SC88026 05797500
         LA    7,DYNRC                                         @SC86345 05798000
         L     8,DFMSGP      Ptr to message buffer             @SC88119 05798500
         XC    0(4,8),0(8)   Clear out old message             @SC88119 05799000
         STM   5,8,DYNPL+16  Set up calling sequence           @SC86345 05799500
         LA    5,DISKIO+4095                                   @SC92022 05800000
         USING DISKIO+4095,5                                   @SC92022 05800500
         LR    6,0                                             @SC92022 05801000
         AR    6,6                                             @SC92022 05801500
         LH    6,DSK0(6)     Get handler address               @SC92022 05802000
         B     DSK0(6)       Do the function                   @SC92022 05802500
DSK0     DC    Y(DSKRED-DSK0,DSKOPNI-DSK0,DSKOPNO-DSK0)   0-2  @SC89073 05803000
         DC    Y(DSKTEST-DSK0,DSKCLOS-DSK0,DSKNSET-DSK0)  3-5  @SC89073 05803500
         DC    Y(DSKNXT-DSK0,DSKXSET-DSK0,DSKCWDF-DSK0)   6-8  @SC89073 05804000
         DC    Y(DSKRED-DSK0,DSKWRT-DSK0,DSKTSP-DSK0)     9-11 @SC89073 05804500
         DC    Y(DSKXXX-DSK0),8Y(DSKUTL-DSK0)            12-20 @SC89073 05805000
         DC    Y(DSKTCLOS-DSK0,DSKOPLIB-DSK0)            21-22 @SC89073 05805500
         DC    Y(DSKPNT-DSK0,DSKTEST-DSK0)               23-24 @SC91269 05806000
         DC    8Y(DSKER1-DSK0)   Spares                        @SC89073 05806500
*                                                                       05807000
* Open for input file whose name is at (R2), FDB at (R1)                05807500
DSKOPNI  DS    0H                                              @SC89073 05808000
         BAL   9,DSKALC      Get FAB                           @SC86295 05808500
         BAL   2,DSKLKP      Get DSCB                          @SC86299 05809000
         BNZ   DSKER1        Not found                         @SC86295 05809500
         BAL   14,DSKTCON    Check PDS notation                @SC88119 05810000
         BAL   14,DSKVALS                                      @SC86295 05810500
         BAL   9,DSKFABS     Set up FAB from FDB               @SC86299 05811000
         LH    0,FABLRECL                                      @SC86299 05811500
         CH    0,FDBBSIZ+2   Too big?                          @SC86299 05812000
         BNL   *+8           Yes, just read a buffer full      @SC86299 05812500
         ST    0,FDBBSIZ     Set buffer size, in case RECFM=F  @SC86299 05813000
         B     DSKOPT        Open and test                     @SC88049 05813500
*                                                                       05814000
* Open for output file whose name is at (R2), FDB at (R1)               05814500
DSKOPNO  DS    0H                                              @SC89073 05815000
         BAL   9,DSKALC      Get FAB                           @SC86295 05815500
         BAL   2,DSKLKP      Get DSCB                          @SC86299 05816000
         MVI   DYNDSP,X'42'  NEW,CATLG if not found            @SC89250 05816500
         BNZ   DSKOPN        Not found, just writing new       @SC86299 05817000
         BAL   14,DSKTCON    Check PDS notation                @SC88119 05817500
         MVI   DYNDSP,X'18'  OLD,KEEP                          @SC86299 05818000
         TM    DS1DSO,2      PDS?                              @SC88083 05818500
         BO    DSKOPVA       Yes, keep the other members!      @SC88083 05819000
         TM    FDBFLGS,APPN                                    @SC86295 05819500
         BZ    *+8                                             @SC90033 05820000
         MVI   DYNDSP,X'28'  MOD,KEEP                          @SC88083 05820500
         TM    FDBFLGS,APPN+SVATT                              @SC90033 05821000
         BZ    DSKOPN                                          @SC90033 05821500
DSKOPVA  DS    0H                                              @SC88083 05822000
         BAL   14,DSKVALS                                      @SC86295 05822500
         BAL   9,DSKFABS     Set up FAB from FDB               @SC86299 05823000
DSKOPN   MVI   DSKOPLS,X'8F' Code for OPEN OUTPUT              @SC88049 05823500
         LH    0,FDBLRC                                        @SC88120 05824000
         BAL   2,DSKTV                                         @SC88120 05824500
          S    0,F4          Deduct 4 for RDW if RECFM=V       @SC88120 05825000
         ST    0,FABLRTR     Set effective record length       @SC88120 05825500
DSKOPT   KCALL DYNALC,DYNPL,EXT                                @SC86299 05826000
         CLI   DYNRC+3,0                                       @SC88119 05826500
         BNE   DSKERAL       Error on allocation               @SC88119 05827000
         CLI   DYNDSP,X'42'  NEW dataset?                      @SC88090 05827500
         BNE   DSKOPBZ       No, assume BLKSIZE is ok          @SC88090 05828000
         DEVTYPE FABDDNAM,DYNPL  Yes, get max block            @SC88090 05828500
         ICM   0,15,DYNPL+4                                    @SC88090 05829000
         BNH   DSKOPBZ       Max not defined??                 @SC88090 05829500
         CH    0,FABBLKSI                                      @SC88090 05830000
         BNL   DSKOPBZ       Current BLKSIZE is ok             @SC88090 05830500
         STH   0,FABBLKSI    Mustn't exceed physical limits!   @SC88090 05831000
DSKOPBZ  DS    0H                                              @SC88090 05831500
         OPEN  MF=(E,DSKOPLS)                                  @SC88049 05832000
         TM    FABOFLGS,X'10'                                  @SC86299 05832500
         BZ    DSKER1        Didn't work                       @SC86299 05833000
         LA    9,FDBD        FDB pointer                       @SC91283 05833500
         RETREG (0,3),(1,9)  Return FAB ptr in R0, FDB in R1   @SC91283 05834000
         B     RTRN0                                           @SC86295 05834500
*                                                                       05835000
* Open library with DDNAME at (R2) - for BLDL only             @SC89073 05835500
DSKOPLIB LR    8,2                                             @SC89073 05836000
         LA    1,TAKFDB      VB/256                            @SC89073 05836500
         LA    2,F0+FABDSN-FABDSMB DS=PO                       @SC89073 05837000
         BAL   9,DSKALC      Get a DCB                         @SC89073 05837500
         MVC   FABDDNAM,0(8) Use given DD name                 @SC89073 05838000
         DMSFREE DWORDS=176/8,ERR=DSKER1 Get a JFCB            @SC89073 05838500
         LR    7,1           Save ptr to block                 @SC92022 05839000
         ST    7,FABEXL      Add to exit list                  @SC92022 05839500
         MVI   FABEXL,7      Mark it a JFCB                    @SC89073 05840000
         RDJFCB MF=(E,DSKOPLS)                                 @SC88073 05840500
         LR    6,15                                            @SC89073 05841000
         DMSFRET DWORDS=176/8,LOC=(7)                          @SC92022 05841500
         LTR   15,6                                            @SC89073 05842000
         BNZ   DSKER1                                          @SC89073 05842500
         MVI   FABEXL,0      Disable JFCB ptr                  @SC89073 05843000
         B     DSKOPBZ       Now open for input                @SC89073 05843500
*                                                                       05844000
* Test for existence of file whose name is at (R2)                      05844500
DSKTEST  DS    0H                                              @SC89073 05845000
         LR    8,2           Save DSN ptr                      @SC89250 05845500
         LA    1,FILFDB      Default pattern for HRECALL       @SC89250 05846000
         BAL   9,DSKALC      Allocate DCB                      @SC89250 05846500
         BAL   2,DSKLKP      Get DSCB                          @SC86299 05847000
         BNZ   DSKER1        Not found                         @SC86299 05847500
         CLI   FABDSMB,C' '  Did we want a member?             @SC88119 05848000
         BE    DSKTE1        No, fine                          @SC88043 05848500
         TM    DS1DSO,2      Was it a PDS?                     @SC88043 05849000
         BZ    DSKTE1        No, ignore the conflict for now   @SC88043 05849500
         XC    FABDSMB,FABDSMB Signal DSORG=PO                 @SC88119 05850000
         OPENF I,FABDSN,FILFDB,DSKTKT,E=DSKER1                 @SC89250 05850500
         MVC   FABDSMB,44(8) Restore member name               @SC89250 05851000
         L     1,DSKTKT                                        @SC88043 05851500
         MVC   PDSBLK(4),=Y(1,58)   Set count and length       @GH90139 05852000
         MVC   PDSMEMBR,44(8)   Move in member name            @GH90139 05852500
         BLDL  (1),PDSBLK    See if member is there            @GH90139 05853000
         LR    6,15          Save return code                  @SC92022 05853500
         CLOSF DSKTKT        Close it up again                 @SC88043 05854000
         LTR   6,6                                             @SC92022 05854500
         BNZ   DSKER1        Wasn't there                      @SC89250 05855000
DSKTE1   MVC   DSKSTT+FDBD-FABD(FDBINFO),FDBD  Save FDB stuff  @SC89250 05855500
         LA    0,FABDWDS     Release FAB storage               @SC89250 05856000
         LR    1,3                                             @SC89250 05856500
         DMSFRET DWORDS=(0),LOC=(1)                            @SC89250 05857000
         SR    4,4           Mark it gone                      @SC89250 05857500
         LA    3,DSKSTT      Ptr for internal FDB              @SC89250 05858000
         BAL   14,DSKVALS    Fill out FDB                      @SC89250 05858500
         LA    9,FDBD        FDB pointer                       @SC91283 05859000
         RETREG (1,9)  Return FDB ptr in R1                    @SC91283 05859500
         B     RTRN0                                           @SC86299 05860000
*                                                                       05860500
* Close file whose ticket is at (R1), release block                     05861000
DSKCLOS  DS    0H                                              @SC89073 05861500
         ICM   3,15,0(1)     Get FAB ptr, if any               @SC86295 05862000
         BZ    RTRN0         None, ignore                      @SC86295 05862500
         MVI   0(1),X'80'    Flag for normal close             @SC88049 05863000
         LR    2,1           Save ptr                          @SC88049 05863500
         CLOSE MF=(E,(1))    Close it                          @SC88049 05864000
         XC    0(4,2),0(2)   Ok, now clear ticket              @SC88049 05864500
         TM    FABBUFCB+3,1  Any buffers?                      @SC88043 05865000
         BO    DSKFRPZ       No, fine                          @SC88043 05865500
      FREEPOOL (3)                                             @SC86299 05866000
DSKFRPZ  DS    0H            Now free whole FAB                @SC88043 05866500
         LA    0,FABDWDS                                       @SC86295 05867000
         LR    1,3                                             @SC86299 05867500
       DMSFRET DWORDS=(0),LOC=(1)                              @SC86295 05868000
         B     RTRN0                                           @SC86295 05868500
*                                                                       05869000
* TClose file whose ticket is in (R1)                          @SC88168 05869500
DSKTCLOS ST    1,DSKTKT                                        @SC88168 05870000
         MVI   DSKTKT,X'80'  Flag for normal close             @SC88168 05870500
         CLOSE MF=(E,DSKTKT),TYPE=T                            @SC88168 05871000
         B     RTRN0                                           @SC88168 05871500
*                                                                       05872000
* Read from file whose ticket is at (R1)                                05872500
DSKRED   DS    0H                                              @SC89073 05873000
         LTR   3,1           Get FAB ptr                       @SC86299 05873500
         BNP   RTRN1         Not defined anymore               @SC86299 05874000
         L     15,FABGET     I/O routine                       @SC86299 05874500
         BALR  14,15         Go to it                          @SC86299 05875000
         LM    14,15,FDBBUFF Get buffer and size               @SC92022 05875500
         LH    7,FABLRECL    Actual length                     @SC86299 05876000
         LR    0,7           Save length for number check      @SC88101 05876500
         AR    7,1           End of record                     @SC86299 05877000
         BAL   2,DSKTV                                         @SC86299 05877500
          LA   1,4(1)        Skip over SDW if V                @SC86299 05878000
         CLI   DSKCOD,0      NONUM?                            @SC88101 05878500
         BNE   DSKREDC       No, use everything                @SC88101 05879000
         CLI   FDBRCF,C'F'   Fixed-length records?             @SC88101 05879500
         BNE   DSKREDV       No, line numbers at start (if any)@SC88101 05880000
         CH    0,=H'80'      See if F/80                       @SC88101 05880500
         BNE   DSKREDC       No                                @SC88101 05881000
         MVZ   DSKMNTH(5),75(1)  See if 76-80 are all numeric  @SC90213 05881500
         CLC   DSKMNTH(5),=8C'0' (DSKMNTH was cleared: LOCAL)  @SC90213 05882000
         BNE   DSKREDC       No                                @SC88101 05882500
         S     7,F8          Yes, move the end back            @SC88101 05883000
         B     DSKREDC                                         @SC88101 05883500
DSKREDV  LA    0,8(1)        Is length at least 8?             @SC88101 05884000
         CR    0,7                                             @SC88101 05884500
         BNL   DSKREDC       No, can't be numbered             @SC88101 05885000
         MVZ   DSKMNTH(8),0(1)   See if 1-8 all numeric        @SC90213 05885500
         CLC   DSKMNTH(8),=8C'0' (DSKMNTH was cleared: LOCAL)  @SC90213 05886000
         BNE   DSKREDC       No, not numbered                  @SC88101 05886500
         LA    1,8(1)        Yes, skip over number             @SC88101 05887000
DSKREDC  DS    0H                                              @SC88101 05887500
         SR    7,1           Revised length                    @SC86299 05888000
         LR    6,1                                             @SC86299 05888500
         CR    7,15                                            @SC92022 05889000
         BNL   *+6                                             @SC86299 05889500
          LR   15,7          Buffer not filled                 @SC92022 05890000
         L     1,4(13)                                         @SC86299 05890500
         ST    15,20(,1)     Return length in R0               @SC92022 05891000
         CLI   DSKCOD,0      NONUM?                            @SC88101 05891500
         BNE   *+8                                             @SC88101 05892000
          ST   14,24(,1)     Yes, return R1 ptr                @SC92022 05892500
         MVCL  14,6          Copy to buffer                    @SC92022 05893000
         B     RTRN0                                           @SC86299 05893500
* End of file on input. Don't close it yet.                    @SC86295 05894000
DSKEOD   LA    15,12         End return code                   @SC86295 05894500
         B     RTRN                                            @SC86295 05895000
*                                                                       05895500
* Write to file whose ticket is at (R1)                                 05896000
DSKWRT   DS    0H                                              @SC89073 05896500
         LTR   3,1           Get FAB ptr                       @SC86299 05897000
         BNP   RTRN1         Not defined anymore               @SC86299 05897500
         LM    8,9,FDBBUFF   Get buffer and size               @SC92022 05898000
DSKWR1   LR    6,9           Copy for LRECL                    @SC92022 05898500
         BAL   2,DSKTV                                         @SC86299 05899000
          LA   6,4(,9)       + 4 if RECFM=V                    @SC92022 05899500
         STH   6,FABLRECL    Set up for output                 @SC86299 05900000
         IC    7,ERRNUM      Save previous error code, if any  @SC88139 05900500
         MVI   ERRNUM,0      Clear error number                @SC86299 05901000
         L     15,FABGET     I/O routine                       @SC86299 05901500
         BALR  14,15         Do it                             @SC86299 05902000
         SR    15,15                                           @SC86299 05902500
         ICM   15,1,ERRNUM   See if deadly error               @SC86299 05903000
         BNZ   RTRN          Yes, pass return code             @SC86299 05903500
         STC   7,ERRNUM      Restore previous error code       @SC88139 05904000
         TM    FABRECFM,FABRECU  Check if V                    @SC91283 05904500
         BNM   DSKWR2        No, U                             @SC91283 05905000
         TM    FABRECFM,FABRECF                                @SC91283 05905500
         BO    DSKWR2        No, F                             @SC91283 05906000
         XC    0(4,1),0(1)                                     @SC86299 05906500
         STCM  6,3,0(1)      In case V                         @SC86299 05907000
          LA   1,4(1)        V: space over SDW                 @SC86299 05907500
DSKWR2   DS    0H                                              @SC91283 05908000
         LR    6,1                                             @SC86299 05908500
         LR    7,9                                             @SC92022 05909000
         MVCL  6,8           Copy to output record             @SC92022 05909500
         B     RTRN0                                           @SC86295 05910000
*                                                                       05910500
* Point past 1st N records of file at (R1)                     @SC89218 05911000
DSKPNT   ICM   3,15,0(1)     Get ticket                        @SC89218 05911500
         BZ    RTRN1         Not open                          @SC89218 05912000
         LR    3,1                                             @SC89218 05912500
         LTR   2,2           Number of records to skip         @SC89218 05913000
         BNP   RTRN0         Never mind                        @SC89218 05913500
DSKPNTL  READF 0(,3),E=RTRN1 Skip one                          @SC89218 05914000
         BCT   2,DSKPNTL     ... until finished                @SC89218 05914500
         B     RTRN0         Return with completion code       @SC89218 05915000
*                                                                       05915500
* Analyze error: packed dec. code in TMPDW                              05916000
DSKXXX   DS    0H                                              @SC89073 05916500
         MVI   ERRNUM,ERRDIE Set Kermit error code             @SC87338 05917000
         L     2,EMSGP       Ptr to msg buffer                 @SC87338 05917500
         CLC   =C'  ',0(2)   Proper SYNAD message?             @SC87338 05918000
         BE    *+10          Yes, ok                           @SC87338 05918500
         XC    EMSGL,EMSGL   No, clear length                  @SC87338 05919000
         B     RTRN1                                           @SC87338 05919500
*                                                                       05920000
* Disk utility for file(s) at (R1) and (R2)                             05920500
DSKUTL   LR    8,0           Save code-12                      @SC86316 05921000
         MVC   DSKPSAV(8),DESTL+1 Save Kermit prefix           @SC88043 05921500
         L     14,ORGR1      Find User prefix                  @SC88043 05922000
         USING CPPL,14                                         @SC88043 05922500
         L     14,CPPLUPT                                      @SC88043 05923000
         USING UPT,14                                          @SC88043 05923500
         MVC   DESTL+1(1),UPTPREFL Use that for now            @SC88043 05924000
         MVC   DEST(7),UPTPREFX                                @SC88043 05924500
         DROP  14                                              @SC88043 05925000
         SH    0,=H'13'      Code-13: DIR,DEL,REN,COP          @SC89073 05925500
         SLA   0,3                                             @SC86295 05926000
         LA    14,DSKCMDS                                      @SC92022 05926500
         AR    14,0          Ptr to command name               @SC92022 05927000
         LA    7,CMD         Buffer for system command         @SC86299 05927500
         MVC   0(8,7),0(14)                                    @SC92022 05928000
         LA    7,8(7)                                          @SC86299 05928500
         LTR   0,0           Was it DIR?                       @SC88043 05929000
         BNZ   DSKUTP        No, use filespec(s) as is         @SC88043 05929500
         MVC   0(4,7),=C'LVL(' Yes, maybe need an option       @SC88043 05930000
         MVC   4(44,7),0(1)  If so, need whole filespec        @SC88043 05930500
         LA    0,4(7)                                          @SC88043 05931000
         LA    1,44                                            @SC88043 05931500
         LA    14,DEST       Comparand is user prefix          @SC88043 05932000
         LH    15,DESTL                                        @SC88043 05932500
         ICM   15,8,BLANK    Extended with blanks              @SC88043 05933000
         CLCL  0,14                                            @SC88043 05933500
         BE    DSKUTX        Just that - no options            @SC88043 05934000
         LA    1,4+44(7)                                       @SC88043 05934500
         TRT   4(44,7),TRTBL Find end of filespec              @SC88043 05935000
         MVI   0(1),C')'     And complete the syntax           @SC88043 05935500
         LA    7,1(1)        End of command string             @SC88043 05936000
         B     DSKUTX        Do it                             @SC88043 05936500
DSKUTP   DS    0H            Other utilities...                @SC88043 05937000
         BAL   3,DSKUTCP                                       @SC86295 05937500
         SRA   0,4                                             @SC86295 05938000
         BZ    *+10                                            @SC86295 05938500
         LR    1,2           2nd file                          @SC86295 05939000
         BAL   3,DSKUTCP                                       @SC86295 05939500
DSKUTX   MVC   DESTL+1(8),DSKPSAV Restore Kermit prefix        @SC88043 05940000
         LA    0,CMD                                           @SC86295 05940500
         LR    6,7                                             @SC86299 05941000
         SR    6,0                                             @SC86299 05941500
         NI    FL4,255-UCMD  Not user command: adr=(0),len=(6) @SC86295 05942000
         KCALL SUPFNC,3      Execute it                        @SC86295 05942500
         B     RTRN                                            @SC86295 05943000
*                                                                       05943500
DSKUTCP  LR    4,0           Save ID                           @SC86299 05944000
         LA    0,FFDSP                                         @SC86299 05944500
         KCALL FSPEC                                           @SC86299 05945000
         MVI   0(15),C' '                                      @SC86299 05945500
         LA    7,1(15)       New output ptr                    @SC86299 05946000
         LR    0,4                                             @SC86299 05946500
         BR    3                                               @SC86295 05947000
*                                                                       05947500
DSKCMDS  DC    C'LISTCAT '   Utility command names             @SC86299 05948000
         DC    C'DELETE  '                                     @SC86299 05948500
         DC    C'RENAME  '                                     @SC86299 05949000
         DC    C'COPY    '                                     @SC86299 05949500
*                                                                       05950000
DSKTV    TM    FABRECFM,FABRECU                                @SC86299 05950500
         BNM   4(2)          U                                 @SC86299 05951000
         TM    FABRECFM,FABRECF                                @SC86299 05951500
         BO    4(2)          F                                 @SC86299 05952000
         BR    2             V                                 @SC86299 05952500
* Check PDS notation -- must match DSORG.  Return via R14               05953000
DSKTCON  TM    DS1DSO,2      Partitioned?                      @SC88119 05953500
         BO    DSKTCOP       Yes, insist on member name        @SC88119 05954000
         CLI   FABDSMB,C' '  Member name?                      @SC88119 05954500
         BER   14            No, ok                            @SC88119 05955000
         B     DSKER1                                          @SC88119 05955500
DSKTCOP  CLI   FABDSMB,C' '  Member name?                      @SC88119 05956000
         BNER  14            Yes, ok                           @SC88119 05956500
         CLI   FABDSMB+1,0   No, but maybe just want directory?@SC88119 05957000
         BER   14            Yes, ok                           @SC88119 05957500
* Return on error, release useless block, if any                        05958000
DSKER1   LTR   1,4           Any block assigned?               @SC86295 05958500
         BZ    RTRN1         No                                @SC86295 05959000
         LA    0,FABDWDS     Yes, release it                   @SC86295 05959500
       DMSFRET DWORDS=(0),LOC=(1)                              @SC86295 05960000
         B     RTRN1         Flag error                        @SC86295 05960500
*                                                                       05961000
DSKERAL  L     1,DFMSGP      Ptr to DAIRFAIL buffer            @SC88119 05961500
         SR    9,9                                             @SC88119 05962000
         ICM   9,3,0(1)      Length of message                 @SC88119 05962500
         BZ    DSKER1        None (why not?)                   @SC88119 05963000
         LA    8,4(1)        Start of text                     @SC88119 05963500
         CLC   =C'IKJ',0(8)  Has msg id?                       @SC88119 05964000
         BNE   *+8                                             @SC88119 05964500
          LA   8,10(8)       Yes, skip it                      @SC88119 05965000
         S     8,F2                                            @SC88119 05965500
         MVC   0(2,8),=C'  ' Make it begin with two blanks     @SC88119 05966000
         AR    9,1           End of message                    @SC88119 05966500
         SR    9,8           Length to use                     @SC88119 05967000
DSKERMSG L     6,EMSGP       Explanation buffer                @SC89250 05967500
         LA    7,LEMSG       Length of same                    @SC88119 05968000
         CR    7,9                                             @SC88119 05968500
         BNH   *+6                                             @SC88119 05969000
          LR   7,9           Too long, use what we can         @SC88119 05969500
         ST    7,EMSGL       Usable length                     @SC88119 05970000
         MVCL  6,8           Copy to buffer                    @SC88119 05970500
         B     DSKER1                                          @SC88119 05971000
*                                                                       05971500
* Allocate FAB.  Enter with R1->FDB pattern, R2->DSN           @SC92022 05972000
* Clobber 0,1,2,15.  Set R3,R4->new FAB, R6->pattern.          @SC92022 05972500
* Return via R9.                                               @SC92022 05973000
DSKALC   DS    0H                                              @SC92022 05973500
         LA    6,1           Update counter                    @SC86299 05974000
         A     6,EVCTR                                         @SC86299 05974500
         ST    6,EVCTR                                         @SC86299 05975000
         LR    6,1           Save FDB ptr                      @SC92022 05975500
         LA    0,FABDWDS                                       @SC86295 05976000
       DMSFREE DWORDS=(0),ERR=DSKER1                           @SC86295 05976500
         LR    3,1           New block ptr                     @SC86295 05977000
         ST    3,DSKOPLS     Save for OPEN plist               @SC88049 05977500
         MVI   DYNDSP,X'88'  SHR,KEEP                          @SC86299 05978000
         MVI   DSKOPLS,X'80' Code for OPEN INPUT               @SC88049 05978500
         LR    4,3           Indicate we have it               @SC88120 05979000
         XC    0(8*FABDWDS,3),0(3)                             @SC86295 05979500
         MVC   FDBD(FDBCOP),0(6) Copy user's FDB               @SC92022 05980000
         MVC   FABDSN,0(2)                                     @SC86299 05980500
         LA    15,FABDSN     Set up DSN ptr                    @SC86299 05981000
         LA    0,FABDDNAM    Get DDN ptr                       @SC86299 05981500
         LA    1,FDBUNT      Get UNIT ptr                      @SC86299 05982000
         LA    2,FDBVOL      Get VOL ptr                       @SC86299 05982500
         STM   15,2,DYNPL    Set up DYNALC                     @SC86299 05983000
         MVI   FABBUFCB+3,1  Fill out DCB                      @SC86299 05983500
         MVI   FABDSORG,X'40' =PS                              @SC86299 05984000
         MVI   FABMACR,X'48' MACRF=GL                          @SC88043 05984500
         CLI   FABDSMB,0     Special case of PDS?              @SC88119 05985000
         BNE   *+16          No                                @SC88043 05985500
         MVI   FABDSORG,X'02' Yes, set DSORG=PO                @SC86299 05986000
         MVI   FABMACR,X'24' ... and MACRF=R                   @SC88043 05986500
         MVI   FABDSMB,C' '  and blot out member               @SC88119 05987000
         MVC   FABMACR+1(1),FABMACR                            @SC88043 05987500
         MVI   FABIOBAD+3,1                                    @SC86299 05988000
         LA    0,DSKEOD                                        @SC86299 05988500
         LA    1,FABEXL      Modifiable exit list              @SC89073 05989000
         MVC   4(8,1),DSKOPEX Copy usual stuff into it         @SC89073 05989500
         STM   0,1,FABEODAD                                    @SC86299 05990000
         UNPK  FABDDNAM,EVCTR(5)                               @SC86299 05990500
         TR    FABDDNAM,TRHEX  Get unique DDNAME               @SC86299 05991000
         MVI   FABDDNAM,C'K'                                   @SC86299 05991500
         MVI   FABDDNAM+7,C'Z'                                 @SC86299 05992000
         MVI   FABOFLGS,2    Not open yet                      @SC88043 05992500
         MVI   FABCHECK+3,1                                    @SC86299 05993000
         LA    1,DSKSYN                                        @SC87338 05993500
         ST    1,FABSYNAD    In case of error                  @SC86299 05994000
         MVI   FABIOBA+3,1                                     @SC86299 05994500
         MVC   FABEOBAD(16),FABIOBA                            @SC87314 05995000
         MVI   FABEOB+3,1                                      @SC86299 05995500
DSKFABS  LH    1,FDBBLKSI    Copy Info to DCB                  @SC88120 05996000
         STH   1,FABBLKSI                                      @SC88120 05996500
         STH   1,FABLRECL                                      @SC86299 05997000
         MVI   FABRECFM,FABRECU                                @SC86299 05997500
         CLI   FDBRCF,C'U'                                     @SC86299 05998000
         BE    DSKFABCC                                        @SC88246 05998500
         MVC   FABLRECL,FDBLRC Use true LRECL after all        @SC88120 05999000
         MVI   FABRECFM,FABRECF+FABRECBR                       @SC86299 05999500
         CLI   FDBRCF,C'F'                                     @SC86299 06000000
         BE    DSKFABCC                                        @SC88246 06000500
         MVI   FABRECFM,FABRECV+FABRECBR                       @SC86299 06001000
DSKFABCC XC    FABRECFM,FDBFLGS Copy carriage control flags    @SC88246 06001500
         NI    FABRECFM,255-FABRECCC  And only those flags     @SC88246 06002000
         XC    FABRECFM,FDBFLGS                                @SC88246 06002500
         BR    9                                               @SC86299 06003000
*                                                                       06003500
* Call with R15->name, return to R2 with CC set (Z if ok)               06004000
* Clobbers or sets 0,1,6,7,14,15.  Assumes R3->full FAB        @SC89250 06004500
* Assumes name ptr already stored in DYNPL, in case migrated   @SC89250 06005000
DSKLKP   SR    0,0                                             @SC86299 06005500
         LA    1,CAMVOLS                                       @SC86299 06006000
         LA    14,X'44'      Name code                         @SC86299 06006500
         SLL   14,24                                           @SC86299 06007000
         STM   14,1,CAMLOC   Save dsn ptr, etc                 @SC86299 06007500
         LA    0,CAMVOLS+6                                     @SC86299 06008000
         LA    1,CAMDSCB                                       @SC86299 06008500
         LA    14,X'C1'      Search code                       @SC86299 06009000
         SLL   14,24                                           @SC86299 06009500
         STM   14,1,CAMOBT                                     @SC86299 06010000
         LA    7,1           Flag for 1st pass                 @SC89250 06010500
DSKLKPL  DS    0H                                              @SC89250 06011000
         MVC   CAMVOLS(2),F0 Clear volume count                @SC92147 06011500
        LOCATE CAMLOC                                          @SC86299 06012000
         LTR   6,15          Retain 1st code in R6             @SC86299 06012500
         BZ    DSKLKPCT      Cataloged ok                      @SC90275 06013000
         CLI   FDBVOL,C' '   Not cataloged, any volume given?  @SC90275 06013500
         BE    DSKLKPNF      No, can't find it                 @SC90275 06014000
         MVC   CAMVOLS+6(6),FDBVOL  Try default volume         @SC88342 06014500
         LA    0,=C'SYSALLDA' and insist on catchall UNIT      @SC88342 06015000
         ST    0,DYNPL+8      for DYNALC                       @SC90275 06015500
         OBTAIN CAMOBT       Get DSCB if on given volume       @SC90275 06016000
DSKLKPNF LTR   15,15         Non-zero return code => not found @SC90275 06016500
         BR    2                                               @SC90275 06017000
DSKLKPCT DS    0H            Cataloged dataset                 @SC90275 06017500
         LA    15,1                                            @SC92147 06018000
         CLC   CAMVOLS(2),F0 Any volume list returned?         @SC92147 06018500
         BE    DSKLKPNF      No, must be GDG name (+n)         @SC92147 06019000
        OBTAIN CAMOBT        Get DSCB                          @SC86299 06019500
         LA    0,=C' '       Cataloged, don't specify          @SC88342 06020000
         LR    1,0                                             @SC88342 06020500
         STM   0,1,DYNPL+8                                     @SC88342 06021000
         LTR   15,15         Test return code                  @SC89250 06021500
         BZR   2             Ok, file was found                @SC89250 06022000
         BCT   7,DSKLKPZ     Quit if already tried recall      @SC89250 06022500
         TM    FL2,PROTO     Transfer/server mode in progress? @SC89250 06023000
*        BO    DSKLKPZ       Quit if in protocol mode          @SC89250 06023500
         CLC   =C'MIGRAT',CAMVOLS+6                            @SC89250 06024000
         BNE   DSKLKPZ       Quit if volume not MIGRAT         @SC89250 06024500
         L     6,DYNPL       Get ptr to name again             @SC89250 06025000
         MVC   LKPMEM,44(6)  Save member name, if any          @SC89250 06025500
         MVI   44(6),C' '    And blank it out                  @SC89250 06026000
         KCALL DYNALC,DYNPL,EXT  Set up DD                     @SC89250 06026500
         MVC   44(8,6),LKPMEM Restore member name              @SC89250 06027000
         CLI   DYNRC+3,0                                       @SC89250 06027500
         BNE   DSKER1        Quit if failed                    @SC89250 06028000
         OPEN  MF=(E,DSKOPLS) Open (and wait for recall)       @SC89250 06028500
         CLOSE MF=(E,DSKOPLS) Don't use, just close it         @SC89250 06029000
         TM    FABBUFCB+3,1                                    @SC89250 06029500
         BO    DSKLKPL       No buffers, all set               @SC89250 06030000
         FREEPOOL (3)        Free buffers first                @SC89250 06030500
         B     DSKLKPL       Try all over again to LOCATE      @SC89250 06031000
*                                                                       06031500
DSKLKPZ  PTEXT '&MIGRATD',AREG=8,LREG=9                        @SC89250 06032000
         B     DSKERMSG      Copy msg to buffer                @SC89250 06032500
*                                                                       06033000
* Handle synchronous disk I/O errors                                    06033500
DSKSYN   SYNADAF ACSMETH=QSAM Get system to do the work        @SC87338 06034000
         L     2,EMSGP       Ptr to msg buffer                 @SC87338 06034500
         MVC   0(80,2),48(1) Copy message (inc. 2 blanks)      @SC87338 06035000
         LA    2,80                                            @SC87338 06035500
         ST    2,EMSGL       Length of string                  @SC87338 06036000
         SYNADRLS            Clean up                          @SC87338 06036500
         B     RTRN1                                           @SC87338 06037000
*                                                                       06037500
* Set up search through list of files, pattern at (R1)                  06038000
DSKNSET  DS    0H                                              @SC89073 06038500
         MVI   CIROPT,2      Get full names                    @SC87015 06039000
         L     3,CIRWA       Initialize length ptrs            @SC87015 06039500
         MVC   0(4,3),CIRWAL                                   @SC87015 06040000
         NI    DSKFL,255-WFN-NXDON                             @SC87015 06040500
         MVC   NXFN,0(1)     Copy name                         @SC87015 06041000
         LA    1,NXFN+52     End of member slot                @SC88096 06041500
         TRT   NXFN+44(8),TRTBL Find end of member name        @SC88096 06042000
         LR    7,1           Save ptr                          @SC92022 06042500
         LA    1,NXFN+44                                       @SC87015 06043000
         TRT   NXFN(44),TRTBL                                  @SC87015 06043500
         LR    3,1           End of name                       @SC87015 06044000
         MVI   TRTBL+C'*',1                                    @SC87015 06044500
         LA    0,NXFN                                          @SC88096 06045000
         LA    9,DSKNDIR     Where to go if no "*" in DSN      @SC88096 06045500
         LA    14,DSKNCIR    Where to go if "*" found          @SC88096 06046000
         TRT   NXFN(44),TRTBL Check for wild card              @SC87015 06046500
DSKNSW   BZR   9             Len=max, just use the one file    @SC88096 06047000
         CLI   0(1),C'*'     Did we find an asterisk           @SC87015 06047500
         BNER  9             No, just the end of the name      @SC88096 06048000
         MVI   TRTBL+C'*',0                                    @SC88096 06048500
         OI    DSKFL,WFN     Mark it wild                      @SC87015 06049000
         LA    4,1(1)                                          @SC87015 06049500
         ST    4,NXSFPTR     Save ptr to suffix                @SC87015 06050000
         SR    3,4                                             @SC87015 06050500
         STH   3,DSNSFL      and length                        @SC87015 06051000
         SR    1,0                                             @SC87015 06051500
         STH   1,DSNPFL      Length of prefix                  @SC87015 06052000
         BR    14            Now get name list                 @SC88096 06052500
DSKNCIR  CLI   NXFN+44,C' '  Insist no members if wild DSN     @SC88096 06053000
         BNE   RTRN1                                           @SC88096 06053500
         AR    1,0           End of prefix string              @SC88096 06054000
DSKNPLP  BCTR  1,0           Scan back for a dot               @SC88096 06054500
         CR    1,0           Must be one, else we scan universe@SC88096 06055000
         BNH   RTRN1         None there, give up               @SC88096 06055500
         CLI   0(1),C'.'                                       @SC88096 06056000
         BNE   DSKNPLP       Keep looking                      @SC88096 06056500
         SR    1,0           Count of bytes in whole qualifiers@SC88096 06057000
         L     14,CIRSRCH    Argument ptr                      @SC87015 06057500
         LA    15,44                                           @SC87015 06058000
         ICM   1,8,BLANK                                       @SC87015 06058500
         MVCL  14,0          Copy with blank fill              @SC87015 06059000
         LINK  EP=IKJEHCIR,MF=(E,CIRPARM) Call catalog routine @NW86330 06059500
         LTR   15,15                                           @SC87015 06060000
         BNZ   RTRN1         Not found                         @SC87015 06060500
         LA    1,45-4        Skip count bytes, then back one   @SC88096 06061000
DSKNRET  L     2,CIRWA       ADR OF RETURNED CATALOG BUFFER    @SC88096 06061500
         SR    2,1           Back up one item                  @SC88096 06062000
         ST    2,CATDSPTR    Save ptr to buffer                @NW86330 06062500
         B     RTRN0                                           @SC86295 06063000
*                                                                       06063500
DSKNDIR  LR    3,7           Use end of member name            @SC92022 06064000
         LA    0,NXFN+44     Start of member                   @SC88096 06064500
         LA    9,RTRN0       Where to go if not wild           @SC88096 06065000
         TRT   NXFN+44(8),TRTBL Find any '*'                   @SC88096 06065500
         MVI   TRTBL+C'*',0  Now restore table                 @SC88096 06066000
         BAL   14,DSKNSW     Return here if '*' found          @SC88096 06066500
         SR    4,4           Clear FAB ptr                     @SC88096 06067000
         LA    1,DSKDPAT     Sample DCB info                   @SC88096 06067500
         LA    2,CAMVOLS     Reuse this area for the DSN       @SC88096 06068000
         MVC   0(44,2),NXFN  Copy DSN                          @SC88096 06068500
         MVI   44(2),C' '    And blank out member              @SC88096 06069000
         BAL   9,DSKALC      Get a DCB (FAB)                   @SC88096 06069500
         BAL   2,DSKLKP      Get DSCB                          @SC88096 06070000
         BNZ   DSKER1        Not found                         @SC89317 06070500
         TM    DS1DSO,2      Is it really a PDS?               @SC88096 06071000
         BZ    DSKER1        No, give up                       @SC89317 06071500
         KCALL DYNALC,DYNPL,EXT Allocate file                  @SC88096 06072000
         OPEN  MF=(E,DSKOPLS)   And open it to the directory   @SC88096 06072500
         TM    FABOFLGS,X'10'   Ok?                            @SC88096 06073000
         BZ    DSKER1        Too bad                           @SC88096 06073500
         ST    4,DSKTKT      Save ptr to FAB                   @SC88096 06074000
         L     2,CIRWA       Start of name buffer              @SC88096 06074500
         LH    9,CIRWAL      Length                            @SC88096 06075000
         AR    9,2           End of buffer                     @SC88096 06075500
         S     9,FDBBSIZ     Back up one block                 @SC88096 06076000
DSKDL1   READF DSKTKT,BUFFER=(2),E=DSKDLZ Read a block         @SC88096 06076500
         SR    7,7                                             @SC88096 06077000
         ICM   7,3,0(2)      Get length of block info          @SC88096 06077500
         AR    7,2           End of block                      @SC88096 06078000
         BCTR  7,0           Set up BXLE                       @SC88096 06078500
         LA    8,2(2)        Point to member info              @SC88096 06079000
DSKDL2   CLC   0(8,8),=8X'FF' End of directory?                @SC88096 06079500
         BE    DSKDLZ        Yes, all done                     @SC88096 06080000
         TM    11(8),X'80'   Alias member?                     @SC88096 06080500
         BO    DSKDL3        Yes, ignore it                    @SC88096 06081000
         MVI   0(2),C'A'     Create table entry                @SC88096 06081500
         MVC   1(8,2),0(8)   with member name                  @SC88096 06082000
         LA    2,9(2)                                          @SC88096 06082500
DSKDL3   IC    6,11(8)       Get entry length                  @SC88096 06083000
         N     6,=F'31'                                        @SC88096 06083500
         LA    6,12(6,6)     In bytes                          @SC88096 06084000
         BXLE  8,6,DSKDL2    On to next member                 @SC88096 06084500
         CR    2,9           Room for another block in table?  @SC88096 06085000
         BNH   DSKDL1        Ok                                @SC88096 06085500
DSKDLZ   MVI   0(2),0        End of table                      @SC88096 06086000
         CLOSF DSKTKT        Release the file                  @SC88096 06086500
         C     2,CIRWA       Did we find anything?             @SC88096 06087000
         BE    RTRN1         No??                              @SC88096 06087500
         LA    1,9           Length of entries                 @SC88096 06088000
         B     DSKNRET       Go init. ptr into table           @SC88096 06088500
DSKDPAT  DC    A(0,256),C'F',X'0',H'256,0,0,256'               @SC88096 06089000
*                                                                       06089500
* Flush previous file pattern                                           06090000
DSKXSET  DS    0H                                              @SC89073 06090500
         OI    DSKFL,NXDON                                     @SC87015 06091000
         B     RTRN0                                           @SC87015 06091500
*                                                                       06092000
* Check CWD string, return code in R15                                  06092500
DSKCWDF  DS    0H                                              @SC89073 06093000
         SR    4,4           Clear FAB ptr                     @SC91283 06093500
         LR    2,1           Temp name ptr                     @SC91283 06094000
         LA    1,DSKDPAT     Sample DCB info                   @SC91283 06094500
         BAL   9,DSKALC      Get a DCB (FAB)                   @SC91283 06095000
         BAL   2,DSKLKP      Check name                        @SC87015 06095500
         BNZ   DSKCWDZ       No conflict, assume valid         @SC91283 06096000
         TM    DS1DSO,2      Was a full DSN, check DSORG       @SC88054 06096500
         BO    DSKCWD1       It's a PDS -- see if it matches   @SC88054 06097000
         CLI   FABDSMB,C'.'  PDS requested?                    @SC91283 06097500
         BE    DSKER1        Yes, but file not found           @SC91283 06098000
         B     DSKCWDZ                                         @SC91283 06098500
DSKCWD1  CLI   FABDSMB,C'.'  PDS requested?                    @SC91283 06099000
         BNE   DSKER1        No, but file was found            @SC91283 06099500
DSKCWDZ  B     DSKFRPZ       Yes, ok                           @SC91283 06100000
*                                                                       06100500
* Check disk space for proposed file: FDB at (R1), FAB ptr at (R6)      06101000
DSKTSP   DS    0H                                              @SC89073 06101500
* - - - get size of available space in R0,R1                   @SC87015 06102000
         LA    0,1023        For now, claim 4 Tbyte            @SC87015 06102500
         SRDA  0,10          Convert to Kbytes                 @SC86316 06103000
         CLR   1,2                                             @SC87012 06103500
         BL    RTRN1         No room                           @SC86316 06104000
         B     RTRN0         Ok                                @SC86316 06104500
*                                                                       06105000
* Check against prefix and suffix criteria and return next match,       06105500
*   if any                                                              06106000
* Also return info in a File Descriptor Block                  @SC86151 06106500
DSKNXT   DS    0H                                              @SC89073 06107000
         TM    DSKFL,NXDON                                     @SC87015 06107500
         BO    RTRN1         Nothing more                      @SC87015 06108000
         MVC   FILNAM,NXFN                                     @SC87015 06108500
         TM    DSKFL,WFN     Are we scanning?                  @SC87015 06109000
         BO    NXFBEG        Yes, do it                        @SC87015 06109500
         OI    DSKFL,NXDON   No, that's the only one           @SC87015 06110000
         LA    2,FILNAM                                        @SC87015 06110500
         B     DSKTEST       Now return file info              @SC89157 06111000
NXFBEG   L     6,CATDSPTR    Ptr to place in catalog           @NW86330 06111500
         USING CATDSET,6                                       @NW86330 06112000
         LA    7,NXFN+44     Start of member                   @SC88096 06112500
         LA    8,8-1         Length of member name             @SC88096 06113000
         C     7,NXSFPTR     Is suffix part of member name?    @SC88096 06113500
         BL    *+12          Yes, we're set                    @SC88096 06114000
          LA   7,NXFN        No, use start of DSN              @SC88096 06114500
          LA   8,44-1        and length                        @SC88096 06115000
NXFDS    LA    6,2(8,6)      Next                              @SC88096 06115500
         CLI   TYPEBYTE,C'A'                                   @NW86330 06116000
         BNE   NXFZ          Assume end of list                @SC87015 06116500
         LH    2,DSNPFL      Get prefix length                 @SC87015 06117000
         LTR   2,2                                             @NW86330 06117500
         BNP   XL0092                                          @NW86330 06118000
         LR    14,7          Compare saved prefix              @SC88096 06118500
         LA    3,CATDNAME     against this name                @SC87015 06119000
         LA    9,0(2,3)      End of possible match             @SC92022 06119500
         BCTR  2,0           Set up for CLC                    @SC87015 06120000
         EX    2,NXFCMP                                        @SC87015 06120500
         BNE   NXFDS         No match                          @SC87015 06121000
XL0092   CLC   DSNSFL,F0                                       @SC87015 06121500
         BNH   XL0002        Don't check suffix                @NW86330 06122000
         LA    1,1(8,3)      Limit of name field               @SC88096 06122500
         EX    8,NXFTRT      Find end of name                  @SC88096 06123000
         LR    3,1                                             @SC87015 06123500
         LH    4,DSNSFL                                        @SC87015 06124000
         SR    3,4           Ptr to start of suffix            @SC87015 06124500
         CR    3,9                                             @SC92022 06125000
         BL    NXFDS         Shorter than prefix+suffix        @SC88096 06125500
         BCTR  4,0                                             @SC87015 06126000
         L     14,NXSFPTR    Ptr to comparison suffix          @SC87015 06126500
         EX    4,NXFCMP                                        @SC87015 06127000
         BNE   NXFDS         No match                          @SC87015 06127500
XL0002   SH    7,=Y(NXFN-FILNAM)  Transpose into FILNAM        @SC88096 06128000
         EX    8,NXFCOP      Copy DSN (or member)              @SC88096 06128500
         ST    6,CATDSPTR    Save ptr for next time            @NW86330 06129000
         LA    2,FILNAM                                        @SC87015 06129500
         B     DSKTEST       Now return file info              @SC89157 06130000
*                                                                       06130500
NXFCMP   CLC   0(,3),0(14)                                     @SC87015 06131000
NXFTRT   TRT   0(,3),TRTBL   Find end of name                  @SC88096 06131500
NXFCOP   MVC   0(,7),CATDNAME Copy name                        @SC88096 06132000
*                                                                       06132500
NXFZ     OI    DSKFL,NXDON                                     @SC87015 06133000
         B     RTRN1         Ran out of names                  @SC87015 06133500
*                                                                       06134000
* Clobbers any registers, returns via 14                       @SC90139 06134500
DSKVALS  DS    0H                                              @SC92170 06135000
         NI    FDBFLGS,255-PDSF                                @SC87015 06135500
         TM    DS1DSO,2      ORG=PO?                           @SC87015 06136000
         BZ    DSKNOPDS      No                                @GH90139 06136500
         OI    FDBFLGS,PDSF  Yes, it's a PDS                   @SC87015 06137000
         IC    15,PDSINDIC   Get indicator                     @GH90139 06137500
         N     15,=X'0000001F'  Isolate last 5 bits            @GH90139 06138000
         BZ    DSKNOPDS      No user data in directory         @GH90139 06138500
         CH    15,=H'15'     Enough user data?                 @GH90139 06139000
         BNE   DSKNOPDS      No - use date/time from DSCB      @GH90139 06139500
         TM    PDSINDIC,X'60'   TTRs in user data area?        @GH90139 06140000
         BNZ   DSKNOPDS      Yes - can't handle load modules   @GH90139 06140500
         CLI   ISPFMDTM,X'23' Is hour plausible?               @SC90139 06141000
         BH    DSKNOPDS      No - use DSCB date                @SC90139 06141500
         CLI   ISPFMDTM+1,X'59' Is minute plausible?           @SC90139 06142000
         BH    DSKNOPDS      No - use DSCB date                @SC90139 06142500
         TRT   ISPFMDTM,DSKPMSK Valid decimal time?            @SC90139 06143000
         BNZ   DSKNOPDS      No - use DSCB date                @SC90139 06143500
         CLC   ISPFMDDT+2(2),=X'366F' Is day of year plausible?@SC90139 06144000
         BH    DSKNOPDS      No - use DSCB date                @SC90139 06144500
         CLC   ISPFMDDT+2(2),=X'0010' Is day of year plausible?@SC90139 06145000
         BL    DSKNOPDS      No - use DSCB date                @SC90139 06145500
         TM    ISPFMDDT+3,X'08'  Valid sign nybble?            @SC90139 06146000
         BZ    DSKNOPDS      No - use DSCB date                @SC90139 06146500
         NI    ISPFMDDT+3,X'F0'  Remove sign nybble            @SC90139 06147000
         TRT   ISPFMDDT,DSKPMSK Valid decimal date?            @SC90139 06147500
         BNZ   DSKNOPDS      No - use DSCB date                @SC90139 06148000
         OI    ISPFMDDT+3,X'0F' Insert plus sign               @SC90139 06148500
         MVC   FDBDATE+4(2),ISPFMDTM Copy hours, minutes       @GH90139 06149000
         XC    TMPDW,TMPDW                                     @GH90139 06149500
         MVC   TMPDW+4(4),ISPFMDDT  Move modification date     @GH90139 06150000
         CVB   6,TMPDW       Get 00YYDDD in binary             @GH90139 06150500
         SRDA  6,32                                            @GH90139 06151000
         D     6,=F'1000'    Separate YY from DDD              @GH90139 06151500
         STCM  6,B'0011',DS1CRDT+1   Save DDD                  @GH90139 06152000
         STC   7,DS1CRDT     Save YY                           @GH90139 06152500
         LA    15,DS1CRDT    Point to modified creation date   @GH90139 06153000
         B     DSKCRDT       Skip to date conversion           @GH90139 06153500
DSKNOPDS DS    0H                                              @SC90139 06154000
         LA    15,DS1CRDT    Assume creation date to be used   @GH89270 06154500
         CLI   DS1MDDT,99    Is year plausible?                @GH89270 06155000
         BH    DSKCRDT       No - use creation date            @GH89270 06155500
         CLC   DS1MDDT+1(2),=AL2(366) Is day of year plausible?@GH89270 06156000
         BH    DSKCRDT       No - use creation date            @GH89270 06156500
         CLC   DS1MDDT+1(2),=AL2(1)   Is day of year plausible?@GH89270 06157000
         BL    DSKCRDT       No - use creation date            @GH89270 06157500
         CLI   DS1MDTM,X'23' Is hour plausible?                @GH89270 06158000
         BH    DSKCRDT       No - use creation date            @GH89270 06158500
         CLI   DS1MDTM+1,X'59' Is minute plausible?            @GH89270 06159000
         BH    DSKCRDT       No - use creation date            @GH89270 06159500
         TRT   DS1MDTM,DSKPMSK Valid decimal?                  @SC90139 06160000
         BNZ   DSKCRDT       No - use creation date            @SC90139 06160500
         CLC   DS1MDDT,DS1CRDT Is mod date before creation?    @GH89270 06161000
         BL    DSKCRDT       Yes - use creation date           @GH89270 06161500
         CLC   DS1MDDT,DS1RFDT After latest ref?               @GH89270 06162000
         BH    DSKCRDT       Yes - use creation date           @GH89270 06162500
         MVC   FDBDATE+4(2),DS1MDTM Copy hours, minutes        @GH89270 06163000
         LA    15,DS1MDDT    Use modification date             @GH89270 06163500
DSKCRDT  SR    7,7                                             @SC90139 06164000
         IC    7,0(,15)      Get year in binary                @SC90139 06164500
         CLC   0(3,15),F0                                      @SC92181 06165000
         BE    DSKVDATZ      Date field is null, skip it       @SC92181 06165500
         CVD   7,TMPDW                                         @SC87296 06166000
         MVO   FDBDATE+1(2),TMPDW Copy year                    @SC87296 06166500
         ICM   7,3,1(15)     Get day-of-year in binary         @GH89270 06167000
         MVC   DSKMNTH,=AL1(30,31,30,31,31,30,31,30,31,28,31)  @SC86299 06167500
         TM    0(15),3       Check for leap year               @GH89270 06168000
         BNZ   *+8                                             @SC87296 06168500
         MVI   DSKMNTH+9,29  Leap year, change Feb.            @SC86299 06169000
         LA    6,11                                            @SC86299 06169500
         SR    0,0                                             @SC86299 06170000
DSKVMDL  IC    0,DSKMNTH-1(6)                                  @SC86299 06170500
         SR    7,0           Test if passed the right month    @SC86299 06171000
         BNP   DSKVMDM       Got it                            @SC86299 06171500
         BCT   6,DSKVMDL                                       @SC86299 06172000
         SR    0,0           Hit December                      @SC86299 06172500
DSKVMDM  AR    7,0           Get day of month                  @SC86299 06173000
         LCR   6,6                                             @SC86299 06173500
         LA    6,12(6)       Get month                         @SC86299 06174000
         MH    6,=H'100'                                       @SC86299 06174500
         AR    6,7           Combine MMDD                      @SC86299 06175000
         MH    6,=H'10'                                        @SC86299 06175500
         CVD   6,TMPDW                                         @SC86299 06176000
         MVC   FDBDATE+2(2),TMPDW+5                            @SC86299 06176500
         MVI   FDBDATE,X'19' Assume 20th Cent                  @SC86295 06177000
         CLI   FDBDATE+1,X'50'                                 @SC86295 06177500
         BH    *+8           Ok                                @SC86295 06178000
         MVI   FDBDATE,X'20' Must be 21st                      @SC86295 06178500
DSKVDATZ DS    0H                                              @SC92181 06179000
* = = = = = get file size in bytes in R6,R7 - - -                       06179500
         SR    6,6           Return 0 for now (i.e., unknown)  @SC87015 06180000
         SR    7,7                                             @SC87015 06180500
         AL    7,=F'1023'    Round up                          @SC87007 06181000
         BNO   *+8           No overflow                       @SC86239 06181500
         LA    6,1(6)                                          @SC86239 06182000
         SRDA  6,10                                            @SC86239 06182500
         ST    7,FDBSIZE                                       @SC86299 06183000
         MVC   FDBBLKSI,DS1BLK                                 @SC86299 06183500
         MVC   FDBDEVT,CAMDEVT Copy device type                @SC88106 06184000
         MVC   FDBVOL,CAMVOLS+6   Copy volume name             @GH88319 06184500
         XC    FDBFLGS,DS1RCF Copy carriage control flags      @SC88246 06185000
         NI    FDBFLGS,255-FABRECCC  And only those flags      @SC88246 06185500
         XC    FDBFLGS,DS1RCF                                  @SC88246 06186000
         LH    1,DS1BLK      Use BLKSIZE if 'U'                @SC86299 06186500
         MVI   FDBRCF,C'U'                                     @SC86299 06187000
         TM    DS1RCF,FABRECU                                  @SC86299 06187500
         BO    DSKVLR                                          @SC86299 06188000
         LH    1,DS1LRC      Use LRECL if 'F'                  @SC86299 06188500
         MVI   FDBRCF,C'F'                                     @SC86299 06189000
         TM    DS1RCF,FABRECF                                  @SC86299 06189500
         BO    DSKVLR                                          @SC86299 06190000
         MVI   FDBRCF,C'V'                                     @SC86299 06190500
DSKVLR   STH   1,FDBLRC                                        @SC86299 06191000
         L     7,4(13)       Get previous stack frame          @SC88048 06191500
         L     1,4(7)        and the one before                @SC88076 06192000
         CLC   =A(SERVER),16(1) Was the caller SERVER?         @SC89215 06192500
         BE    *+12          Yes, ok                           @SC88076 06193000
          CLC  =A(USNTRF),16(1) No, was it USNTRF?             @SC89215 06193500
          BNER 14            No, don't bother checking TAKE's  @SC88076 06194000
         USING SERVERSV,7    Assume SERVER or USNTRF           @SC88048 06194500
         ICM   0,15,TAKLEV   Any TAKE files open?              @SC88048 06195000
         BNPR  14            No, that's fine                   @SC88048 06195500
         CH    0,=Y(TAKMAX)  Be sure this is valid             @SC88048 06196000
         BNLR  14            Oops, give up                     @SC88048 06196500
DSKVACT  LR    6,0                                             @SC88048 06197000
         SLA   6,2                                             @SC88048 06197500
         L     6,TAKTAB-4(6) Fetch a file ticket               @SC88048 06198000
         CLC   FABDSN,FABDSN-FABD(6) Does the name match?      @SC88048 06198500
         BE    DSKVACS       Yes, this file is in use          @SC88048 06199000
         BCT   0,DSKVACT     No, keep looking                  @SC88048 06199500
         BR    14            No match, that's ok               @SC88048 06200000
DSKVACS  OI    FDBFLGS,FDBACTV Yes, turn on flag               @SC88048 06200500
         DROP  7                                               @SC88048 06201000
         BR    14                                              @SC86299 06201500
*                                                                       06202000
DSKPMSK  DC    10XL16'10101010101'  Mask for valid P bytes     @SC90139 06202500
         DC    96X'01'                                         @SC90139 06203000
*                                                                       06203500
DSKOPEX  DC    0F'0',X'05',AL3(DSKOPC) OPEN EXIT               @SC86299 06204000
         DC    X'91',AL3(DSKABEND)  DCB ABEND exit             @TS86001 06204500
*                                                                       06205000
* Look for x37 abends                                          @TS86001 06205500
DSKABEND MVI   ERRNUM,ERRFUL Assume full                       @SC86355 06206000
         XC    EMSGL,EMSGL   Clear extra message               @SC87338 06206500
         CLC   =X'B370',0(1) B37 abend?                        @TS86001 06207000
         BE    DSKABX        Yes                               @SC86355 06207500
         CLC   =X'D370',0(1) D37 abend?                        @TS86001 06208000
         BE    DSKABX        Yes                               @SC86355 06208500
         CLC   =X'E370',0(1) E37 abend?                        @TS86001 06209000
         BE    DSKABX        Yes                               @SC86355 06209500
* Look for 013 abend                                           @TS86001 06210000
         MVI   ERRNUM,ERRDIE Assume I/O error                  @SC86355 06210500
         CLC   =X'0130',0(1) 013 abend?                        @TS86001 06211000
         BNE   DSKABX        No, assume worst                  @SC86355 06211500
         CLI   2(1),X'14'    Mismatch DSORG?                   @TS86001 06212000
         BNE   *+12          No                                @SC86355 06212500
         MVI   ERRNUM,ERRFNE Yes, member invalid or missing    @SC86355 06213000
         B     DSKABX                                          @SC86355 06213500
         CLI   2(1),X'18'    Unknown member name?              @TS86001 06214000
         BNE   DSKABX        No, assume worst                  @SC86355 06214500
         MVI   ERRNUM,ERRFNF Yes, say "not found"              @SC86355 06215000
DSKABX   MVI   3(1),X'04'    Ignore if possible                @SC86355 06215500
         BR    14            Return                            @TS86001 06216000
*                                                                       06216500
DSKOPC   LR    3,1                                             @SC86299 06217000
         LH    9,FABBLKSI                                      @SC92022 06217500
         LTR   9,9                                             @SC92022 06218000
         BP    *+8                                             @SC86299 06218500
          LH   9,=H'6233'                                      @SC92022 06219000
         LR    6,9                                             @SC92022 06219500
         TM    FABRECFM,FABRECU                                @SC86299 06220000
         BO    DSKOPS                                          @SC86299 06220500
         LH    6,FABLRECL                                      @SC86299 06221000
         BNZ   *+8                                             @SC86299 06221500
         OI    FABRECFM,FABRECV+FABRECBR                       @SC86299 06222000
         LTR   6,6                                             @SC86299 06222500
         BP    DSKOPQ                                          @SC86299 06223000
         LA    6,80                                            @SC86299 06223500
         BAL   2,DSKTV                                         @SC88049 06224000
          LA   6,4(6)        Allow LRECL=84 for VB             @SC88049 06224500
DSKOPQ   TM    FABRECFM,FABRECF                                @SC86299 06225000
         BZ    DSKOPV                                          @SC86299 06225500
         SR    8,8                                             @SC92022 06226000
         DR    8,6                                             @SC92022 06226500
         LTR   9,9                                             @SC92022 06227000
         BP    *+8                                             @SC88104 06227500
          LA   9,1           BLKSIZE was less than LRECL!      @SC92022 06228000
         MR    8,6                                             @SC92022 06228500
         B     DSKOPS                                          @SC86299 06229000
DSKOPV   LA    4,4(6)                                          @SC86299 06229500
         CR    4,9                                             @SC92022 06230000
         BNH   DSKOPS                                          @SC86299 06230500
         LR    9,4                                             @SC92022 06231000
DSKOPS   STH   6,FABLRECL                                      @SC86299 06231500
         STH   9,FABBLKSI                                      @SC92022 06232000
         BR    14                                              @SC86299 06232500
*                                                                       06233000
         DROP  6                                               @SC87015 06233500
         DROP  3                                               @SC90264 06234000
         DROP  5                                               @SC92022 06234500
*                                                                       06235000
         LOCALS ,                                              @SC86295 06235500
DYNPL    DS    A(0,0,0,0,DYNDSP,0,DYNRC)                       @SC88026 06236000
         DS    A(0)          Ptr to message buffer             @SC88119 06236500
DYNRC    DS    F                                               @SC86299 06237000
DSKTKT   DS    A             Ptr for testing member            @SC88043 06237500
DSKOPLS  DS    F             Ptr to new FAB                    @SC88049 06238000
DYNDSP   DS    X                                               @SC86299 06238500
DSKMNTH  DS    XL11          Month length table                @SC86299 06239000
DSKPSAV  EQU   DSKMNTH,8     Buffer for saved prefix           @SC88043 06239500
DSKCOD   DS    X             Saved DISKIO code                 @SC88308 06240000
         EXIT                                                           06240500
