*COPY                                                 IKCUTL            05000000
         CHECKVER IKCUTL,4.3                                   @SC90072 05000500
         TITLE 'CWDSET/DSPACE Routines - set/show working directory'    05001000
* Set new 'working directory', i.e., filemode letter                    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
*  CMS filespec parts                                          @SC86295 05003500
FN       EQU   FILNAM,8                                        @SC86295 05004000
FT       EQU   FN+8,8                                          @SC86295 05004500
FM       EQU   FT+8,2                                          @SC86295 05005000
*                                                                       05005500
IFIFM    EQU   IFILE+16,2                                      @SC90344 05006000
*                                                                       05006500
JFN      EQU   JFNAM,8       Foreign FN for SEND               @SC86295 05007000
JFT      EQU   JFN+8,8       Foreign FT for SEND               @SC86295 05007500
*                                                                       05008000
         NTOKN N=CWDERR,H=CWDERR                               @SC86164 05008500
         LTR   7,7           Length of token                   @SC86164 05009000
         BNZ   CWDERR        >1                                @SC86164 05009500
         MVC   IFIFM(1),0(6) Copy mode letter                  @SC90037 05010000
         TR    IFIFM(1),UPCASE                                 @SC91033 05010500
       NXTFSET IFILE,CWD,E=CWDERR                              @SC86295 05011000
         MVC   DEST(1),IFIFM Save new mode                     @SC90037 05011500
         B     RTRN0                                           @SC86295 05012000
CWDERR   PTEXT '&CWDERRM'                                      @SC86295 05012500
         B     SUBERR                                          @SC86295 05013000
*                                                                       05013500
*        DSPACE Routine - display available disk space         @SC86164 05014000
*                                                                       05014500
* Show space in 'working directory' or other minidisk                   05015000
* Entry: SCANPTR string has option (none => working directory)          05015500
* Exit: R15=0 if ok, R15=1 if error or help needed. ERRNUM unchanged    05016000
DSPACE   ENTER ALT                                             @SC86164 05016500
         MVC   QDISK+16(1),DEST Default filemode               @SC86164 05017000
         NTOKN N=DSPACEX                                       @SC86164 05017500
         MVC   QDISK+16(1),0(6)                                @SC86164 05018000
         TR    QDISK+16(1),UPCASE                              @SC91033 05018500
DSPACEX  HOST  QDISK,E=RTRN1                                   @SC86295 05019000
         B     RTRN0                                           @SC86295 05019500
         LOCALS ,                                              @SC86295 05020000
         EXIT  ,                                               @SC86295 05020500
         TITLE 'FSPEC Routine - extract filespec from scan string'      05021000
*                                                                       05021500
* Entry: R1->name field, R0=flags selecting operation (see below)       05022000
*        For parse operations, SCANPTR defines the input string.        05022500
*        For getting foreign or display filespec, R7->output buffer     05023000
* Exit: if not FFNEW, then R15=0 if ok, 1 if ?, 2 if bad.               05023500
*        For R15=1 or 2 R3,R4 give message.  ERRNUM may be leftover.    05024000
*                                                                       05024500
*                                 Flags:                  Notes:        05025000
*   Tasks:               FFRCF FFSND FFGET FFNEW                        05025500
* Parse RECV               X                     set ROVR properly      05026000
* Parse SEND 1st                 X                                      05026500
* Parse SEND 2nd           X     X                                      05027000
* Parse GET 1st                        X                                05027500
* Parse GET 2nd            X           X         set ROVR properly      05028000
* Parse F-packet   (FFHDR) X     X     X                                05028500
* Parse for Generic(FFUTL)       X     X         FFWLD: allow partial   05029000
* Parse TAKE                                                            05029500
*                                                                       05030000
* Get unique name                            X     R15: 0=>ok, 1=>bad   05030500
* Interactive name check               X     X     R15: 0=>ok, 1=>bad   05031000
* Get foreign name (FFENC) X                 X     R15->end of string   05031500
* Get display form (FFDSP)       X           X     R15->end of string   05032000
*                                                                       05032500
FSPEC    ENTER                                                 @SC86295 05033000
         STC   0,FSPFLG                                        @SC86295 05033500
         LR    5,0                                             @SC88049 05034000
         SRL   5,4           Convert flags to index            @SC88049 05034500
         AR    5,5                                             @SC88049 05035000
         LR    0,1           Copy ptr to filespec              @SC86295 05035500
         TM    FSPFLG,FFNEW                                    @SC86295 05036000
         BO    FSPWRN                                          @SC86295 05036500
         XC    0(18,1),0(1)  Clear filespec                    @SC86295 05037000
         MVC   FSPBAD,=C'&INVALID'                             @SC86295 05037500
         MVC   FSPBADF(9),=C' filename'                        @SC86295 05038000
         PTEXT FSPBAD,FSPBL  Standard msg form                 @SC86295 05038500
         MVI   ERRNUM,ERRFNE Assume bad file name              @SC86158 05039000
         MVC   16(2,1),DEST  Default FM                        @SC86295 05039500
         LH    5,FSP0(5)     Get dispatch adr                  @SC88049 05040000
         B     FSP0(5)       Go to proper handler              @SC88049 05040500
*                TAKE        GET 1st    SEND 1st    Generic    @SC88049 05041000
FSP0    DC AL2(FSPTAK-FSP0,FSPSN2-FSP0,FSPSND-FSP0,FSPUTL-FSP0) SC88049 05041500
*               RECEIVE     GET 2nd    SEND 2nd    F-packet    @SC88049 05042000
        DC AL2(FSPRC-FSP0,FSPRC-FSP0,FSPSN2-FSP0,FSPHD-FSP0)   @SC88049 05042500
FSPUTL   TM    FSPFLG,FFWLD  Utility: default to all files?    @SC88049 05043000
         BZ    FSPASC        No                                @SC86295 05043500
         MVC   0(8,1),ASTER  Yes                               @SC86295 05044000
         MVC   8(8,1),ASTER                                    @SC86295 05044500
FSPASC   TM    FL2,SRV       Server mode?                      @SC86295 05045000
         BZ    FSPCPY        No, don't need to convert         @SC86295 05045500
         ICM   15,15,LEN     Get length                        @SC86295 05046000
         BZ    FSPCPY                                          @SC86295 05046500
         BCTR  15,0          Correct for EX                    @SC86158 05047000
         L     5,ADR         Get string ptr                    @SC89215 05047500
         EX    15,FSPTRAE    Change to EBCDIC                  @SC89215 05048000
         EX    15,FSPTRUP    Upcase and dot to space           @SC89215 05048500
         B     FSPCPY                                          @SC86295 05049000
FSPTRAE  TR    0(,5),ATOED                                     @SC89301 05049500
FSPTRUP  TR    0(,5),FSPUPDOT                                  @SC89215 05050000
FSPRC    NI    FL1,255-ROVR  Setup for RECEIVE                 @SC86295 05050500
         NI    FL4,255-NMOK-NMCHNG  Collision not checked yet  @SC90033 05051000
         MVI   0(1),C'$'     Default FN                        @SC86295 05051500
         MVC   UFM,DEST      Default FM, can change by = = x   @SC86295 05052000
         B     FSPCPY                                          @SC86295 05052500
FSPHD    MVC   0(8,1),=CL8'$' Default fn                       @SC86295 05053000
         MVC   8(8,1),0(1)   Default ft                        @SC86295 05053500
         MVC   16(2,1),UFM   Default fm                        @SC86295 05054000
         L     2,ADR                                           @SC86295 05054500
         TR    0(256,2),FSPTAB  Make valid fn chars            @SC86295 05055000
         B     FSPCPY                                          @SC86295 05055500
FSPSND   TM    FL5,SALL                                        @SC88049 05056000
         BZ    *+10                                            @SC86295 05056500
         MVC   16(2,1),ASTER Default FM for SEND               @SC86295 05057000
         B     FSPASC                                          @SC86295 05057500
FSPSN2   MVI   1(1),C'='     Foreign file name is same         @SC86295 05058000
         MVI   9(1),C'='                                       @SC86295 05058500
         CTOKN NODOT,H=FSP2H,N=RTRN0                           @SC89097 05059000
         LA    1,L'JFNAM                                       @SC86295 05059500
         CLM   7,3,*-2       Does it fit?                      @SC86224 05060000
         BNH   *+6           Yes                               @SC86224 05060500
         LR    7,1           Use what we can                   @SC86224 05061000
         LR    3,0                                             @SC86295 05061500
         STC   7,0(3)        Save length                       @SC86224 05062000
         LA    0,1(3)                                          @SC86295 05062500
         MVCL  0,6           Get fn, at least                  @SC86224 05063000
         MVI   TRTBL+C'.',2  See if valid CMS token            @SC86224 05063500
         MVI   TRTBL+C'/',2                                    @SC86224 05064000
         SR    2,2                                             @SC86224 05064500
         TRT   1(9,3),TRTBL                                    @SC86295 05065000
         MVI   TRTBL+C'.',0                                    @SC86224 05065500
         MVI   TRTBL+C'/',0                                    @SC86224 05066000
         BCT   2,RTRN0       Not valid: must be complex string @SC86224 05066500
         MVC   FSPPTR,SCANPTR                                  @SC86295 05067000
         LA    2,3                                             @SC86295 05067500
FSPCNT   CLI   BRK,C','                                        @SC88306 05068000
         BE    FSPCNZ        Take comma as end                 @SC88306 05068500
         NTOKN N=FSPCNZ                                        @SC88306 05069000
         BCT   2,FSPCNT                                        @SC86295 05069500
FSPCNZ   MVC   SCANPTR,FSPPTR Restore ptrs                     @SC86295 05070000
         N     2,F1                                            @SC86295 05070500
         BNZ   RTRN0         Single token string               @SC86295 05071000
         LA    0,9(3)        Get 2nd token                     @SC86295 05071500
         MVI   0(3),0        Clear length again                @SC86295 05072000
         MVC   FSPBADX,=C'type'                                @SC86295 05072500
         CTOKN NOBRK,H=FSP2H,N=FSPMIS                          @SC89097 05073000
         MVCL  0,6                                             @SC86295 05073500
         B     RTRN0                                           @SC86295 05074000
FSPTAK   TM    FSPFLG,FFGIV  GIVE command?                     @SC88049 05074500
         BO    *+10          Yes, keep specific FM             @SC87117 05075000
         MVC   16(2,1),ASTER Default FM for TAKE               @SC86295 05075500
         MVC   8(8,1),=CL8'TAKE'                               @SC86295 05076000
FSPCPY   LA    5,LFID(,1)    Point to file options             @SC89218 05076500
         CTOKN NOBRK,H=FSPH,N=FSPZ,OPTS=0                      @SC89218 05077000
         TM    FSPFLG,FFRCF                                    @SC86295 05077500
         BZ    FSPCPN                                          @SC86295 05078000
         CLI   0(6),C'='                                       @SC86224 05078500
         BE    FSPREQ        Go if RECEIVE = ...               @SC86295 05079000
         CLI   0(6),C'*'                                       @SC86224 05079500
         BE    FSPINV                                          @SC86295 05080000
FSPCPN   BAL   14,FSPTOK     Get fn                            @SC87034 05080500
         MVC   FSPBADX,=C'type'                                @SC86295 05081000
         CTOKN H=FSPH,N=FSPZ,OPTS=FSPZ                         @SC89218 05081500
         CLI   0(6),C'='                                       @SC86224 05082000
         BE    FSPINV        Go if RECEIVE xxx =               @SC86295 05082500
         TM    FSPFLG,FFRCF                                    @SC86295 05083000
         BZ    FSPCPT                                          @SC86295 05083500
         CLI   0(6),C'*'                                       @SC86224 05084000
         BE    FSPINV        Go if RECEIVE xxx *               @SC86295 05084500
         OI    FL1,ROVR      Overwrite received fname          @SC86295 05085000
FSPCPT   BAL   14,FSPTOK     Get ft                            @SC87034 05085500
         MVC   FSPBADX,=C'mode'                                @SC86295 05086000
         CTOKN FM,H=FSPH,N=FSPZ,OPTS=FSPZ                      @SC89218 05086500
         TM    FSPFLG,FFRCF                                    @SC86295 05087000
         BZ    FSPCPM                                          @SC86295 05087500
         CLI   0(6),C'*'                                       @SC86224 05088000
         BE    FSPINV                                          @SC86295 05088500
FSPCPM   DS    0H                                              @SC89097 05089000
         BAL   14,FSPTOK     Get fm                            @SC87034 05089500
         B     RTRN0                                           @SC86295 05090000
*                                                                       05090500
FSPREQ   MVC   FSPBADX,=C'type'                                @SC86295 05091000
         CTOKN H=FSPH,N=FSPZ,OPTS=FSPZ  Get ft for RECEIVE =   @SC89218 05091500
         CLI   0(6),C'='                                       @SC86224 05092000
         BNE   FSPINV        Go if FT is not =                 @SC86295 05092500
         CLI   0(6),C'*'                                       @SC86224 05093000
         BE    FSPINV        Bad FM                            @SC86295 05093500
         MVC   FSPBADX,=C'mode'                                @SC86295 05094000
         CTOKN FM,H=FSPH,N=FSPZ,OPTS=FSPZ Pick fm              @SC89218 05094500
         BAL   14,FSPTOK     Use FM they specified             @SC87034 05095000
         MVC   UFM,0(1)      Use for all of file group         @SC87034 05095500
         B     RTRN0                                           @SC87034 05096000
*                                                                       05096500
FSPTOK   LR    8,0           Save start                        @SC87034 05097000
         LR    9,1           And length                        @SC87034 05097500
         MVCL  0,6           Copy token with padding           @SC87034 05098000
         LR    1,8                                             @SC87034 05098500
         BCTR  9,0           Fix for TR                        @SC87034 05099000
         EX    9,TRUPCAS     Upcase the token                  @SC87034 05099500
         BR    14                                              @SC87034 05100000
*                                                                       05100500
FSPDOTS  LTR   1,7           Copy length-1                     @SC89097 05101000
         BNPR  14            Can't convert if just '.'         @SC89097 05101500
         LR    9,6           Copy start of token               @SC89097 05102000
FSPDOTL  CLI   1(9),C'.'     Scan for '.', if any              @SC89097 05102500
         BE    FSPDOTF       Found one                         @SC89097 05103000
         LA    9,1(,9)       Keep looking                      @SC89097 05103500
         BCT   1,FSPDOTL                                       @SC89097 05104000
         BR    14            Not found, ordinary token         @SC89097 05104500
FSPDOTF  LR    7,9           Found dot: break up token         @SC89097 05105000
         SR    7,6           Length-1 of stuff before dot      @SC89097 05105500
         LM    8,9,SCANPTR                                     @SC89097 05106000
         SR    9,1           Back up over brk + post-dot stuff @SC89097 05106500
         AR    8,1           ... and increase length left      @SC89097 05107000
         STM   8,9,SCANPTR                                     @SC89097 05107500
         MVI   BRK,C' '      Reset separator too               @SC89218 05108000
         BR    14                                              @SC89097 05108500
*                                                                       05109000
FSPZ     LR    14,0                                            @SC86295 05109500
         CLI   0(14),C' '    Any default given?                @SC86295 05110000
         BH    RTRN0         Yes, use it                       @SC86295 05110500
FSPMIS   MVC   FSPBAD,=C'&MISSING'                             @SC86295 05111000
FSPINV   LA    15,2                                            @SC86295 05111500
         B     FSPPTRS                                         @SC86295 05112000
*                                                                       05112500
FSPH     PTEXT '&FMTFSPC&FSPCPRM'                              @SC92300 05113000
         CLI   FSPFLG,FFSND  SEND 1st?                         @SC89261 05113500
         BE    *+8           Yes, use whole message            @SC89261 05114000
          SH   4,=H'&FMTOPT' Chop off option part              @SC92300 05114500
         B     FSP0H                                           @SC86295 05115000
FSP2H    PTEXT '&FORFSPC'                                      @SC86295 05115500
FSP0H    LA    15,1                                            @SC86295 05116000
FSPPTRS  RETREG 3,4          Return msg ptrs                   @SC86295 05116500
FSPRET   RET   ,                                               @SC86295 05117000
*                                                                       05117500
* Non-parsing functions . . .                                           05118000
*                                                                       05118500
* Get unique filespec                                                   05119000
FSPWRN   LR    4,1           Save name ptr                     @SC86295 05119500
         TM    FSPFLG,FFENC                                    @SC86295 05120000
         BO    FSPENC        Encode name into buffer           @SC86295 05120500
         TM    FSPFLG,FFDSP                                    @SC86295 05121000
         BO    FSPDSP        Copy name into buffer for display @SC86295 05121500
         TM    FL4,NMOK      Already checked?                  @SC87012 05122000
         BO    RTRN0         Yes, ok                           @SC87012 05122500
         MVC   XFILE,0(1)    Save original name                @SC90033 05123000
         LA    6,8+6(1)      End of FT                         @BS86001 05123500
         BCTR  6,0                                             @BS86001 05124000
         CLI   0(6),C' '     Find end of token                 @BS86001 05124500
         BE    *-6                                             @BS86001 05125000
         LA    5,10+1        Allowed retries                   @BS86001 05125500
         LA    7,C'0'        Extra character                   @BS86001 05126000
         OI    FL4,NMOK      Assume it checks                  @SC87012 05126500
FSPSTA   OPENF T,(4),E=RTRN0 Does it exist already?            @SC86135 05127000
         OI    FL4,NMCHNG    Yes, remember collision occurred  @SC90033 05127500
         MVI   1(6),C'$'     Yes, modify FT                    @BS86001 05128000
         STC   7,2(6)        Serialize                         @BS86001 05128500
         LA    7,1(7)        Bump counter                      @BS86001 05129000
         BCT   5,FSPSTA                                        @BS86001 05129500
         PTEXT '&FILCLSN'                                      @SC88049 05130000
         B     FSP0H         Return error code                 @SC88049 05130500
*                                                                       05131000
* Encode name at (R1) into (R7) buffer (in ASCII), possibly with        05131500
*  substitution from JFSPEC, but disable subsequent subst.              05132000
*  Return updated ptr in R15                                            05132500
FSPENC   LA    1,JFSPEC      Complex string?                   @SC86224 05133000
         LA    5,JFNAM       Remote file-spec                  @SC86155 05133500
         BAL   14,PAKFOR                                       @SC86224 05134000
         BNZ   FSPFILS       Yes, tokens aren't used           @SC86224 05134500
         BAL   14,FSPFID     Filename                          @HF86223 05135000
         LA    7,1(7)        Skip over period                  @HF86223 05135500
         BAL   14,FSPFID     Filetype                          @HF86223 05136000
FSPFILS  MVI   JFSPEC,0      Turn off string                   @SC86224 05136500
         CLI   JFN,C'='      Partial renaming?                 @SC86224 05137000
         BE    FSPENR        Yes, keep it                      @SC86224 05137500
         CLI   JFT,C'='                                        @SC86224 05138000
         BE    FSPENR                                          @SC86224 05138500
         MVI   JFN,C'='      Now use original name             @SC86171 05139000
         MVI   JFT,C'='                                        @SC86171 05139500
FSPENR   LR    15,7          Save ptr                          @SC86295 05140000
         B     FSPRET                                          @SC86295 05140500
*                                                                       05141000
* Copy name at (R1) into (R7) buffer in display form                    05141500
*  Return updated ptr in R15                                            05142000
FSPDSP   BAL   14,FSPDTK     Filename                          @SC86295 05142500
         BAL   14,FSPDTK     Filetype                          @SC86295 05143000
         MVC   0(2,7),0(4)   Filemode                          @SC86295 05143500
         LA    7,2(7)                                          @SC86295 05144000
         B     FSPENR                                          @SC86295 05144500
*                                                                       05145000
* Subroutine to detokenize a list into ASCII                   @SC86135 05145500
FSPFID   MVC   0(8,7),0(4)   Copy token                        @SC86135 05146000
         CLI   0(5),C'='     Keep true name?                   @SC86171 05146500
         BE    *+10          Yes                               @SC86171 05147000
         MVC   0(8,7),0(5)   No, use override                  @SC86171 05147500
         LA    1,8(7)        End of token if no blanks         @SC86135 05148000
         TRT   0(8,7),TRTBL  Find 1st blank                    @SC86135 05148500
         TR    0(8,7),ETOAD  ASCII it                          @SC89301 05149000
         LR    7,1           New end of string                 @SC86135 05149500
         LA    4,8(4)        Next token                        @SC86135 05150000
         LA    5,8(5)                                          @SC86171 05150500
         MVI   0(7),ADOT     Add an ASCII dot, just in case    @SC86135 05151000
         BR    14                                              @SC86135 05151500
*                                                                       05152000
* Subroutine to detokenize a list in EBCDIC                    @SC86295 05152500
FSPDTK   MVC   0(8,7),0(4)   Copy token                        @SC86135 05153000
         LA    1,8(7)        End of token if no blanks         @SC86135 05153500
         TRT   0(8,7),TRTBL  Find 1st blank                    @SC86135 05154000
         MVI   0(1),C' '     Add a BLANK                       @SC86295 05154500
         LA    7,1(1)        New end of string                 @SC86135 05155000
         LA    4,8(4)        Next token                        @SC86135 05155500
         BR    14                                              @SC86135 05156000
*                                                                       05156500
* Subroutine to set up CMS token for copying                   @SC86224 05157000
CMSTOK8  LA    7,1(7)                                          @SC86224 05157500
         ICM   7,8,BLANK                                       @SC86224 05158000
         LA    1,8                                             @SC86224 05158500
         BR    14                                              @SC86224 05159000
*                                                                       05159500
* Table to convert EBCDIC text to upper case + dot to blank    @SC89215 05160000
FSPUPDOT DC    (C'.')AL1(*-FSPUPDOT)                           @SC89215 05160500
         DC    C' '                                            @SC89215 05161000
         DC    (127-C'.')AL1(*-FSPUPDOT)                       @SC89215 05161500
         HTBL  80,C1,C2,C3,C4,C5,C6,C7,C8,C9,8A,8B,8C,8D,8E,8F @SC89268 05162000
         HTBL  90,D1,D2,D3,D4,D5,D6,D7,D8,D9,9A,9B,9C,9D,9E,9F @SC89268 05162500
         HTBL  A0,A1,E2,E3,E4,E5,E6,E7,E8,E9,AA,AB,AC,AD,AE,AF @SC89268 05163000
         DC    080AL1(*-FSPUPDOT)                              @SC89215 05163500
* Valid CMS file name characters                               @SC86295 05164000
FSPTAB   DC    64C'_',C' '           space                     @SC86295 05164500
         DC    10C'_',C' '           dot                       @SC86295 05165000
         DC    02C'_',C'+'           plus                      @SC86295 05165500
         DC    12C'_',C'$'           dollar sign               @SC86295 05166000
         DC    04C'_',C'-'           dash                      @SC86295 05166500
         DC    12C'_',C'_'           underscore                @SC86295 05167000
         DC    12C'_',C':#@'         colon, pound sign, at sign@SC86295 05167500
         DC    04C'_',C'ABCDEFGHI'   a-i                       @SC86295 05168000
         DC    07C'_',C'JKLMNOPQR'   j-r                       @SC86295 05168500
         DC    08C'_',C'STUVWXYZ'    s-z                       @SC86295 05169000
         DC    23C'_',C'ABCDEFGHI'   A-I                       @SC86295 05169500
         DC    07C'_',C'JKLMNOPQR'   J-R                       @SC86295 05170000
         DC    08C'_',C'STUVWXYZ'    S-Z                       @SC86295 05170500
         DC    06C'_',C'0123456789'  0-9                       @SC86295 05171000
         DC    06C'_'                                          @SC86295 05171500
         LOCALS ,                                              @SC86295 05172000
FSPBAD   DS    C'&INVALID'                                     @SC92300 05172500
FSPBADF  DS    C' file'                                        @SC92300 05173000
FSPBADX  DS    C'name'                                         @SC86295 05173500
FSPBL    EQU   *-FSPBAD      Length of composite message       @SC92300 05174000
FSPPTR   DS    XL8           Saved scan ptrs                   @SC86295 05174500
FSPFLG   DS    X             Filespec flags                    @SC86295 05175000
FSPEC    EXIT                                                  @SC86295 05175500
         TITLE 'KHELP routine - perform HELP command'                   05176000
* Handle HELP command, rest of string given by SCANPTR.                 05176500
KHELP    ENTER ,                                               @SC86355 05177000
         LR    8,6           Save ptr to command               @SC88043 05177500
         SR    5,5           Clear length of extra word        @SC90264 05178000
         NTOKN N=KHLI        See if subcommand given           @SC86355 05178500
         L     1,=A(USNCMD)  Command table                     @SC87117 05179000
KHSCAN   SCAN  (1),KHLF,NODISP                                 @SC86355 05179500
         WTEXT '&BADSBCM'   Not found                          @SC86355 05180000
         RET   ,                                               @SC86355 05180500
KHLF     CLM   7,8,F0        Just '?'                          @SC86355 05181000
         BE    RTRN          Yes, done                         @SC86355 05181500
         C     1,=A(USNCSET) Is it the set command?            @SC91320 05182000
         BNE   KHNORM        Normal subcommands                @SC90264 05182500
         LA    4,KWNAME(,1)  Set ptr to 'SET' string           @SC91320 05183000
         IC    5,KWMIN(,1)   and actual length of abbreviation @SC91320 05183500
         LA    5,1(,5)                                         @SC91320 05184000
         NTOKN N=KHSET       Just SET -- no parameter          @SC90264 05184500
         L     1,=A(SETCMDKW)  Keyword table                   @SC90264 05185000
         B     KHSCAN        Go back and check parameter       @SC90264 05185500
KHNORM   DS    0H                                              @SC90264 05186000
         LA    6,KWNAME(,1)  Ptr to name in table              @SC90264 05186500
         SR    7,7                                             @SC90264 05187000
         IC    7,KWMIN(,1)   Length - 1 of abbrev              @SC90264 05187500
         LA    7,1(,7)                                         @SC90264 05188000
         B     KHLJ          Create command string for typing  @SC90264 05188500
KHSET    SR    7,7           Plain SET with no parameter       @SC90264 05189000
         B     KHLJ          Do it                             @SC90264 05189500
KHLI     PTEXT 'KERMITCM',AREG=6,LREG=7                        @SC90264 05190000
KHLJ     DS    0H                                              @SC90264 05190500
         MVC   KHLPBF+8(8),KRMNAM Set up filename              @SC90264 05191000
         MVC   KHLPBF+16(10),=CL10'HELPCMS * '                 @SC90264 05191500
         CLI   KRMNAM,C'*'   Was it a START?                   @SC90264 05192000
         BE    KHLDF         Yes, use default                  @SC86355 05192500
         CLI   KRMNAM,X'FF'  Nothing at all?                   @SC90264 05193000
         BE    KHLDF         That's right, use default         @SC90264 05193500
         FSSTATE FSCB=KHLPBF,ERROR=KHLDF  See if special help  @SC90264 05194000
         B     KHLGEN                                          @SC90264 05194500
KHERR    WTEXT '&NOHELPF'   Not found                          @SC90264 05195000
         RET   ,                                               @SC90264 05195500
KHLDF    MVC   KHLPBF+8(8),=CL8'KERMIT'                        @SC90264 05196000
         FSSTATE FSCB=KHLPBF,ERROR=KHERR  Give up if not found @SC90264 05196500
KHLGEN   MVC   KHLPBF+24(2),24(1) Copy filemode from FST       @SC90264 05197000
         MVC   KHLPBF(8),=CL8'&TYPCMD '                        @SC90264 05197500
         MVC   KHLPBF+26(30),=CL30'      (       MEMBER'       @SC90264 05198000
         LA    14,KHLPBF+48                                    @SC90264 05198500
         LR    15,5                                            @SC90264 05199000
         MVCL  14,4          Copy 'SET' to buffer, if needed   @SC90264 05199500
         LR    15,7                                            @SC90264 05200000
         MVCL  14,6          Copy 'subcmd' to buffer           @SC90264 05200500
         MVC   KHLPBF+56(8),=8X'FF'                            @SC90264 05201000
         LA    0,KHLPBF      Set up for system                 @SC90264 05201500
         LA    6,64          Length of string                  @SC90264 05202000
         NI    FL4,255-UCMD                                    @SC90264 05202500
         KCALL SUPFNC,3      Do it                             @SC86355 05203000
         CH    15,=H'32'     Library problem?                  @SC92003 05203500
         BNE   RTRN          No, just give up                  @SC92003 05204000
         MVC   KHLPBF(8),=CL8'HELP'  Switch to basic HELP cmd  @SC92003 05204500
         MVC   KHLPBF+16(8),=8X'FF'                            @SC92003 05205000
         LA    6,24          Length of new string (R0 still ok)@SC92003 05205500
         KCALL SUPFNC,3      Do it                             @SC92003 05206000
         RET   ,                                               @SC86355 05206500
         LOCALS ,                                                       05207000
KHLPBF   DS    8CL8                                            @SC90264 05207500
KHELP    EXIT  ,                                               @SC87007 05208000
         TITLE 'SUPFNC Routine - various supervisor functions' @SC86158 05208500
SUPFNC   ENTER                                                 @SC86295 05209000
*  On entry, R1 = operation code, R0 = possible ptr            @SC86158 05209500
* Exit: R15 set (0 => ok, <0 => illegal cmd, >0 => depends)             05210000
*       ERRNUM set appropriately (R1=1,3,4) or unchanged (2,5-11)       05210500
* 1 -> Start typeout interception.  N.B.  &MAXLR >> 2048 for this       05211000
* 2 -> Clean up afterwards and stop interception                        05211500
* 3 -> Execute host command with or without interception                05212000
*      If UCMD set, SCANPTR gives text, else R0->text,R6=len            05212500
* 4 -> Execute CP command with or without interception                  05213000
*      R0->text, R6=len                                                 05213500
* 5 -> Stop interception if going                                       05214000
* 6 -> Retrieve original cmd parm string into CBUF (R15=1 if null)      05214500
* 7 -> Test for stacked lines, return number in R15                     05215000
* 8 -> Log off (doesn't return!)                                        05215500
* 9 -> Wait specified time                                              05216000
* 10-> Return clock time in R15 (centisec)                              05216500
* 11-> Setup up new prompt string at (R0)                               05217000
         BCT   1,ICPFIN                                        @SC86158 05217500
* Start interception, initialize ptrs                          @SC86158 05218000
         MVI   ERRNUM,ERRNOE OK                                @SC86158 05218500
         L     1,WBUF        Output buffer                     @SC90264 05219000
         LA    0,2048(,1)    Skip over some, to be safe        @SC90264 05219500
         A     1,F64KP       End of buffer                     @SC90264 05220000
         LR    15,0                                            @SC86158 05220500
         STM   15,0,TXTPTR   Save                              @SC86158 05221000
         STM   0,1,SVCOPTR                                     @SC86158 05221500
         SR    1,0           Get length                        @SC86158 05222000
         L     15,=X'15000000'                                 @SC86158 05222500
         MVCL  0,14          Fill with NL (X'15')              @SC86158 05223000
         MVI   SVCSNAG+1,0   370-mode PSW                      @SC89235 05223500
         LA    14,SVCOPSW+3  Assume page 0 version             @SC89235 05224000
         TM    FLGXA,XACMS   XA mode?                          @SC89235 05224500
         BZ    SFCSVCST      No, fine                          @SC89235 05225000
         MVI   SVCSNAG+1,X'08'  XA-mode PSW                    @SC89235 05225500
         AIF   ('&KTAG' NE 'XA').CMSXA1                        @SC90067 05226000
         L     1,ASVCSECT    Ptr to SVC info                   @SC89235 05226500
         USING SVCSECT,1                                       @SC89235 05227000
         LA    14,SVCOCODE   Use XA version                    @SC89235 05227500
.CMSXA1  ANOP                                                  @SC90067 05228000
SFCSVCST ST    14,SVCOCPTR   Correct ptr to SVC code           @SC89235 05228500
         CLC   SVCNPSW,SVCSNAG  Already set up?                @SC86158 05229000
         BE    RTRN0         Yes, but how?                     @SC86295 05229500
         MVC   SAVENPSW,SVCNPSW                                @SC86158 05230000
         MVC   TYPSAV,ADMSCWR                                  @SC86283 05230500
        DMSKEY NUCLEUS                                         @SC86283 05231000
         MVC   SVCNPSW,SVCSNAG Set up interception (SVC)       @SC86283 05231500
         MVC   ADMSCWR,=A(ICPTYP)  (BALR)                      @SC86283 05232000
        DMSKEY RESET                                           @SC86283 05232500
         B     RTRN0                                           @SC86295 05233000
* Clean up after interception                                  @SC86295 05233500
ICPFIN   BCT   1,ICPHST                                        @SC86158 05234000
         L     5,SVCOPTR     End of text                       @SC86158 05234500
         ST    5,TXTPTR+4    Save                              @SC86158 05235000
         B     ICPRST1       Now restore interrupts            @SC86295 05235500
* Restore SVC interrupt vector                                 @SC86158 05236000
ICPRST   BCT   1,SFCLIN                                        @SC86295 05236500
ICPRST1  CLC   SVCNPSW,SVCSNAG                                 @SC86295 05237000
         BNE   RTRN0         OK                                @SC86295 05237500
        DMSKEY NUCLEUS                                         @SC86283 05238000
         MVC   SVCNPSW,SAVENPSW                                @SC86283 05238500
         MVC   ADMSCWR,TYPSAV                                  @SC86283 05239000
         NI    MSGFLAGS,255-NOTYPING                           @SC88309 05239500
        DMSKEY RESET                                           @SC86283 05240000
         B     RTRN0                                                    05240500
* Avoid user-area CMS commands, otherwise execute command at   @SC86158 05241000
*  (R0) already tokenized. Save return code.                   @SC86158 05241500
ICPHST   BCT   1,ICPCP                                         @SC86158 05242000
         TM    FL4,UCMD      User CMS command?                 @SC86295 05242500
         BZ    ICPCMS0       No, already tokenized             @SC86295 05243000
         LM    0,1,SCANPTR                                     @SC86295 05243500
         LTR   15,0                                            @SC87034 05244000
         BNP   ICPCMIL       Nothing there                     @SC87034 05244500
        DMSKEY NUCLEUS       Enter Key 0                       @SC86295 05245000
         L     15,ASCANN                                       @SC86295 05245500
         BALR  14,15         Tokenize data                     @SC86295 05246000
         LR    3,0           Length of tokenized list          @SC90073 05246500
         BCTR  3,0           Get length for TR                 @SC90073 05247000
         EX    3,TRUPCAS     Convert to upper case             @SC90073 05247500
         LR    0,15                                            @SC86295 05248000
        DMSKEY RESET         Restore user key                  @SC86295 05248500
         LTR   15,0          Did SCANN fail?                   @SC86295 05249000
         BNZ   ICPCMIL       Yes                               @SC86295 05249500
         C     3,F8          Did we get anything?              @SC90073 05250000
         BNH   ICPCMIL       No, just a fence.  Give up        @SC90073 05250500
         LR    0,1                                             @SC86295 05251000
ICPCMS0  LR    3,0                                             @SC86295 05251500
         CLC   =C'CP ',0(3)  CP command?                       @SC86158 05252000
         BE    ICPCMSCP      Yes, do it                        @SC86158 05252500
         MVI   TRTBL+C'%',1  Possible wildcard chars           @SC90037 05253000
         MVI   TRTBL+C'*',1                                    @SC90037 05253500
         TRT   0(8,3),TRTBL  See if any % or * in FN           @SC90037 05254000
         MVI   TRTBL+C'%',0  Restore TRTBL                     @SC90037 05254500
         MVI   TRTBL+C'*',0                                    @SC90037 05255000
         BZ    *+12          No wild chars found               @SC90037 05255500
          CLI  0(1),C' '     Maybe just a blank?               @SC90037 05256000
          BNE  ICPCMIL       No, illegal                       @SC90037 05256500
         MVC   IFT,=CL8'EXEC'                                  @SC86158 05257000
         MVC   IFM,ASTER     Search all disks                  @SC86158 05257500
         TM    OPTFLAGS,NOIMPEX  EXEC's allowed?               @SC86158 05258000
         BO    ICPCMSM       No, try for module                @SC86158 05258500
         TM    FL4,UCMD      User CMS command?                 @SC86158 05259000
         BZ    ICPCMSM       No, avoid EXEC's                  @SC86158 05259500
ICPCMSA  MVC   IFN,0(3)                                        @SC86158 05260000
         LA    4,1                                             @SC86158 05260500
         TM    FL4,UCMD      User CMS command?                 @SC90264 05261000
         BO    ICPCMSS       Yes, might have abbrevs           @SC90264 05261500
         SR    4,4           No, disable abbrevs               @SC90264 05262000
ICPCMSS  FSSTATE FSCB=IFSCB,ERROR=ICPABBR See if exists        @SC90037 05262500
         LR    5,1                                             @SC86295 05263000
         USING FSTSECT,5                                       @SC90037 05263500
         TM    FL4,UCMD      User CMS command?                 @SC90264 05264000
         BZ    ICPCMSU       No, do it now                     @SC90264 05264500
        DMSEXS MVC,0(8,3),IFN Found, copy full name            @SC86158 05265000
         CLI   IFT,C'E'      EXEC?                             @SC86158 05265500
         BNE   ICPCMSU       No, module. Check it              @SC86158 05266000
         S     3,F8          Back up to EXEC in COMBUF         @SC86158 05266500
         DMSEXS MVC,NUCPLBEG,NUCPLCMD Argst begins w/ cmd name @SC89264 05267000
         B     ICPCMSX       Do it                             @SC86158 05267500
ICPABBR  LTR   4,4           Already tried abbrev?             @SC86158 05268000
         BZ    ICPCMSM       Yes, give up                      @SC86158 05268500
         TM    OPTFLAGS,NOABBREV Allowed?                      @SC86158 05269000
         BO    ICPCMSM       No, just do it                    @SC86158 05269500
        DMSKEY NUCLEUS                                         @SC86158 05270000
         LM    0,1,0(3)      Get name entered                  @SC86158 05270500
         L     15,AABBREV    Look up abbreviation              @SC86158 05271000
         BALR  14,15                                           @SC86158 05271500
         LR    4,15          Save RC                           @SC86158 05272000
        DMSKEY RESET         Return to normal                  @SC86158 05272500
         LTR   4,4           Did we find one?                  @SC86158 05273000
         BNZ   ICPCMSM       No, give up                       @SC86158 05273500
         STM   0,1,IFN       Yes, try it                       @SC86158 05274000
         B     ICPCMSS       Now R4=0, don't loop              @SC86158 05274500
ICPCMSM  CLI   IFT,C'M'                                        @SC86158 05275000
         BE    ICPCMEX       Already looked                    @SC90037 05275500
         MVC   IFT,=CL8'MODULE'                                @SC86158 05276000
         B     ICPCMSA       Start over again                  @SC86158 05276500
ICPCMEX  CLC   =CL8'EXEC',IFN Are we looking for an EXEC?      @SC90037 05277000
         BNE   ICPCMSX       No, just execute it               @SC90037 05277500
         MVC   IFN,8(3)      Yes, see if it exists             @SC90037 05278000
         MVC   IFT,=CL8'EXEC'                                  @SC90037 05278500
         FSSTATE FSCB=IFSCB,ERROR=ICPCMIL See if exists        @SC90037 05279000
         B     ICPCMSX                                         @SC90037 05279500
ICPCMSU  CLI   FSTFV,C'F'    System-key transient?             @SC90037 05280000
         BE    ICPCMSX       OK, no problem                    @SC86158 05280500
         MVC   IFM,FSTM      Get right mode letter             @SC86158 05281000
         DROP  5                                               @SC90037 05281500
         LA    2,CMD         Buffer for 1st record of module   @SC86295 05282000
         MVC   4(4,2),=A(KERMIT)  In case of failure           @SC86295 05282500
        FSREAD FSCB=IFSCB,BUFFER=(2)  Get header record        @SC86295 05283000
       FSCLOSE FSCB=IFSCB                                      @SC86158 05283500
         CLC   =A(KERMIT),CMD+4 Check beginning adr            @SC86158 05284000
         BH    ICPCMSX       Below Kermit, assume it's ok      @SC89023 05284500
         CLC   =XL4'20000',=A(KERMIT) Are we both user-area?   @SC89023 05285000
         BNH   ICPCMIL       User-area, forbid it              @SC86158 05285500
ICPCMSX  HOST  0(3),E=*+4,EPL=YES  Accept errors, use ext.PL.  @SC89264 05286000
         LTR   6,15          Save return code                  @SC86295 05286500
         BNM   SFCRC                                           @SC86295 05287000
         TM    OPTFLAGS,NOIMPCP                                @SC86295 05287500
         BO    ICPCMIL       No implied CP commands            @SC86295 05288000
         TM    FL4,UCMD      User command?                     @SC86295 05288500
         BO    ICPCMSCP      Yes, maybe it's for CP            @SC86295 05289000
ICPCMIL  MVI   ERRNUM,ERRSYS Illegal system command            @SC86295 05289500
         B     RTRNM1                                          @SC86295 05290000
ICPCMP   CLC   1(,4),0(3)    Partial token matching            @SC86158 05290500
IFSCB    FSCB  'X X',BSIZE=80,RECNO=1,RECFM=V                  @SC86158 05291000
IFN      EQU   IFSCB+8,8                                       @SC90037 05291500
IFT      EQU   IFN+8,8                                         @SC90037 05292000
IFM      EQU   IFT+8,2                                         @SC90037 05292500
* Execute CP command sent to CMS (assumed SCANN'ed)            @SC86158 05293000
ICPCMSCP L     0,NUCPLCMD    Get cmd ptr                       @SC86158 05293500
         L     6,NUCPLEND                                      @SC86158 05294000
         SR    6,0           Get length                        @SC86158 05294500
         LA    1,1           Simulate normal entry             @SC86158 05295000
* Execute CP command at (R0) with text interception            @SC86158 05295500
ICPCP    BCT   1,ICPRST                                        @SC86158 05296000
         LR    1,0           Copy ptr for upcasing             @SC87034 05296500
         LTR   4,6                                             @SC87034 05297000
         BNP   ICPCMIL       Nothing there                     @SC87034 05297500
         BCTR  4,0                                             @SC87034 05298000
         EX    4,TRUPCAS                                       @SC87034 05298500
         CLC   SVCNPSW,SVCSNAG                                 @SC86283 05299000
         BNE   ICPCDG        Not intercepting, just do it      @SC86283 05299500
         KCALL SETMSG,3      Restore CP settings               @SC86158 05300000
         LM    1,2,SVCOPTR   Response buffer                   @SC86158 05300500
         SR    2,1           Get buffer length                 @SC86158 05301000
         L     7,=F'8192'    Max length from CP                @SC86158 05301500
         CR    7,2           Do we have that much?             @SC86158 05302000
         BNH   *+6                                             @SC86158 05302500
         LR    7,2           Use what we have                  @SC86158 05303000
         LR    2,7           Remember                          @SC86158 05303500
         ICM   6,8,BLANK                                       @SC86158 05304000
         DIAG  0,6,8         Issue command                     @SC86158 05304500
         BZ    *+6                                             @SC86158 05305000
         LR    7,2           Not likely: filled buffer         @SC86158 05305500
         A     7,SVCOPTR                                       @SC86158 05306000
         BCTR  7,0           Scan back over any extra X'15'    @SC86158 05306500
         CLI   0(7),X'15'                                      @SC86158 05307000
         BE    *-6                                             @SC86158 05307500
         LA    7,2(7)        Keep one X'15'                    @SC86158 05308000
         C     7,SVCOPTR+4   Be careful of end                 @SC86158 05308500
         BNH   *+8           OK                                @SC86158 05309000
         L     7,SVCOPTR+4   Got past it somehow               @SC86158 05309500
         ST    7,SVCOPTR                                       @SC86158 05310000
         KCALL SETMSG,2      Change CP settings again          @SC86158 05310500
         B     ICPRC                                           @SC86295 05311000
*                                                                       05311500
ICPCDG   DIAG  0,6,8         Issue command                     @SC86283 05312000
ICPRC    C     6,F1          Illegal command?                  @SC86295 05312500
         BE    ICPCMIL       Yes                               @SC86295 05313000
* Issue return code msg if needed                              @SC86295 05313500
SFCRC    LTR   4,6           Check RC                          @SC86295 05314000
         BZ    SFCZRC        RC=0                              @SC86158 05314500
         LR    15,6                                            @SC90264 05315000
         TM    FL4,UCMD      User cmd?                         @SC86316 05315500
         BZ    RTRN          No. No message, just rc in R15    @SC90264 05316000
         MVC   CMD(2),=C'R(' Set up message                    @SC86209 05316500
         LA    15,CMD+2                                        @SC86209 05317000
         BAL   2,EDDEC       Edit RC into msg                  @SC86295 05317500
         MVI   0(15),C')'    Format is R(rc)                   @SC86209 05318000
         LA    0,1(15)                                         @SC86268 05318500
         LA    1,CMD         Start of edited string            @SC86209 05319000
         SR    0,1           Length                            @SC86268 05319500
         WTEXT (1),(0)                                         @SC86268 05320000
SFCZRC   LR    15,6                                            @SC86295 05320500
         MVI   ERRNUM,ERRNOE No errors                         @SC86295 05321000
         B     RTRN                                            @SC86295 05321500
*                                                                       05322000
SFCLIN   BCT   1,SFCSTK                                        @SC86295 05322500
* Retrieve original command line arguments, if any             @SC86295 05323000
*   Return code =0 if yes, =1 if no                            @SC86295 05323500
*   Leave string in CBUF buffer (up to 512), length in CLEN    @SC89235 05324000
         LM    5,6,ORGR0     Original R0,R1                    @SC87253 05324500
         CLI   0(6),255                                        @SC86171 05325000
         BE    RTRN1         Go if, e.g., just 'START'         @SC86171 05325500
         LA    6,8(6)        Ok, point to arguments            @SC86171 05326000
         CLI   0(6),255                                        @SC86171 05326500
         BE    RTRN1         Go if nothing on cmd                       05327000
         L     8,CBUF        A safe data area                  @SC89235 05327500
         LA    9,512         Length of buffer                  @SC89235 05328000
         CLI   ORGR1,1                                         @SC87253 05328500
         BL    SFCCMDK       R1 hi order byte is 0                      05329000
         CLI   ORGR1,11                                        @SC87253 05329500
         BH    SFCCMDK       R1 hi order byte is > X'0B'                05330000
         LM    6,7,4(5)      Address of arguments, end         @SC89235 05330500
         SR    7,6           Get length                        @SC89235 05331000
         CR    9,7           How much info?                    @SC89235 05331500
         BNH   *+6           Ok                                @SC89235 05332000
          LR   9,7           Copy only what's there            @SC89235 05332500
         ST    9,CLEN        Save command length               @SC89235 05333000
         MVCL  8,6                                             @SC89235 05333500
         B     RTRN0                                           @SC89235 05334000
*                                                                       05334500
SFCCMDK  AR    9,8           Ptr to end of buffer              @SC89235 05335000
SFCCMDKL MVC   0(8,8),0(6)   Copy token                        @SC89235 05335500
         LA    1,8(,8)       Char after token                  @SC89235 05336000
         TRT   0(8,8),TRTBL  Find blank                        @SC89235 05336500
         MVI   0(1),C' '     Add a blank, in case              @SC86295 05337000
         LA    8,1(,1)       Skip over blank                   @SC89235 05337500
         LA    6,8(6)        Skip a CMS token                           05338000
         CLI   0(6),255                                                 05338500
         BE    SFCCMDKM      End of str, quit copying          @SC89235 05339000
          CR   8,9           Is it too long?                   @SC89235 05339500
          BL   SFCCMDKL      Loop if more room                 @SC89235 05340000
SFCCMDKM S     8,CBUF        Length = current pos - beginning  @SC89235 05340500
         ST    8,CLEN        Save command length               @SC89235 05341000
         B     RTRN0                                           @SC86295 05341500
*                                                                       05342000
* Test for stacked commands                                    @SC86295 05342500
*   return code = number of stacked lines                      @SC86295 05343000
SFCSTK   BCT   1,SFCKIL                                        @SC86295 05343500
         LH    15,NUMFINRD   Pending lines                     @SC86295 05344000
         A     15,NUCNLSTK   Lines in program stack            @SC86295 05344500
         B     RTRN                                            @SC86295 05345000
*                                                                       05345500
* Log out                                                      @SC86295 05346000
SFCKIL   BCT   1,SFCWT                                         @SC86295 05346500
         CPCMD 1,0,'LOGOFF'                                    @SC86295 05347000
*                                                                       05347500
* Wait specified time in R0 (sec)                                       05348000
SFCWT    BCT   1,SFCCLK                                        @SC86295 05348500
       LINEDIT TEXT='SL ..... SEC',DOT=NO,DISP=CPCOMM,                 +05349000
               SUB=(DEC,(0))                                   @SC86184 05349500
         L     1,=A(S1INTFL) No, set flag for interrupt        @SC91095 05350000
         OI    0(1),ATN                                        @SC91095 05350500
         B     RTRN0                                           @SC86295 05351000
*                                                                       05351500
* Return time in centisec in R15                                        05352000
SFCCLK   BCT   1,SFCPRP                                        @SC87351 05352500
         STCK  TMPDW         Store TOD clock                   @SC86295 05353000
         LM    14,15,TMPDW                                     @SC86295 05353500
         SLDL  14,8          Take mod 204 days                 @SC86295 05354000
         SRDL  14,20         Get in microsec                   @SC86295 05354500
         D     14,=F'10000'  Get in centisec                   @SC86295 05355000
         B     RTRN                                            @SC86295 05355500
*                                                                       05356000
* Set up prompt string                                         @SC89334 05356500
SFCPRP   ICM   4,1,S1HND     See if handshake is defined       @SC89334 05357000
         BZ    RTRN0         No, skip it                       @SC89334 05357500
         LR    1,0           Ptr to prompt string              @SC89334 05358000
         BCTR  1,0           Ptr to prompt string length       @SC89334 05358500
         SR    2,2                                             @SC89334 05359000
         ICM   2,1,0(1)      Get length                        @SC89334 05359500
         BZ    RTRN0         No prompt, leave it to system     @SC89334 05360000
         LA    3,0(2,1)      Point to last character           @SC89334 05360500
         CLM   4,1,0(3)      Is it the handshake?              @SC89334 05361000
         BE    RTRN0         Yes, assume all is well           @SC89334 05361500
         STC   4,1(,3)       No, tack one onto string          @SC89334 05362000
         LA    2,1(,2)       And update length                 @SC89334 05362500
         STC   2,0(,1)                                         @SC89334 05363000
         B     RTRN0                                           @SC89334 05363500
         TITLE 'SVC interceptor,  executed in system protect key'       05364000
         USING ICPTYP,15                                       @SC86283 05364500
ICPTYP   STM   12,14,SVCSV1  Save regs                         @SC86283 05365000
         L     13,SVCSNAG+4  Addressability                    @SC86283 05365500
         DROP  15                                                       05366000
         USING SVCEXIT,13                                      @SC86283 05366500
         B     ICPTGO        Grab it                           @SC86283 05367000
SVCEXIT  STM   12,13,0       Save regs                         @SC86158 05367500
         BALR  13,0          Addressability                    @SC86158 05368000
         USING *,13                                            @SC86158 05368500
         L     13,SVCSNAG+4  Addressability                    @SC86283 05369000
         USING SVCEXIT,13                                      @SC86283 05369500
         ICM   13,8,SVCEXIT  Flag for SVC entry                @SC86283 05370000
         MVC   SVCSV1(8),0                                     @SC86158 05370500
         STM   14,15,SVCSV2                                    @SC86158 05371000
         L     12,AFVS                                         @SC86158 05371500
         USING FVSECT,12                                       @SC86158 05372000
         TM    UFDBUSY,ABNBIT  ABEND in progress?              @SC86158 05372500
         BO    SVCCNCL                                         @SC86158 05373000
         L     14,SVCOCPTR   Correct ptr to SVC code           @SC89235 05373500
         CLI   0(14),13      ABEND?                            @SC89235 05374000
         BE    SVCCNCL                                         @SC86158 05374500
         CLI   0(14),203                                       @SC89235 05375000
         BE    SVC203T       Could be DMSABN                   @SC86158 05375500
         CLI   0(14),204     Used only in CMS 5.5 and above    @SC89235 05376000
         BE    *+12                                            @SC89235 05376500
          CLI  0(14),202                                       @SC89235 05377000
         BNE   SVCGO         Ok, do it                         @SC86158 05377500
         CLC   =CL8'TYPLIN',0(1)  WRTERM?                      @SC86158 05378000
         BNE   SVCGO         No, do it                         @SC86158 05378500
ICPTGO   LM    14,15,SVCOPTR Output ptrs                       @SC86158 05379000
         SR    15,14         Length left                       @SC86158 05379500
         LA    12,255        Limit                             @SC86158 05380000
         CH    12,14(1)      Buffer length                     @SC86295 05380500
         BNH   *+8           Too big                           @SC86158 05381000
         LH    12,14(1)      Ok, use it                        @SC86295 05381500
         LTR   12,12                                           @SC86158 05382000
         BNP   ICPTRET                                         @SC86283 05382500
         CR    12,15         Enough room?                      @SC86283 05383000
         BH    ICPTRET       No                                @SC86283 05383500
         ICM   15,7,9(1)     Buffer address                    @SC86295 05384000
         TM    MSGFLAGS,NOTYPING                               @SC88309 05384500
         BO    ICPTRET       HT is in effect                   @SC88309 05385000
         TM    13(1),X'40'   Error message?                    @SC88309 05385500
         BZ    *+8           No, keep whole text               @SC88309 05386000
         DIAG  15,12,X'5C'   Adjust according to EMSG          @SC88309 05386500
         LTR   12,12         Anything to show?                 @SC88309 05387000
         BNP   ICPTRET       Not anymore                       @SC88309 05387500
         BCTR  12,0          Set up for mvc                    @SC86158 05388000
         EX    12,SVCCOPY    Move to WBUF                      @SC86158 05388500
         LA    14,2(12,14)   New end                           @SC86158 05389000
         TM    13(1),X'80'   Suppress NL?                      @SC88309 05389500
         BZ    *+6           No, keep it                       @SC88309 05390000
         BCTR  14,0          Yes, append next line             @SC88309 05390500
         ST    14,SVCOPTR                                      @SC86158 05391000
ICPTRET  SR    15,15         Success                           @SC86283 05391500
         CLM   13,8,SVCEXIT  Was it an SVC?                    @SC86283 05392000
         BE    SVCDONE       Yes                               @SC86283 05392500
         LM    12,14,SVCSV1  Restore regs                      @SC86283 05393000
         BR    14            Return                            @SC86283 05393500
SVCDONE  L     12,SVCOPSW+4  Return adr                        @SC86158 05394000
         CLI   0(12),0       Error adr given?                  @SC86158 05394500
         BNE   SVCRET                                          @SC86158 05395000
         LA    14,4(12)      Yes, skip over                    @SC86158 05395500
SVCSKP   STCM  14,7,SVCOPSW+5                                  @SC86158 05396000
SVCRET   LM    12,14,SVCSV1  Restore                           @SC86158 05396500
         SR    15,15         'success'                         @SC86158 05397000
         LPSW  SVCOPSW       Return                            @SC86158 05397500
SVCCOPY  MVC   0(,14),0(15)                                    @SC86158 05398000
*                                                                       05398500
SVC203T  L     12,SVCOPSW+4  Code ptr                          @SC86158 05399000
SVCABNT  CLI   1(12),11      DMSABN?                           @SC86158 05399500
         BNE   SVCGO         No, do it                         @SC86158 05400000
SVCCNCL  MVC   SVCNPSW,SAVENPSW  Cancel interception           @SC86158 05400500
         MVC   ADMSCWR,TYPSAV                                  @SC86283 05401000
SVCGO    MVC   0(8,0),SAVENPSW   Proper SVC handler            @SC86158 05401500
         LM    12,15,SVCSV1                                    @SC86158 05402000
         LPSW  0                                               @SC86158 05402500
* Storage for SVC interception                                 @SC86158 05403000
SAVENPSW DS    D             SYSTEM  SVC NPSW                  @SC86158 05403500
SVCSNAG  DC    A(0,SVCEXIT)  My replacement                    @SC86158 05404000
SVCSV1   DS    2F            Saved 12,13                       @SC86158 05404500
SVCSV2   DS    2F            Saved 14,15                       @SC86158 05405000
SVCOPTR  DS    2F            Buffer output and end ptrs        @SC86158 05405500
SVCOCPTR DS    A             Correct ptr to SVC code           @SC89235 05406000
TYPSAV   DS    F             Saved system address              @SC86283 05406500
         LOCALS ,                                              @SC86295 05407000
SUPFNC   EXIT                                                  @SC86158 05407500
         TITLE 'TERMIO Routine - Handle terminal I/O'                   05408000
* R1 points to a pair of (adr,len) for read or write.  If I/O is        05408500
* successfull, R15 returns transferred byte count (else returns -1).    05409000
*               Command code is in R0:                                  05409500
* 1 => Open line for I/O            4 => Write packet                   05410000
* 2 => Close line                   5 => Read packet                    05410500
* 3 => Reset line status after    ( 6 => Write message ) not used       05411000
*      environment changes                                              05411500
*                                                                       05412000
TERMIO   ENTER                                                          05412500
         SR    15,15         OK                                @SC86295 05413000
         BCT   0,TRMCLS                                        @SC86295 05413500
* Open terminal line for protocol                                       05414000
         WAITT                                                          05414500
         STAX  BR14          Ingore attention interrupts                05415000
         MVI   RIOC,X'80'    Nothing saved                     @SC86295 05415500
         MVI   TRMFLG,X'FF'  Initialize w/r flag               @SC87275 05416000
         B     TRMSPRP                                         @SC87275 05416500
* Close terminal line after protocol transfer                           05417000
TRMCLS   BCT   0,TRMRSET                                       @SC86295 05417500
         STAX                                                           05418000
         B     RTRN0                                           @SC86295 05418500
* (Re)set terminal characteristics to suit environment                  05419000
TRMRSET  BCT   0,TRMRW                                         @SC86295 05419500
         B     RTRN0                                           @SC86295 05420000
*                                                                       05420500
*  Perform I/O request                                                  05421000
TRMRW    BCT   0,TRMRD                                         @SC87275 05421500
         CLI   WRRD,0        Write/read?                       @SC87275 05422000
         BE    TRMWO         No, do it immediately             @SC87275 05422500
         MVC   RIOPRP(8),0(1)  Yes, save stuff for prompt      @SC87275 05423000
         CLI   TRMTP,C'F'    Full-screen non-transparent?      @SC92030 05423500
         BNE   RTRN0         No                                @SC92030 05424000
         SR    0,0           Clear before every packet         @SC92030 05424500
         KCALL SCRNIO                                          @SC92030 05425000
         XI    FL3,FCLRF     Flip switch for skipping          @SC92030 05425500
         TM    FL3,FCLRF     Skipping now?                     @SC92030 05426000
         BZ    RTRN0         Not this time                     @SC92030 05426500
         WRTERM ' '          Yes, skip two lines               @SC92030 05427000
         WRTERM ' '                                            @SC92030 05427500
         B     RTRN0                                           @SC87275 05428000
TRMWO    MVI   TRMFLG,0      Indicate no action on follow-up   @SC87275 05428500
         B     TRMEX         Do the write                      @SC87275 05429000
TRMRD    TS    TRMFLG                                          @SC87275 05429500
         BZ    RTRN0         Just a follow-up. 0-length read   @SC87275 05430000
*                                                                       05430500
TRMEX    SLA   0,4                                             @SC87275 05431000
         LR    2,0                                             @SC92180 05431500
         SRA   2,1           Index * 8 = offset to output stuff@SC92180 05432000
         LA    8,TRMPLS                                        @SC87275 05432500
         AR    8,0           Get appropriate CCW skeleton      @SC86295 05433000
         MVC   9(3,8),1(1)   Copy adr                          @SC86295 05433500
         MVC   14(2,8),6(1)  Copy len                          @SC86295 05434000
         LA    1,8(2,8)      Ptrs for output                   @SC92180 05434500
         L     4,0(,1)       Remember them for logging data    @SC92180 05435000
         LH    5,6(,1)                                         @SC92180 05435500
         LA    2,8           Lenth of ptrs                     @SC92180 05436000
         LA    0,C'w'                                          @SC92180 05436500
         BAL   7,SCRLOG      Log it                            @SC92180 05437000
         LA    1,0(,4)       Ptr to buffer                     @SC92180 05437500
         LR    2,5           Lenth of buffer                   @SC92180 05438000
         LA    0,C'd'                                          @SC92180 05438500
         BAL   7,SCRLOG      Log it                            @SC92180 05439000
         HOST  0(8)          Issue command                     @SC86295 05439500
         CLC   TRMPLS,0(8)   Write only?                       @SC92180 05440000
         BE    TRMRLEN                                         @SC92180 05440500
         LA    1,8(,8)       Ptr for input                     @SC92180 05441000
         LA    2,8           Lenth of ptrs                     @SC92180 05441500
         LA    0,C'r'                                          @SC92180 05442000
         BAL   7,SCRLOG      Log it                            @SC92180 05442500
         L     1,8(,8)                                         @SC92180 05443000
         LA    1,0(,1)       Ptr to buffer                     @SC92180 05443500
         LH    2,14(,8)                                        @SC92180 05444000
         LA    0,C'd'                                          @SC92180 05444500
         BAL   7,SCRLOG      Log it                            @SC92180 05445000
TRMRLEN  LH    15,14(,8)     Number of chars xfer'd            @SC92180 05445500
TRMSPRP  LA    0,S1EOL       Reinstate "normal" prompt         @SC87275 05446000
         LA    1,2                                             @SC87275 05446500
         CLI   S1HND,0       Handshake desired?                @SC87275 05447000
         BNE   *+6           Yes, ok                           @SC87275 05447500
         BCTR  1,0           No, send just the EOL             @SC87275 05448000
         STM   0,1,RIOPRP                                      @SC87275 05448500
         RET                                                   @SC86295 05449000
*                                                                       05449500
TRMPLS   DS    0F            Terminal I/O plists               @SC86295 05450000
* WRTERM Plist during Kermit protocol                                   05450500
         DC    CL8'TYPLIN'                                              05451000
         DC    X'01',AL3(*-*) Send buffer address              @SC86190 05451500
         DC    C'B',X'92'    B=Black,02=No xlate,90=Long       @TB86218 05452000
         DC    H'0'          Buffer length                              05452500
* RDTERM plist during RPACK                                             05453000
         DC    CL8'WAITRD'                                              05453500
         DC    X'01',AL3(*-*) Rcv buffer addr                  @SC86190 05454000
         DC    C'*',C'B'     *:long, B:prompt/direct           @SC87201 05454500
         DC    AL2(0)        Input data length                          05455000
RIOPRP   DC    A(0,1)        Prompt                            @SC87275 05455500
         TITLE 'SCRNIO Routine - Handle screen I/O via Series/1'        05456000
* R1 points to a pair of (adr,len) for read or write.  If I/O is        05456500
* successfull, R15 returns transferred byte count (else returns -1).    05457000
*               Command code is in R0:                                  05457500
* 0 => Clear screen on console (not comm line)                 @SC90045 05458000
* 1 => Open screen for I/O            4 => Write packet                 05458500
* 2 => Close screen                   5 => Read packet                  05459000
* 3 => Reset screen status after      6 => Write message (no ATTN)      05459500
*      environment changes            7 => Read screen buffer           05460000
*                                                                       05460500
* CCW Flags, WCC flag bits, CSW flags:                                  05461000
CC       EQU   X'40'         Command chaining                  @SC86159 05461500
SLI      EQU   X'20'         Suppress Incorr Len Ind                    05462000
ATN      EQU   X'80'         Attention                                  05462500
CE       EQU   X'08'         Channel end                                05463000
DE       EQU   X'04'         Device end                                 05463500
UC       EQU   X'02'         Unit check                                 05464000
UE       EQU   X'01'         Unit exception                             05464500
CPBRK    EQU   ATN+CE+DE+UC  CP break-in                                05465000
*                                                                       05465500
SCRNIO   ENTER ALT                                             @SC92180 05466000
         LTR   0,0                                             @SC90045 05466500
         BZ    SCRCLR                                          @SC90045 05467000
         STC   0,CONSOPR     Save command code                 @LP88158 05467500
         BCT   0,SCRCLS                                        @SC86295 05468000
* Set up for transparent I/O                                            05468500
         L     1,=A(IDEFS)   CSECT of initializations          @SC90173 05469000
         USING DEFS,1        Mapped via DSECT                  @SC90173 05469500
         LA    2,S1DATA      Series/1 introducer               @SC90173 05470000
         LA    3,S1ORDL+2    Length + 2                        @SC90173 05470500
         CLI   TRMTP,C'S'                                      @SC90173 05471000
         BE    SCRPRSET      Do it                             @SC90173 05471500
         LA    2,GRDATA      Graphics introducer               @SC90173 05472000
         LA    3,GRDL+2      Length + 2                        @SC90173 05472500
         CLI   TRMTP,C'G'                                      @SC90173 05473000
         BE    SCRPRSET      Do it                             @SC90173 05473500
         LA    2,AEADAT      AEA introducer                    @SC90173 05474000
         LA    3,AEAL+2                                        @SC90173 05474500
         DROP  1                                               @SC90173 05475000
SCRPRSET LR    5,3                                             @SC90173 05475500
         LA    4,S1EOL+2     Get start of command buffer       @SC90173 05476000
         SR    4,5                                             @SC90173 05476500
         STM   4,5,S1XOPL    Set up prompt plist               @SC90173 05477000
         S     5,F2          Deduct stuff already there        @SC90173 05477500
         MVCL  4,2                                             @SC90173 05478000
         MVC   HNDFNC,HNDPAT+8  Copy function (SET)            @SC88326 05478500
         WAITT ,             Make CMS happy                             05479000
         HOST  HNDINTPL      Issue HNDINT                      @SC86295 05479500
         LA    8,SCRCCWCL    Clear screen now                  @SC86295 05480000
         BAL   9,SCRNEX                                        @SC86295 05480500
         MVI   RIOC,X'80'    Nothing saved                     @SC86295 05481000
         ICM   0,15,LCLDLY                                     @SC87268 05481500
         BZ    RTRN0         Skip extra delay                  @SC87268 05482000
         CPCMD 6,7,'SL 1 SEC' This seems useful                @HF86233 05482500
         B     RTRN0                                           @SC86295 05483000
SCRCLR   CLI   TRMTP,C'T'    Is it a TTY terminal?             @SC90045 05483500
         BE    RTRN0         Yes, can't clear screen           @SC90045 05484000
         CLI   TRMTP,C'V'    Is it a TTY terminal?             @SC90045 05484500
         BE    RTRN0         Yes, can't clear screen           @SC90045 05485000
         CLI   TRMTP,C'F'    Is it a full-screen non-transpar? @SC92030 05485500
         BE    *+12          Yes, must clear frequently        @SC92030 05486000
         TM    FL2,PROTO     In protocol mode?                 @SC90045 05486500
         BO    RTRN0         Yes, skip clearing screen         @SC90045 05487000
         WAITT ,             Wait if necessary                 @SC90045 05487500
         L     1,ADEVTAB     Ptr to device table in nucleus    @SC90045 05488000
         LH    2,0(,1)       CON1 is first device              @SC90045 05488500
         LA    1,SCRCCWCL    Clear-screen CCW                  @SC90045 05489000
         DIAG  1,2,X'58'     Start I/O via diagnose            @SC90045 05489500
         B     RTRN0                                           @SC90045 05490000
SCRCLS   BCT   0,SCRRSET                                       @SC86295 05490500
         LA    8,SCRCCWVM    Release screen                    @SC86295 05491000
         BAL   9,SCRNEX                                        @SC86295 05491500
         MVC   HNDFNC,=C'CLR '                                 @SC88326 05492000
         HOST  HNDINTPL      Issue HNDINT CLR                  @SC88326 05492500
         LA    5,=C'READY ...' Make sure hanging writes appear @SC86159 05493000
         MVC   6(3,5),CONSADH Use console vaddr                @SC86159 05493500
         LA    7,9           String length                     @SC86159 05494000
         CPCMD 5,7,RESP=YES  Suppress reply                    @SC86159 05494500
         B     RTRN0                                           @SC86295 05495000
* (Re)set device characteristics to suit environment                    05495500
SCRRSET  BCT   0,SCRRW                                         @SC86295 05496000
         B     RTRN0                                                    05496500
*                                                                       05497000
*  Perform I/O request                                                  05497500
SCRRW    MVC   SCRCCW,0(1)   Copy adr+len                      @SC88049 05498000
         LR    5,0                                             @SC88049 05498500
         CLC   =C'CON1',HNDDV  Console device?                 @SC89088 05499000
         BE    *+8           Yes, use DIAG 58 facility         @SC89088 05499500
          LA   5,4(,5)       No, use alternate CCW codes       @SC93146 05500000
         CLI   TRMTP,C'A'    AEA-type device?                  @SC90173 05500500
         BNE   *+8           No, we've got it                  @SC90173 05501000
          LA   5,8(,5)       Yes, use alternate CCW codes      @SC93146 05501500
         IC    9,SCRCCM-1(5) Get command code                  @SC88049 05502000
         STC   9,SCRCCW                                        @SC88049 05502500
         IC    9,SCRCCF-1(5) Get flags                         @SC88049 05503000
         STC   9,SCRCCW+5                                      @SC88049 05503500
         MVI   SCRCCW+4,SLI  Suppress length interrupts        @SC88049 05504000
         CLI   CONSOPR,5     Read operation next?              @SC89180 05504500
         BE    SCRE4TRY      Yes, VTAM will be happy           @SC89180 05505000
         TM    S1INTFL,ATN   Seen attention interrupt lately?  @SC89180 05505500
         BZ    SCRE4TRY      No, VTAM will be happy            @SC89180 05506000
         LA    0,C'a'        Yes, should see what he wants     @SC89180 05506500
         LA    1,CONSXSTA                                      @SC89180 05507000
         LA    2,2                                             @SC89180 05507500
         BAL   7,SCRLOG      Log the interrupt                 @SC89180 05508000
         LA    0,5                                             @SC89180 05508500
         KCALL SCRNIO,SCRRDPL Use recursive call to read       @SC89180 05509000
SCRE4TRY LA    8,SCRCCW                                        @LP88188 05509500
         BAL   9,SCRNEX      Execute internal subr             @SC86295 05510000
         CLI   CONSOPR,5     Was it a packet read?             @LP88188 05510500
         BNE   RTRN          No, continue                      @LP88188 05511000
         LTR   15,15         Did it fail?                      @LP88188 05511500
         BL    RTRN          Yes, continue                     @LP88188 05512000
         TM    FL2,PROTO     In midst of transfer?             @SC88203 05512500
         BZ    RTRN          No, must be status check          @SC88203 05513000
         L     1,0(8)        Data address                      @LP88188 05513500
         CLI   0(1),X'E4'    7171 overrun (line error)?        @LP88188 05514000
         BNE   RTRN          No, continue                      @LP88188 05514500
         LA    8,SCRE4RET    CCWs to reset transparent mode    @LP88188 05515000
         MVI   CONSOPR,4     And send a dummy packet           @LP88188 05515500
         BAL   9,SCRNEX                                        @LP88188 05516000
         MVI   CONSOPR,5     Do the read again                 @LP88188 05516500
         B     SCRE4TRY      Loop until no more E4 reply       @LP88188 05517000
*                                                                       05517500
*---- Subroutine of SCRNEX (must preserve R4,R8,R9) ----------*@SC91039 05518000
* Execute chnnl pgm; detect errors; wait for completion;       @SC91039 05518500
*  log CSW after completion; exit to SCRNEX handler if error;  @SC91039 05519000
*  wait for subsequent ATTN if write/read oprn.                @SC91039 05519500
* Entry: R1->pgm, R2=vaddr, R7->return                         @SC91039 05520000
* Normal exit: clobber 0,1,2,3,15 and return                   @SC91039 05520500
* Error exit: clobber 0,1,2,3,15 and branch to SCRERR          @SC91039 05521000
SCRXCT   ENABLE INTTYPE=NONE      Disable all interrupts       @XN89235 05521500
         ST    1,STMSCNS     Save ptr to channel pgm           @SC90222 05522000
         TM    0(1),X'F0'    Special console-type CCW?         @SC91039 05522500
         BZ    SCRXNODI      No, avoid DIAG 58                 @SC91039 05523000
         CLC   =C'CON1',HNDDV  Console device?                 @SC89088 05523500
         BE    SCRXDIAG      Yes, use DIAG 58 facility         @SC89088 05524000
SCRXNODI DS    0H                                              @SC91039 05524500
         AIF   ('&KTAG' NE 'XA').CMSXA2                        @SC90067 05525000
         TM    FLGXA,XACMS   In 370/XA mode?                   @SC89235 05525500
         BZ    SCRXSIO       No, do SIO                        @XN89235 05526000
         MVC   SCRORB+5(2),=X'40FF' Set various flags          @XN89235 05526500
         ST    1,ORBCPA      Set Channel Program Address       @XN89235 05527000
         GETSID DEVICE=(2)   Get subchannel number in R1       @XN89235 05527500
         SSCH  SCRORB        Start the I/O operation           @XN89235 05528000
         BNZ   SCRERR        Error if not CC=0                 @XN89235 05528500
         B     SCRXTSCH      Drain the status                  @XN89235 05529000
SCRXSIO  DS    0H                                              @XN89235 05529500
.CMSXA2  ANOP                                                  @SC90067 05530000
         DMSEXS MVC,CAW(4),STMSCNS  Use basic SIO              @SC90222 05530500
         SIO   0(2)                                            @SC89088 05531000
         BC    2,SCRBUSY     Maybe try again                   @SC91039 05531500
         BC    4,SCRXTIOS    Completed already, check status   @SC91039 05532000
         BNZ   SCRERR        I/O error case                    @XN89235 05532500
         B     SCRXTIO       Drain status                      @XN89235 05533000
SCRXDIAG DIAG  1,2,X'58'     Start I/O via diagnose            @SC89088 05533500
         BNZ   SCRXERR       I/O error                         @SC91039 05534000
         AIF   ('&KTAG' NE 'XA').CMSXA3                        @SC90067 05534500
         TM    FLGXA,XACMS   In 370/XA mode?                   @SC89235 05535000
         BZ    SCRXTIO       No, do TIO                        @SC89235 05535500
         GETSID DEVICE=(2)   Get subchannel number in R1       @SC89235 05536000
SCRXTSCH TSCH  SCRSUBAR      Test status of device             @SC89235 05536500
         BC    4,SCRXTSCH    Loop until status pending         @XN89235 05537000
         BC    1,SCRERR      Error if not there now ! (??)     @XN89235 05537500
SCRXTSCS MVC   CONSCSW(8),IRBCSW Grab status                   @SC91039 05538000
         B     SCRXTIOO      Rejoin 370 mode                   @SC89235 05538500
.CMSXA3  ANOP                                                  @SC90067 05539000
SCRXTIO  DS    0H                                              @SC89235 05539500
         TIO   0(2)          Test for completion               @SC89088 05540000
         BNZ   *-4           Keep waiting                      @SC89088 05540500
SCRXTIOS MVC   CONSCSW(8),CSW    Grab status                   @SC91039 05541000
SCRXTIOO DS    0H                                              @XN89235 05541500
         MVI   CONSATN,0     Haven't waited for attention yet  @SC90222 05542000
         CLI   CONSOPR,4     Doing a write/read?               @SC89088 05542500
         BNE   SCRXOK        No, we don't need any interrupts  @SC89088 05543000
         TM    CONSUNIT,255-CE-DE Already got attn or error?   @SC91081 05543500
         BNZ   SCRXOK        Yes, don't wait at all            @SC91081 05544000
         CLI   TRMTP,C'S'    S/1?                              @SC90173 05544500
         BE    *+12                                            @SC90173 05545000
          CLI  WRRD,0        Only writing?                     @SC90173 05545500
          BE   SCRXOK        Yes, expect no ATTN               @SC90173 05546000
         HOST  HNDWAIT       Wait for I/O to complete          @SC88326 05546500
         MVI   CONSATN,ATN   Signal attention seen             @SC90222 05547000
SCRXOK   DS    0H                                              @SC89088 05547500
         ENABLE INTTYPE=ALL  Reenable interrupts               @XN89235 05548000
         CLI   CONSCHAN,0                                      @LP88186 05548500
         BNE   SCRERRC       Go if ch error                    @SC90222 05549000
         TM    CONSUNIT,X'73' Any unit error?                  @LP88186 05549500
         BNZ   SCRERRC                                         @LP88186 05550000
         LA    0,C'i'        "good interrupt" label            @SC89166 05550500
*        B     SCRLOGI       Log it fall through               @LP88186 05551000
*                                                                       05551500
* SCRLOG: Hexadecimal log of (R2) bytes at address (R1)        @LP88158 05552000
* Log label is taken from R0 low order byte.                   @SC89166 05552500
* Return via R7.  R0-R3 and R15 destroyed.                     @SC89166 05553000
SCRLOGI  DS    0H            Special entry to log interrupts   @LP88158 05553500
         LA    1,CONSCSW                                       @SC89166 05554000
         LA    2,CONSTLEN                                      @LP88158 05554500
SCRLOG   TM    FL1,DEBUG     Logging in effect?                @SC87286 05555000
         BZR   7             No, that's all                    @SC89166 05555500
         TM    DBGFLG,DBGIO  I/O stuff requested?              @SC88168 05556000
         BZR   7             No, skip it                       @SC89166 05556500
         L     3,LOGBUF      Ptr to buffer                     @LP88158 05557000
         STC   0,0(,3)       Set log label                     @SC89166 05557500
         LA    3,2(,3)       Start of data area                @SC91172 05558000
         TM    DBGFLG,DBGTI  Times requested?                  @SC91172 05558500
         BZ    SCRLOGA       No, just do hex dump              @SC91172 05559000
         ST    1,SCRLR1      Save ptr to block                 @SC91172 05559500
         BAL   14,ACCTTOD    Get time of day in seconds        @SC91172 05560000
         MVI   0(3),C' '     Leave a space                     @SC91172 05560500
         KCALL DUMPTOD,1(3)  Format time into buffer           @SC91172 05561000
         LR    3,15          Get ptr to end of string          @SC91172 05561500
         L     1,SCRLR1      Restore R1                        @SC91172 05562000
SCRLOGA  LA    0,6*9(,3)     End of line buffer                @SC91172 05562500
         TM    DBGFLG,DBGLO  Long buffer requested?            @SC90222 05563000
         BZ    *+8                                             @SC90222 05563500
          LA   0,50*9(,3)    Yes, long buffer                  @SC91172 05564000
SCRLOGLP MVI   0(3),C' '     Add for readability               @LP88158 05564500
         UNPK  1(9,3),0(5,1) Unpack into buffer                @SC88168 05565000
         TR    1(8,3),TRHEX  Convert to printable hex          @SC88168 05565500
         LA    3,9(3)        Advance text ptr                  @SC88168 05566000
         LA    1,4(1)        and data source                   @LP88158 05566500
         S     2,F4          Finished data?                    @SC88168 05567000
         BNP   SCRLGEND      Yes, go write                     @LP88158 05567500
         CR    3,0           Reached text limit?               @LP88158 05568000
         BL    SCRLOGLP      no, loop for more slices          @LP88158 05568500
         MVC   0(3,3),=C'...' Show incomplete                  @LP88158 05569000
         LA    3,3(3)                                          @SC88168 05569500
SCRLGEND DS    0H                                              @LP88158 05570000
         AR    2,2           Check for incomplete slice        @SC88168 05570500
         BNM   *+6           No, ok                            @SC88168 05571000
         AR    3,2           Yes, adjust end of text           @SC88168 05571500
         S     3,LOGBUF      Get length of text                @SC88168 05572000
         WRITF LOGPTR,BSIZE=(3) Log it                         @LP88158 05572500
         TM    DBGFLG,DBGSV  SAVE requested?                   @SC88168 05573000
         BZR   7             No, skip closing log file         @SC89166 05573500
         SAVEF LOGPTR        Update disk directory             @SC88168 05574000
         BR    7                                               @SC89166 05574500
*                                                                       05575000
*--- Major I/O routine: execute chnnl pgm w/ error recovery ---@SC91039 05575500
* Entry: R8->pgm, R9->return                                   @SC91039 05576000
*   Log pgm; wait for device ready; call SCRXCT to execute;    @SC91039 05576500
*   log data buffer; errors in SCRXCT fall out into retry loop.@SC91039 05577000
* Exit: clobber 0,1,2,3,4,5,7 and set R15= useful data length  @SC91039 05577500
*   (or -1 if error)                                           @SC91039 05578000
SCRNEX   LA    4,10          CP BREAKIN recovery retry count   @LP88186 05578500
         NI    S1INTFL,255-ATN Clear pending attention, if any @SC89180 05579000
SCRNEXLP LR    1,8           Get CCW ptr                       @SC91039 05579500
         SLR   2,2           Convert op. code to log label     @LP88158 05580000
         IC    2,CONSOPR                                       @LP88158 05580500
         LA    2,CONSOPRS(2)                                   @LP88158 05581000
         IC    0,0(,2)                                         @SC89166 05581500
         LA    2,8           Size of one CCW                   @LP88158 05582000
         TM    4(1),CC       Command chained?                  @LP88158 05582500
         BZ    *+8                                             @LP88158 05583000
         LA    2,8(2)        Yes, add another                  @LP88158 05583500
         BAL   7,SCRLOG      CCWs logged                       @SC89166 05584000
         LH    2,CONSADDR            Console address                    05584500
         AIF   ('&KTAG' NE 'XA').CMSXA4                        @SC90067 05585000
         TM    FLGXA,XACMS   In 370/XA mode?                   @SC89235 05585500
         BZ    SCRTIO        No, do TIO                        @SC89235 05586000
         GETSID DEVICE=(2)   Get subchannel number in R1       @XN89235 05586500
SCRTSCH  TSCH  SCRSUBAR      Test status of console            @XN89235 05587000
         BZ    SCRTSCH       Loop if status stored             @XN89235 05587500
         B     SCRTIOO       Rejoin 370 mode                   @SC89235 05588000
SCRTIO   DS    0H                                              @SC89235 05588500
.CMSXA4  ANOP                                                  @SC90067 05589000
         TIO   0(2)                  See if usable                      05589500
         BC    6,*-4                 Loop if busy or CSW stored         05590000
SCRTIOO  DS    0H                                              @SC89235 05590500
         BC    1,SCRERR              not operational: error             05591000
         LR    1,8           Copy CCW adr                      @SC89088 05591500
         BAL   7,SCRXCT      Execute and wait for completion   @SC89166 05592000
         BAL   7,SCRLOGD     Log data and get count in R5      @SC90222 05592500
         LR    15,5                                            @LP88186 05593000
         TM    0(8),1        Is it a channel read?             @LP88186 05593500
         BOR   9             No, size OK                       @LP88186 05594000
         S     15,WRCMDL+4   Deduct 3 for buffer adr           @SC90173 05594500
         BNLR  9                                               @LP88186 05595000
         SLR   15,15                                           @LP88186 05595500
         BR    9             Return to caller                  @LP88186 05596000
*                                                                       05596500
* Alternate entry to SCRLOG for logging data buffer.           @SC91039 05597000
*    Also returns data count in R5.                            @SC91039 05597500
SCRLOGD  L     1,STMSCNS     Get ptr to channel pgm            @SC90222 05598000
         LH    5,6(,1)       Buffer size                       @SC90222 05598500
         SH    5,CONSBYTC    Minus residual count              @LP88186 05599000
         L     1,0(,1)       Data address                      @SC90222 05599500
         LA    0,C'd'        "Data" label                      @SC89166 05600000
         LR    2,5           Data size                         @LP88186 05600500
         B     SCRLOG        Go log it                         @SC90222 05601000
*                                                                       05601500
*---- Error handler within SCRNEX - retry and loop or exit ----@SC91039 05602000
*                                                                       05602500
SCRXERR  DS    0H                                              @SC91039 05603000
         AIF   ('&KTAG' NE 'XA').CMSXA4B                       @SC91039 05603500
         TM    FLGXA,XACMS   In 370/XA mode?                   @SC91039 05604000
         BZ    SCRXETIO      No, do TIO                        @SC91039 05604500
         GETSID DEVICE=(2)   Get subchannel number in R1       @SC91039 05605000
         TSCH  SCRSUBAR      Test status of device             @SC91039 05605500
         BC    1,SCRERR      Error if not there now ! (??)     @SC91039 05606000
         BC    2,SCRBUSY                                       @SC91039 05606500
         B     SCRXTSCS      Go grab status                    @SC91039 05607000
SCRXETIO DS    0H                                              @SC91039 05607500
.CMSXA4B ANOP                                                  @SC91039 05608000
         TIO   0(2)          DIAG failed, find out why         @SC91039 05608500
         BC    1,SCRERR      Dead device                       @SC91039 05609000
         BC    2,SCRBUSY                                       @SC91039 05609500
         B     SCRXTIOS      Something happened after all      @SC91039 05610000
*                                                                       05610500
SCRERRC  DS    0H            Fatal I/O error                   @LP88186 05611000
         LA    0,C'e'        Indicate error interrupt or CC    @SC89166 05611500
         BAL   7,SCRLOGI     Log it                            @SC89166 05612000
         BAL   7,SCRLOGD     Log data, if any                  @SC90222 05612500
         CLI   CONSUNIT,CPBRK CP stole the screen?             @SC89088 05613000
         BNE   SCRERR        Bin                               @LP88186 05613500
         BCT   4,SCRBRK      Go recover unless retries exhaust @LP88186 05614000
         B     SCRERR        Give up                           @SC91039 05614500
SCRBUSY  BCT   4,SCRNEXLP    Retry without recovery            @SC91039 05615000
SCRERR   SR    15,15                                           @SC86295 05615500
         BCTR  15,0          Return error code of -1           @SC86295 05616000
         ENABLE INTTYPE=ALL  Reenable interrupts               @XN89235 05616500
         BR    9                                               @SC86295 05617000
SCRBRK   DS    0H            CP BREAKIN recovery               @LP88186 05617500
         LA    1,RTRYIO                                        @LP88186 05618000
         LA    0,C'b'        Log BREAKIN recovery CCW          @SC89166 05618500
         C     1,STMSCNS     Were we already trying to recover?@SC91039 05619000
         BE    SCRBRKRD      Yes, must issue a READ            @SC91039 05619500
         LA    2,16                                            @LP88186 05620000
         BAL   7,SCRLOG                                        @SC89166 05620500
         LA    14,=C'RESET ...'                                @LP88186 05621000
         MVC   6(3,14),CONSADH Use console vaddr               @LP88186 05621500
         LA    0,9           String length                     @LP88186 05622000
         CPCMD 14,0,RESP=YES Reply to buffer                   @LP88186 05622500
         LA    1,RTRYIO                                        @LP88186 05623000
         LH    2,CONSADDR    Console address                   @LP88186 05623500
         OI    CONSOPR,X'80' Flag to avoid waiting for ATTN    @LP88186 05624000
         BAL   7,SCRXCT      Take the screen back              @SC89166 05624500
         NI    CONSOPR,X'7F' Restore as request                @LP88186 05625000
         B     SCRNEXLP      Try again                         @SC91039 05625500
SCRBRKRD LA    2,16                                            @SC91039 05626000
         LA    1,RTRYIO2     Next try to read                  @SC91039 05626500
         BAL   7,SCRLOG                                        @SC91039 05627000
         LA    1,RTRYIO2     Next try to read                  @SC91039 05627500
         LH    2,CONSADDR    Console address                   @SC91039 05628000
         OI    CONSOPR,X'80' Flag to avoid waiting for ATTN    @SC91039 05628500
         BAL   7,SCRXCT      Read the screen                   @SC91039 05629000
         NI    CONSOPR,X'7F' Restore as request                @SC91039 05629500
         B     SCRBRK        Now try again to clear it         @SC91039 05630000
         DS    0D                                                       05630500
SCRCCWCL DC    X'19',AL3(0),AL1(SLI),X'FF',AL2(1)                       05631000
SCRCCWVM DC    X'19',AL3(0),AL1(SLI),X'FE',AL2(1)                       05631500
RTRYIO2  CCW   X'0A',SCRSENSE,SLI+CC,5 CMS normal read         @SC91039 05632000
         CCW   X'03',0,SLI,1                                   @SC91039 05632500
*                                                                       05633000
RTRYIO   DC    0D'0',X'19',AL3(0),AL1(CC+SLI),X'FF',AL2(1)     @SC86159 05633500
         DC    X'29',AL3(RTRYCM),AL1(SLI),X'90',AL2(1)         @TB88078 05634000
RTRYCM   DC    &S1CMD                                          @SC90264 05634500
*                                                                       05635000
SCRE4RET DS    0D                                              @LP88188 05635500
*        DC    X'29',AL3(SCRE4LTM),AL1(SLI+CC),X'90',Y(SCRE4LTL) C91178 05636000
         DC    X'29',AL3(SCRE4DWR),AL1(SLI),X'00',Y(SCRE4DWL)  @SC88168 05636500
*CRE4LTM DC    X'40',AL1(SBA),X'4040',AL1(ICR),X'4040' Reset   @SC91178 05637000
*CRE4LTL EQU   *-SCRE4LTM    Length of command                 @SC91178 05637500
SCRE4DWR DC    X'C2',AL1(SBA),X'5D7F',AL1(SBA),X'000180' packet@SC88168 05638000
SCRE4DWL EQU   *-SCRE4DWR    Length of command                 @SC88168 05638500
*              --DIAG58--- ---SIO----- --DIAG58--- ---SIO----- @SC93146 05639000
*              W  R  WM RB W  R  WM RB W  R  WM RB W  R  WM RB @SC93146 05639500
SCRCCM   HTBL  29,2A,29,2A,01,06,05,02,29,2A,29,2A,11,06,05,02 @SC93146 05640000
SCRCCF   HTBL  00,80,90,00,00,00,00,00,20,80,90,00,00,00,00,00 @SC93146 05640500
*        Use x'10' flag in the writemsg CCW flag byte to       @TB88078 05641000
*        prohibit VM/XA DIAG58 from issuing Read Modifieds     @TB88078 05641500
*        to check for PA1                                      @TB88078 05642000
         TITLE 'SETMSG Routine - controls CP breakin'                   05642500
* Entry: R1 selects operation                                           05643000
* Exit: R15=0 if ok                                                     05643500
* 1-> Analyze user environment, determine if suitable.                  05644000
*     Save quantities needed and condition line for entering commands.  05644500
*     Perform any system-dependent initialization.                      05645000
* 2-> Condition line for protocol transfers.                            05645500
* 3-> Decondition line at end of transfer.                              05646000
* 4-> System-dependent clean-up at exit.                                05646500
* 5-> Reperform system-dependent initialization after SET LINE.         05647000
SETMSG   ENTER ALT                                             @SC86295 05647500
         BCT   1,STM2                Go if R1 not 1, so no init         05648000
         L     1,ORGR1                                         @SC88049 05648500
         MVC   KRMNAM,0(1)   Copy original invoked name        @SC88049 05649000
         L     2,CBUF        Put diag result here                       05649500
         LA    3,32          Get this much info                         05650000
         DIAG  2,3,X'00'     Identify                                   05650500
         MVC   USRTAKE,16(2) Move userid to our buffer                  05651000
         MVC   HNDINTPL(LHNDWT),HNDPAT Init HNDINT             @SC88326 05651500
         L     1,ASTMUSET                                      @SC87117 05652000
         MVC   8(9,1),=C'MACHINE -'                            @SC89235 05652500
         CPCMD 2,4,'Q SET',RESP=YES                            @SC86148 05653000
         MVC   ADR,CBUF              Response address for parser        05653500
         ST    5,LEN                 Response length for parser         05654000
         MVC   STMSCNS(8),SCANPTR Save string ptrs             @SC89235 05654500
         SR    5,5           Length of previous data           @SC89235 05655000
         LA    8,STMMLEN-2   Descriptor list for MACHINE       @SC89235 05655500
         BAL   2,STMGET                                        @SC89235 05656000
         L     1,ASTMUSET                                      @SC89235 05656500
         CLI   8+8(1),C'-'   Is it VM/XA?                      @SC89235 05657000
         BE    STMVMSP       No, remember that                 @SC89235 05657500
         OI    FLGXA,XACP    CP is VM/XA                       @SC89235 05658000
         CLI   8+8(1),C'3'   Is it in 370 mode?                @SC89235 05658500
         BE    STMVMSP       Yes, remember that                @SC89235 05659000
         OI    FLGXA,XACMS   CMS is in XA mode                 @SC89235 05659500
         WRTERM '&NONXAMS'                                     @SC89235 05660000
         B     RTRN1         Too bad, give up                  @SC89235 05660500
STMVMSP  DS    0H                                              @SC89235 05661000
         MVC   0(STMUL+STMLL,1),STMUOFF Set up pattern         @SC87117 05661500
         S     1,F4          Start of list: back 8, up L'SET +1@SC87117 05662000
         SR    5,5           Length of previous data           @SC86148 05662500
         LA    8,STMLEN-2    Descriptor list                   @SC86148 05663000
         MVC   SCANPTR(8),STMSCNS Restore ptrs                 @SC89235 05663500
         BAL   2,STMGET                                        @SC89235 05664000
         BAL   2,STMGET                                        @SC89235 05664500
         MVC   SCANPTR(8),STMSCNS Restore ptrs again           @SC89235 05665000
         LA    4,5           Number of items in QUERY SET      @SC89235 05665500
         BAL   2,STMGET                                        @SC86295 05666000
         BCT   4,*-4                                           @SC86148 05666500
         CPCMD 2,6,'Q TERM',RESP=YES                           @SC86148 05667000
         MVC   ADR,CBUF              Response address for parser        05667500
         ST    7,LEN         Response length for parser        @SC87117 05668000
         LA    1,1(1)        One extra: L'TERM - L'SET         @SC87117 05668500
         BAL   2,STMGET                                        @SC86295 05669000
         BAL   2,STMGET                                        @SC92030 05669500
         BAL   2,STMGET      (if more: put S 1,F4 in loop)     @SC87295 05670000
*          Note: KWRKBASE is 11...                             @SC89268 05670500
         STM   10,11,STMSAVR Save base registers               @SC87117 05671000
         HOST  STMEXC        Set up subcommand environment     @SC87117 05671500
         B     STM5X                                           @SC87351 05672000
         DS    0F                                              @SC87117 05672500
STMEXC   DC    CL8'SUBCOM',CL8'KERMIT'                         @SC87117 05673000
         DC    F'0',A(STMSUBC,0)                               @SC87117 05673500
STMEXDRP DC    CL8'SUBCOM',CL8'KERMIT'                         @SC92112 05674000
         DC    F'0',A(0),8X'FF'                                @SC92112 05674500
*                                                                       05675000
STM2     BCT   1,STM3                Go if R1 was not 2, so not off     05675500
         TM    FL1,TSTF                                        @SC86295 05676000
         BO    RTRN0         Just testing, don't change it     @SC86295 05676500
         LA    2,STMUOFF             Set everything off                 05677000
         MVC   STMUOTB,AOUTRTBL Save user's table ptrs         @SC87201 05677500
         MVC   STMUITB,AINTRTBL                                @SC87201 05678000
         LA    7,F0          Set to turn off translation       @SC87201 05678500
         LR    8,7                                             @SC87201 05679000
         B     STMD                                                     05679500
*                                                                       05680000
STM3     BCT   1,STM4                                          @SC86316 05680500
         L     2,ASTMUSET    Restore user's settings           @SC87117 05681000
         LA    7,STMUITB     Restore user's table ptrs         @SC87201 05681500
         LA    8,STMUOTB                                       @SC87201 05682000
STMD     LA    4,STMUL       Length of 1st batch               @SC87117 05682500
         LA    5,0(2,4)      Start of 2nd                      @SC87117 05683000
         LA    6,STMSPL      Length of VM/SP-only stuff        @SC89235 05683500
         TM    FLGXA,XACP    Is it VM/SP?                      @SC89235 05684000
         BZ    *+8                                             @SC89235 05684500
          AR   2,6           No, skip that stuff               @SC89235 05685000
          SR   4,6                                             @SC89235 05685500
         CPCMD 2,4           Issue a bunch of CP commands      @SC87117 05686000
         BAL   14,TTYCHK     Line mode?                        @SC92030 05686500
          B    STMDTT        Yes, do line-mode stuff           @SC92030 05687000
         B     RTRN0         No, skip line-mode stuff          @SC92030 05687500
STMDTT   DS    0H                                              @SC92030 05688000
         DMSEXS MVC,AINTRTBL,0(7)   Restore input table        @SC87201 05688500
         DMSEXS MVC,AOUTRTBL,0(8)   Restore output table       @SC87201 05689000
         LA    7,STMLL                                         @SC87295 05689500
         CPCMD 5,7,RESP=YES  No, do linemode stuff             @SC87295 05690000
         B     RTRN0                                                    05690500
*                                                                       05691000
STM4     BCT   1,STM5        Special clean-up                  @SC87351 05691500
         HOST  STMEXDRP      Drop subcommand environment       @SC92112 05692000
         B     RTRN0                                           @SC92112 05692500
*                                                                       05693000
STM5     DS    0H            Re-init after SET LINE            @SC87351 05693500
STM5X    SR    2,2                                             @SC86295 05694000
         BCTR  2,0                                             @SC86295 05694500
         MVI   TRMTP,C'N'    Assume bad until validated        @SC90173 05695000
         CLI   TRMLIN,C' '   External line?                    @SC87351 05695500
         BE    STM5D         No, use console                   @SC87351 05696000
         TR    TRMLIN,UPCASE                                   @SC88120 05696500
         LA    5,3+1         Allow no more than 3 hex digits   @SC87351 05697000
         SR    2,2           Init value                        @SC87351 05697500
         LA    1,TRMLIN      Ptr to string                     @SC87351 05698000
STM5L    CLI   0(1),C' '     Look for end of value             @SC87351 05698500
         BE    STM5D         Ok, got number                    @SC87351 05699000
         IC    3,0(1)                                          @SC87351 05699500
         CLI   0(1),C'0'     0-9?                              @SC87351 05700000
         BL    STM5LA                                          @SC87351 05700500
         CLI   0(1),C'9'                                       @SC87351 05701000
         BH    RTRN1         Bad digit                         @SC87351 05701500
         B     STM5LS        Ok, use it                        @SC87351 05702000
STM5LA   CLI   0(1),C'A'     A-F?                              @SC87351 05702500
         BL    RTRN1         Bad                               @SC87351 05703000
         CLI   0(1),C'F'                                       @SC87351 05703500
         BH    RTRN1         Bad                               @SC87351 05704000
         LA    3,9(3)        OK, get in binary                 @SC87351 05704500
STM5LS   SLL   3,28          Convert to nybble                 @SC87351 05705000
         SLDL  2,4                                             @SC87351 05705500
         LA    1,1(1)        Keep scanning                     @SC88049 05706000
         BCT   5,STM5L                                         @SC87351 05706500
         B     RTRN1         String too long                   @SC87351 05707000
STM5D    SR    3,3           Clear result register             @SC91311 05707500
         DIAG  2,3,X'24'     Get console flags                 @SC91311 05708000
         CLM   3,8,=X'40'    Is it a dedicated GRAF dev?       @SC88203 05708500
         BE    *+12          Yes, ok                           @SC88203 05709000
         CLM   3,8,=X'8020'  Is this a terminal?               @SC87351 05709500
         BNE   RTRN1         No, bad device                    @SC87351 05710000
         MVI   TRMTP,C'&KCONT'  1st assume TTY                 @SC88309 05710500
         STH   2,CONSADDR    Save console addr (CUU)                    05711000
         UNPK  CONSADH(4),CONSADDR(3)                          @SC86159 05711500
         TR    CONSADH(3),TRHEX  Save as chars                 @SC86159 05712000
         L     5,ADEVTAB     Ptr to system device table        @SC88326 05712500
         LA    6,DEVSIZE     Size of table item                @SC88326 05713000
         L     7,ATABEND     End of table                      @SC88326 05713500
         CLM   2,3,0(5)      Check device vaddr                @SC89235 05714000
         BE    STM5HL        Found it, use this name           @SC88326 05714500
         BXLE  5,6,*-8                                         @SC88326 05715000
         LA    5,HNDPATDV-4  Not found, use default name       @SC88326 05715500
STM5HL   MVC   HNDDV,4(5)                                      @SC88326 05716000
         MVC   WAITDV,4(5)                                     @SC88326 05716500
         CLM   4,8,=X'8020'  Is this an SNA 3770/3767 or TTY?  @2L90270 05717000
         BE    RTRN0         Yes, all set                      @SC88203 05717500
         SR    1,1           Assume Query not allowed          @SC91311 05718000
         L     4,RIOPTRS     Get more info                     @SC91311 05718500
         L     6,RIOPTRS+4   Length allowed                    @SC91311 05719000
         LR    7,6           Extra copy                        @SC91311 05719500
         LR    5,2           Get vaddr                         @SC91311 05720000
         DIAG  4,6,X'8C'     Ask for the info                  @SC91311 05720500
         LTR   5,5           Did it work?                      @SC91311 05721000
         BNZ   STMGRS        No, give up                       @SC91311 05721500
         LTR   6,6           Supposed residual count           @SC91311 05722000
         BM    STMGRS        Something wrong                   @SC91311 05722500
         SR    7,6           Length of info                    @SC91311 05723000
         CH    7,=H'6'       Basic info always returned        @SC91311 05723500
         BNH   STMGRS        No Query info                     @SC91311 05724000
         LA    1,STCQBIT     Ok, Query is allowed              @SC91311 05724500
STMGRS   DS    0H                                              @SC91311 05725000
         O     1,=A(&CONOPTS)                        Options   @SC91311 05725500
         KCALL SETCON        Find out just what kind...        @SC91311 05726000
         B     RTRN0                                                    05726500
*                                                                       05727000
* Parse CP response for token pointed by R1:  <len-1> token             05727500
* On entry:    R1 = ptr-8-R5 of name in user list              @SC86148 05728000
*              R5 = length of previous token                   @SC86148 05728500
*              R8 = ptr to previous len-1 of name,data         @SC86148 05729000
* On exit:     R1,R5,R8 updated                                @SC86148 05729500
*              value copied into user list                     @SC86148 05730000
*                                                                       05730500
STMGET   LA    8,2(8)        Point to next descriptor          @SC86148 05731000
         LA    1,8(5,1)      Advance to next name              @SC86148 05731500
         IC    5,1(8)        Get length of data                @SC86148 05732000
STMGET1  NTOKN N=0(2)        Pick next token                   @SC86295 05732500
         CLM   7,1,0(8)      Is this the same size we want?    @SC86148 05733000
         BNE   STMGET1       Not the size we want              @SC86148 05733500
         EX    7,STMGETC             is it right one?                   05734000
         BNE   STMGET1       Nope, keep on looking             @SC86148 05734500
         AR    1,7           Space over name                   @SC86148 05735000
         NTOKN N=0(2)        Use the next token                @SC86316 05735500
         EX    5,STMGETM     Copy value                        @SC86148 05736000
         BR    2                                               @SC86295 05736500
*                                                                       05737000
STMGETC  CLC   0(,1),0(6)    Check token against list          @SC86148 05737500
STMGETM  MVC   2(,1),0(6)    Save value in list                @SC86148 05738000
*                                                                       05738500
*                  ACNT TIME                         -- SET    @SC89235 05739000
STMLEN   DC    AL1(03,2,04,3)                                  @SC89235 05739500
*                  MSG  WNG  RUN  EDIT IMSG          -- SET    @SC89235 05740000
         DC    AL1(02,3,02,3,02,2,06,2,03,3)                   @SC89235 05740500
*                  TABC SIZE SCRL                    -- TERM   @SC92030 05741000
         DC    AL1(06,1,07,2,05,3)                             @SC92030 05741500
*                                                                       05742000
STMUOFF  EQU   *       Start of CP commands to set all off     @SC89235 05742500
         DC    C'SET ACNT OFF',X'15'                           @SC89235 05743000
         DC    C'SET TIMER OFF ',X'15'                         @SC89235 05743500
STMSPL   EQU   *-STMUOFF     Amount to skip if VM/XA           @SC89235 05744000
         DC    C'SET MSG OFF ',X'15'                           @SC89235 05744500
         DC    C'SET WNG OFF ',X'15' (in order of CP msgs)              05745000
         DC    C'SET RUN ON ',X'15'                                     05745500
         DC    C'SET LINEDIT OFF',X'15'                        @SC88194 05746000
         DC    C'SET IMSG OFF ',X'15'                          @SC87117 05746500
STMUL    EQU   *-STMUOFF                                       @CR86321 05747000
STMLOFF  DC    C'TERM TABCHAR OF'                              @SC92030 05747500
         DC    C'     LINESIZE OFF'                            @SC92030 05748000
         DC    CL5' ',C'SCROLL CONT'  (if more, cut to 1 sp)   @SC87295 05748500
STMLL    EQU   *-STMUOFF-STMUL                                 @SC87117 05749000
STMMLEN  DC    AL1(06,2)     Descriptor for MACHINE            @SC89235 05749500
         TITLE 'STMSUBC Routine - subcommand environment handler'       05750000
         USING STMSUBC,15                                      @SC87117 05750500
STMSUBC  STM   14,12,12(13)  Save registers                    @SC87117 05751000
         LM    10,11,STMSAVR Get base registers                @SC87117 05751500
         LA    0,USNTRFLX    Length of locals                  @SC87117 05752000
         BAL   14,SUBENT     Set up entry                      @SC87117 05752500
         LR    15,KSUBBASE   Recover local base register       @SC89268 05753000
         LR    2,0           Save ptr to EPLIST                @SC87117 05753500
         LA    0,RTRNUM      Set to return error code          @SC87117 05754000
         L     1,=A(USNCMDX) All commands but QUIT             @SC87117 05754500
         BAL   14,LOOPS                                        @SC87117 05755000
         L     KSUBBASE,=A(USNTRF) Ptr to main loop routine    @SC89268 05755500
         LM    15,0,4(2)     Ptrs to command and end           @SC87117 05756000
         SR    0,15          Get length                        @SC87117 05756500
         LA    1,CMD                                           @SC87117 05757000
         MVC   0(256,1),0(15) Copy to buffer                   @SC87117 05757500
         OI    KFLG-USNTRFSV(13),CMDC+SIGN Indicate just 1 cmd @SC87117 05758000
         B     LUPPRS                                          @SC87117 05758500
         TITLE 'S1INT Routine - interrupt handler'                      05759000
         USING S1INT,15                                        @SC86295 05759500
S1INT    DS    0H                                              @SC89088 05760000
         STCM  3,12,CONSXSTA Save status bytes                 @SC89180 05760500
         TM    CONSXSTA,ATN  Attention received?               @SC89180 05761000
         BZ    S1IOK         No, forget it                     @SC89180 05761500
         OI    S1INTFL,ATN   Yes, remember it                  @SC89180 05762000
S1IOK    SR    15,15         R15=0-> intrpt proc complete               05762500
         BR    14                                              @SC86295 05763000
         DROP  15                                              @SC86295 05763500
*                                                                       05764000
* HNDINT Plist for Series/1 interrupt handling                          05764500
HNDPAT   DC    CL8'HNDINT'   HNDINT plist                      @SC88326 05765000
         DC    CL4'SET'      Set function                               05765500
HNDPATDV DC    CL4'CONK'     Symbolic device (or CON1)         @SC88326 05766000
         DC    AL4(S1INT)    S1 Interrupt handler                       05766500
         DC    AL2(9)        Console address (fill in)         @SC88326 05767000
         DC    CL2'AC'                                         @SC91095 05767500
         DC    4X'FF'                                          @SC88326 05768000
         DC    CL8'WAIT'                                       @SC88326 05768500
LHNDWT   EQU   *-HNDPAT                                        @SC88326 05769000
*                                                                       05769500
CONSCSW  DS    A             (key + cc)(1) + CCW addr(3)                05770000
CONSUNIT DS    X             Unit status                                05770500
CONSCHAN DS    X             Channel status                             05771000
CONSBYTC DS    H             Byte count                                 05771500
CONSATN  DS    X             Flag for ATN seen, etc.           @SC90222 05772000
CONSTLEN EQU   *-CONSCSW     End of console status log area    @LP88158 05772500
*                                                                       05773000
SCRRDPL  DC    A(SCRSENSE,L'SCRSENSE)                          @SC89180 05773500
SCRSENSE DS    XL10          Buffer for ATN-triggered read     @SC89180 05774000
CONSXSTA DS    XL2           Status bytes saved on interrupt   @SC89180 05774500
S1INTFL  DS    X             Saved interrupt flags             @SC89180 05775000
*                                                                       05775500
CONSOPRS DC    C'?ocswrmg'   Console command labels for log    @SC93146 05776000
STMSAVR  DS    2F                                              @SC88168 05776500
CONSADH  DC    C'...',C' '   Unpacked vaddr + pad              @SC86159 05777000
         LOCALS ,                                              @SC86295 05777500
SCRCCW   DS    D             CCW for send, recv, msg           @SC88049 05778000
STMSCNS  DS    2F            Saved scan ptrs                   @SC87117 05778500
SCRLR1   DS    F             Saved R1 in SCRLOG                @SC91172 05779000
         AIF   ('&KTAG' NE 'XA').CMSXA5                        @SC90067 05779500
SCRORB   DS    F'0'          Parameter=0                       @XN89235 05780000
         DS    X'00,40,FF,00'   Key=0, etc.                    @XN89235 05780500
ORBCPA   DS    A             Address is filled in              @XN89235 05781000
SCRSUBAR DS    16F           Storage for TSCH                  @XN89235 05781500
IRBCSW   EQU   SCRSUBAR+4,8                                    @XN89235 05782000
.CMSXA5  ANOP                                                  @SC90067 05782500
CONSOPR  DS    XL1           Current I/O operation             @SC89180 05783000
SETMSG   EXIT                                                           05783500
         TITLE 'DISKIO Routine - performs disk I/O functions'           05784000
* ERRNUM unchanged unless there is a disk error.                        05784500
* Function selected on entry by R0:                                     05785000
* 0=> unnum: R1->FAB.  Return R1->buffer,R0=# and remove the sequence   05785500
*   number (if any) from the buffer (used for TAKE files)               05786000
* 1=> open (in): R1->pattern FDB, R2->name.  Returns R0->FAB, R1->FDB   05786500
* 2=> open (out): (same)                                                05787000
* 3=> test name: R2->name.  Returns R1->FDB if file found and  @SC91269 05787500
*     writable (else R15=1)                                    @SC91269 05788000
* 4=> close file: R1->adr(FAB).                                         05788500
* 5=> set up search: R1->pattern name.                                  05789000
* 6=> return next file in list:  Returns R1->FDB + sets up FILNAM       05789500
* 7=> close search (if any).                                            05790000
* 8=> test CWD string: R1->string.  Returns R15=0 if ok, else =1.       05790500
* 9=> read: R1->FAB.  Returns R15=12 if EOF, 0 if ok; R0=# data         05791000
* 10=> write: R1->FAB.  Returns R15=13 if disk full, 0 if ok.           05791500
* 11=> test space: R1->pattern FDB (has size in Kbytes),                05792000
*  R2->name (used if FAB not found), R6->adr(FAB). Return R15=0 if ok.  05792500
* 12=> analyze R/W error, set ERRNUM, make EMSG: R1->FAB, TMPDW=code    05793000
*      always returns R15=1                                             05793500
* 13=> directory info on file: R1->name.  Returns R15=0 if ok.          05794000
* 14=> delete file: R1->name.  Returns R15=0 if ok.                     05794500
* 15=> rename file: R1->name, R2->new name.  Returns R15=0 if ok.       05795000
* 16=> copy file: R1->name, R2->new name.  Returns R15=0 if ok.         05795500
* 21=> save file status in directory: R1->FAB. (not used)      @SC88168 05796000
* 22=> open library (in): R2->DDNAME.  Return R15=0 if ok.     @SC89073 05796500
* 23=> point for next read, R1->adr(FDB), R2=records to skip.  @SC89218 05797000
*      Return R15=0 if ok.                                     @SC89218 05797500
* 24=> test name: R2->name.  Returns R1->FDB if file found and @SC91269 05798000
*      readable (else R15=1)                                   @SC91269 05798500
DISKIO   ENTER                                                          05799000
         USING FABD,3                                          @SC86295 05799500
         SR    4,4           Signal no block assigned          @SC86295 05800000
         STC   0,DSKCOD      Save function code (for now)      @SC88101 05800500
         LR    5,0                                             @SC89073 05801000
         AR    5,5                                             @SC89073 05801500
         LH    5,DSK0(5)     Get handler address               @SC89073 05802000
         B     DSK0(5)       Do the function                   @SC89073 05802500
DSK0     DC    Y(DSKNON-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,DSKNSX-DSK0,DSKCWDF-DSK0)    6-8  @SC89073 05804000
         DC    Y(DSKER1-DSK0,DSKER1-DSK0,DSKTSP-DSK0)     9-11 @SC89073 05804500
         DC    Y(DSKXXX-DSK0),8Y(DSKUTL-DSK0)            12-20 @SC89073 05805000
         DC    2Y(DSKER1-DSK0),Y(DSKPNT-DSK0)            21-23 @SC89218 05805500
         DC    Y(DSKTEST-DSK0)                           24-   @SC91269 05806000
         DC    8Y(DSKER1-DSK0)   Spares                        @SC89073 05806500
*                                                                       05807000
DSKNON   DS    0H                                              @SC89073 05807500
         LR    3,1           Address FAB                       @SC88101 05808000
         L     0,FABNORD     Get length of buffer              @SC88101 05808500
         L     2,FDBBUFF     Get ptr to buffer                 @SC88101 05809000
         CLI   FDBRCF,C'F'   Fixed-length records?             @SC88101 05809500
         BNE   DSKNONZ       No, no line numbers               @SC88101 05810000
         CH    0,=H'80'      See if F/80                       @SC88101 05810500
         BNE   DSKNONZ       No                                @SC88101 05811000
         MVZ   WLDPAT(5),75(2)  See if 76-80 are all numeric   @SC88101 05811500
         CLC   WLDPAT(5),=5C'0'                                @SC88101 05812000
         BNE   DSKNONZ       No                                @SC88101 05812500
         S     0,F8          Yes, move the end back            @SC88101 05813000
DSKNONZ  RETREG 0,(1,2)      Return R0 and (2) as R1           @SC88218 05813500
         B     RTRN0         Done                              @SC88101 05814000
DSKOPNI  DS    0H                                              @SC88101 05814500
*                                                                       05815000
* Open for input file whose name is at (R2), FDB at (R1)                05815500
         BAL   9,DSKALC      Get FAB                           @SC86295 05816000
DSKOP0   BAL   2,DSKLKP      Get FST, ADT ptrs                 @SC86295 05816500
         BNZ   DSKER1        Not found                         @SC86295 05817000
         BAL   14,DSKVALS                                      @SC86295 05817500
         B     RTRN0                                           @SC86295 05818000
*                                                                       05818500
* Open for output file whose name is at (R2), FDB at (R1)               05819000
DSKOPNO  DS    0H                                              @SC89073 05819500
         BAL   9,DSKALC      Get FAB                           @SC86295 05820000
         BAL   2,DSKLKP      Get FST, ADT ptrs                 @SC86295 05820500
         BNZ   DSKOPLR       Not found, just writing new       @SC87012 05821000
         TM    FDBFLGS,APPN+SVATT  Should we keep attributes?  @SC90033 05821500
         BZ    *+8           No                                @SC90033 05822000
          BAL  14,DSKVALS    Yes, copy old ones to FDB         @SC90033 05822500
         TM    FDBFLGS,APPN                                    @SC86295 05823000
         BO    DSKOPLR                                         @SC90033 05823500
       FSERASE FSCB=(3)                                        @SC86295 05824000
DSKOPLR  SR    0,0                                             @SC87012 05824500
         ICM   0,3,FDBLRC    File LRECL                        @SC87012 05825000
         CLI   FDBRCF,C'V'   RECFM F limited to LRECL          @SC88120 05825500
         BNE   DSKSTLR                                         @SC88120 05826000
         CLI   TYPFIL,C'B'   Binary?                           @SC88120 05826500
         BE    DSKSTLR       Yes, always fold                  @SC88120 05827000
         L     0,MAXLRC      TEXT file, no limit               @SC87012 05827500
DSKSTLR  ST    0,FABLRTR     Set effective record length       @SC88120 05828000
         B     RTRN0                                           @SC86295 05828500
*                                                                       05829000
* Test for existence of file whose name is at (R2)                      05829500
DSKTEST  DS    0H                                              @SC89073 05830000
         MVC   DSKSTNM,0(2)                                    @SC86295 05830500
         LA    3,DSKSTT                                        @SC86295 05831000
         B     DSKOP0        Test file                         @SC86295 05831500
*                                                                       05832000
* Close file whose ticket is at (R1), release block                     05832500
DSKCLOS  DS    0H                                              @SC89073 05833000
         ICM   3,15,0(1)     Get FAB ptr, if any               @SC86295 05833500
         BZ    RTRN0         None, ignore                      @SC86295 05834000
         XC    0(4,1),0(1)   Yes, now clear ticket             @SC86295 05834500
         SR    15,15         Clear return code, in case active @SC92260 05835000
         TM    FDBFLGS,FDBACTV Is another copy active?         @SC92260 05835500
         BO    DSKCLOS2      Yes, don't actually FINIS it      @SC92260 05836000
       FSCLOSE FSCB=(3)                                        @SC86295 05836500
DSKCLOS2 LR    1,3           Set up DMSFREE                    @SC92260 05837000
         LR    5,15          Save return code                  @SC92076 05837500
         LA    0,FABDWDS                                       @SC86295 05838000
       DMSFRET DWORDS=(0),LOC=(1)                              @SC86295 05838500
         LR    15,5                                            @SC92076 05839000
         CH    15,=H'6'                                        @SC92076 05839500
         BE    RTRN0         Wasn't open anyway: maybe empty   @SC92076 05840000
         B     RTRN                                            @SC92076 05840500
*                                                                       05841000
* Point past 1st N records of file at (R1)                     @SC89218 05841500
DSKPNT   ICM   3,15,0(1)     Get ticket                        @SC89218 05842000
         BZ    RTRN1         Not open                          @SC89218 05842500
         LA    6,1                                             @SC89218 05843000
         AR    6,2           Rec no. = 1 + number to skip      @SC89218 05843500
         BNP   RTRN0         Never mind                        @SC89218 05844000
         C     6,FDBNREC     File long enough?                 @SC89218 05844500
         BH    RTRN1         No, skip it                       @SC89218 05845000
         SR    0,0           Don't mess with write point       @SC89218 05845500
         FSPOINT FSCB=(3),WRPNT=(0),RDPNT=(6),FORM=E           @SC89218 05846000
         B     RTRN          Return with completion code       @SC89218 05846500
*                                                                       05847000
* Analyze error: packed dec. code in TMPDW                              05847500
DSKXXX   DS    0H                                              @SC89073 05848000
         MVI   ERRNUM,ERRDIE Set Kermit error code             @SC87338 05848500
         L     2,EMSGP       Ptr to msg buffer                 @SC87338 05849000
         MVC   0(8,2),0(1)   Copy oprn name                    @SC87338 05849500
         MVC   8(2,2),=C'R='                                   @SC87338 05850000
         OI    TMPDW+7,15    Set zone                          @SC87338 05850500
         UNPK  10(2,2),TMPDW Copy error code                   @SC87338 05851000
         MVC   EMSGL,F12     Length of string                  @SC87338 05851500
         B     RTRN1                                           @SC87338 05852000
*                                                                       05852500
* Disk utility for file(s) at (R1) and (R2)                             05853000
DSKUTL   SH    0,=H'13'      Code-13: DIR,DEL,REN,COP          @SC86316 05853500
         LR    8,0           Save a copy                       @SC86316 05854000
         SLA   0,3                                             @SC86295 05854500
         LA    5,DSKCMDS                                       @SC86295 05855000
         AR    5,0           Ptr to command name               @SC86295 05855500
         LA    4,CMD         Buffer for tokenized command      @SC86295 05856000
         MVC   0(8,4),0(5)                                     @SC86295 05856500
         LA    4,8(4)                                          @SC86295 05857000
         LR    6,1           1st file                          @SC86295 05857500
         BAL   3,DSKUTCP                                       @SC86295 05858000
         SRA   0,4                                             @SC86295 05858500
         BZ    *+10                                            @SC86295 05859000
         LR    6,2           2nd file                          @SC86295 05859500
         BAL   3,DSKUTCP                                       @SC86295 05860000
         LTR   8,8           Code-13                           @SC86316 05860500
         BNZ   *+14          Go if not LISTFILE                @SC86316 05861000
         MVC   0(16,4),=CL16'(       DATE'                     @SC86295 05861500
         LA    4,16(4)                                         @SC86295 05862000
         MVI   0(4),X'FF'    Insert fence                      @SC86295 05862500
         MVC   1(7,4),0(4)                                     @SC86295 05863000
         LA    0,CMD                                           @SC86295 05863500
         NI    FL4,255-UCMD  Not user command: already tokens  @SC86295 05864000
         KCALL SUPFNC,3      Execute it                        @SC86295 05864500
         B     RTRN                                            @SC86295 05865000
*                                                                       05865500
DSKUTCP  LA    7,LFID        Length of name                    @SC86295 05866000
         ICM   7,8,BLANK     Blank fill                        @SC86295 05866500
         LA    5,24                                            @SC86295 05867000
         MVCL  4,6           Copy name and update R4           @SC86295 05867500
         BR    3                                               @SC86295 05868000
*                                                                       05868500
DSKCMDS  DC    C'LISTFILE'   Utility command names             @SC86295 05869000
         DC    C'ERASE   '                                     @SC86295 05869500
         DC    C'RENAME  '                                     @SC86295 05870000
         DC    C'COPYFILE'                                     @SC86295 05870500
*                                                                       05871000
* Return on error, release useless block, if any                        05871500
DSKER1   LTR   1,4           Any block assigned?               @SC86295 05872000
         BZ    RTRN1         No                                @SC86295 05872500
         LA    0,FABDWDS     Yes, release it                   @SC86295 05873000
       DMSFRET DWORDS=(0),LOC=(1)                              @SC86295 05873500
         B     RTRN1         Flag error                        @SC86295 05874000
*                                                                       05874500
DSKALC   LR    5,1           Save FDB ptr                      @SC86295 05875000
         MVC   DSKSTNM,0(2)                                    @SC86295 05875500
         LA    0,FABDWDS                                       @SC86295 05876000
       DMSFREE DWORDS=(0),ERR=DSKER1                           @SC86295 05876500
         LR    3,1           New block ptr                     @SC86295 05877000
         LA    4,FDBD        FDB pointer                       @SC88120 05877500
         RETREG (0,3),(1,4)  Return (3) as R0, (4) as R1       @SC89218 05878000
         LR    4,3           Indicate we have it               @SC88120 05878500
         XC    0(8*FABDWDS,3),0(3)                             @SC86295 05879000
         MVC   FDBD(FDBCOP),0(5) Copy user's FDB               @SC86295 05879500
         MVC   FDBLRC,FDBLRCTT Move lrecl to final location    @SC92076 05880000
         MVC   FDBLRCTT,F0                                     @SC92076 05880500
         MVC   FABFN(18),0(2)                                  @SC86295 05881000
         OI    FDBFLGS,FDBEPL                                  @SC86295 05881500
         MVI   FABANIT+3,1                                     @SC86295 05882000
         ICM   14,15,LFID(2) Get start and end for sending     @SC89218 05882500
         ICM   15,15,LFID+4(2)                                 @SC89218 05883000
         SLR   15,14         Length of request                 @SC89218 05883500
         ST    15,FDBSREC    Save for length computation       @SC89218 05884000
         BR    9                                               @SC86295 05884500
*                                                                       05885000
DSKLKP  DMSKEY NUCLEUS                                         @SC86295 05885500
         CLI   DSKCOD,3      Testing for possible output?      @SC91269 05886000
         BE    DSKLKPW       Yes, insist on writable           @SC91269 05886500
         CLI   DSKCOD,2      Testing for possible output?      @SC91269 05887000
         BE    DSKLKPW       Yes, insist on writable           @SC91269 05887500
         CLI   DSKCOD,11     Testing for possible output?      @SC91269 05888000
         BE    DSKLKPW       Yes, insist on writable           @SC91269 05888500
        GETFST DSKSTT        Call system routine for FST       @SC86295 05889000
         B     DSKLKP2                                         @SC91269 05889500
DSKLKPW  GETFST DSKSTT,MODE=W Look for writable FST            @SC91269 05890000
DSKLKP2  DS    0H                                              @SC91269 05890500
         LR    9,0           Save ADT ptr                      @SC86295 05891000
         LR    8,1           And FST ptr                       @SC86295 05891500
         LTR   1,15          Save return code                  @SC86295 05892000
        DMSKEY RESET                                           @SC86295 05892500
         LTR   15,1          Test return code                  @SC86295 05893000
         BR    2                                               @SC86295 05893500
*                                                                       05894000
* Set up search through list of files, pattern at (R1)                  05894500
DSKNSET  DS    0H                                              @SC89073 05895000
         NI    DSKFL,255-CWDF Find files                       @SC86295 05895500
         MVC   NXFN(18),0(1)                                   @SC86295 05896000
*                                                                       05896500
* Flush previous file pattern                                           05897000
DSKNSX   MVI   ADT,X'80'     Start over                        @SC86295 05897500
         B     RTRN0                                           @SC86295 05898000
*                                                                       05898500
* Check CWD string, return code in R15                                  05899000
DSKCWDF  DS    0H                                              @SC89073 05899500
         OI    DSKFL,CWDF    Find disk                         @SC86295 05900000
         MVC   NXFN(18),0(1)                                   @SC86295 05900500
         MVI   ADT,X'80'     Start over                        @SC86295 05901000
         B     NXTFST                                          @SC86295 05901500
*                                                                       05902000
* Check disk space for proposed file: FDB at (R1), FAB ptr at (R6)      05902500
DSKTSP   L     5,FDBSIZE-FDBD(,1)  Get actual size             @SC90037 05903000
         MVC   DSKTRCF,FDBRCF-FDBD(1) Copy record format       @SC92234 05903500
         ICM   3,15,0(6)     Get FAB ptr                       @SC90037 05904000
         BZ    DSKTSPX       Not open yet                      @SC90037 05904500
         IC    1,FABFM       Get mode letter                   @SC90037 05905000
DSKTSP0  DS    0H                                              @SC90037 05905500
         USING FSTSECT,8                                       @SC90037 05906000
         USING ADTSECT,9                                       @SC86316 05906500
         L     9,IADT        Look at 1st ADT                   @SC86316 05907000
DSKTSP1  CLM   1,1,ADTM      Find right disk                   @SC90037 05907500
         BE    DSKTSP2                                         @SC86316 05908000
         ICM   9,15,ADTPTR   Try next                          @SC86316 05908500
         BNZ   DSKTSP1                                         @SC86316 05909000
         B     RTRN0         Disk not found!                   @SC86316 05909500
DSKTSP2  L     1,ADTNUM      Total blocks                      @SC86316 05910000
         AIF   ('&CMSSFS' NE 'YES').CMSFS1                     @SC92076 05910500
         TM    ADTFLG4,ADTDIR   Shared File System?            @AM90130 05911000
         BO    DSKTSFS          Yes, do extra calculations     @SC92076 05911500
.CMSFS1  ANOP                                                  @SC92076 05912000
         S     1,ADTUSED     Less used                         @SC86316 05912500
         S     1,ADTARES     Deduct reserve count (alt dir+map)@SC92234 05913000
DSKTSPC  LA    7,4           Block overhead for F              @SC92234 05913500
         CLI   DSKTRCF,C'F'  Is it F?                          @SC92234 05914000
         BE    *+8           Yes                               @SC92234 05914500
          LA   7,12          No, use overhead for V            @SC92234 05915000
         MR    6,1           Total overhead on free space      @SC92234 05915500
         D     6,ADTDBSIZ    Convert to blocks                 @SC92234 05916000
         BCTR  1,0           Deduct one more for good measure  @SC92234 05916500
         SR    1,7           Get the amount actually usable    @SC92234 05917000
         M     0,ADTDBSIZ    Times block size                  @SC86316 05917500
         SRDA  0,10          Convert to Kbytes                 @SC86316 05918000
         CLR   1,5                                             @SC90037 05918500
         BL    RTRN1         No room                           @SC86316 05919000
         B     RTRN0         Ok                                @SC86316 05919500
DSKTSPX  MVC   DSKSTNM,0(2)  File not opened yet, look for it  @SC90037 05920000
         BAL   2,DSKLKP                                        @SC90037 05920500
         IC    1,DSKSTNM+FABFM-FABFN Mode letter, in case      @SC90037 05921000
         BNZ   DSKTSP0       Not found, nothing to erase       @SC90037 05921500
         TM    ADTFLG4,ADTEDF  Extended format?                @SC90037 05922000
         BZ    DSKTSOF                                         @SC90037 05922500
         L     1,ADTDBSIZ    Block size                        @SC90037 05923000
         M     0,FSTADBC     Number of blocks                  @SC90037 05923500
         B     DSKTSS                                          @SC90037 05924000
DSKTSOF  SR    0,0                                             @SC90037 05924500
         LA    1,800         Block size                        @SC90037 05925000
         MH    1,FSTDBC                                        @SC90037 05925500
DSKTSS   SRDA  0,10          Convert to kbytes                 @SC90037 05926000
         SR    5,1           Assume old file will be erased    @SC90037 05926500
         BNP   RTRN0         Will release enough for new file  @SC90037 05927000
         B     DSKTSP2       Not enough, check free blocks     @SC90037 05927500
*                                                                       05928000
         AIF   ('&CMSSFS' NE 'YES').CMSFS2                     @SC92076 05928500
DSKTSFS  ST    5,DSKMAX      Save size needed                  @SC92076 05929000
         LA    3,ADTFQDN     Start of file pool name           @SC92076 05929500
         LA    1,8(,3)       End of pool name field            @SC92076 05930000
         TRT   0(8,3),TRTBL  Find first blank, if any          @SC92076 05930500
         SR    1,3           Get length of pool name           @SC92076 05931000
         ST    1,DSKPNLEN    Set up plist                      @SC92076 05931500
* Get storage space limit                                      @SC92076 05932000
         LA    14,=CL8'DMSQLIMU' SFS Query Limits - Single User@SC92076 05932500
         LA    15,DSKRTC                                       @SC92076 05933000
         LA    0,DSKREAS     Reason code                       @SC92076 05933500
         LA    1,ADTFQDN     Start of file pool name           @SC92076 05934000
         LA    2,DSKPNLEN    Length of name                    @SC92076 05934500
         LA    3,ASTER       User name (* = me)                @SC92076 05935000
         LA    4,F1          Length of name                    @SC92076 05935500
         LA    5,DSKGRP                                        @SC92076 05936000
         LA    6,DSKMAX      # of 4K blocks allowed            @SC92076 05936500
         LA    7,DSKUSD      # used                            @SC92076 05937000
         LA    8,DSKTHR                                        @SC92076 05937500
         STM   14,8,DSKQPLST                                   @SC92076 05938000
         OI    DSKQPLST+40,X'80'   Mark end of plist           @SC92076 05938500
         L     5,DSKMAX      Restore needed size               @SC92076 05939000
         KCALL DMSCSL,DSKQPLST,EXT    Get space quota info     @SC92076 05939500
         ICM   0,15,DSKRTC   Did it work?                      @SC92076 05940000
         BNZ   RTRN0         No, just assume there's enough    @SC92076 05940500
         L     1,DSKMAX                                        @SC92076 05941000
         S     1,DSKUSD      # of blocks left                  @SC92076 05941500
         B     DSKTSPC       and rejoin                        @SC92076 05942000
.CMSFS2  ANOP                                                  @SC92076 05942500
*        NXTFST Routine - searches the ADT and FST chains               05943000
DSKNXT   DS    0H                                              @SC89073 05943500
* Carl Kass and Jeff Damens, CUCCA User Services, 12/80                 05944000
* Modified for Kermit-CMS by Vace Kundakci, 12/85                       05944500
* Copyright (C) 1980 Columbia University                                05945000
* Permission is granted to any individual or institution to copy        05945500
* or use this program, except for explicitly commercial purposes.       05946000
*                                                                       05946500
* NXFN,-FT,-FM contain a CMS fileid, possibly containing wildcard       05947000
* characters, and FST and ADT contain pointers to a valid ADT & FST     05947500
* or are null (negative ADT), return the next FST matching the given    05948000
* filename in FST and the address of the corresponding ADT in ADT.      05948500
* Also move the matched filename into FN, FT, FM.                       05949000
* Also return info in a File Descriptor Block                  @SC86151 05949500
*                                                                       05950000
         USING DCHSECT,1                                                05950500
NXTFST   ICM   9,15,ADT      Supplied ADT                               05951000
         BP    NXFNEXT               Use it if there's one              05951500
         L     9,IADT        Else, start with first ADT        @SC86295 05952000
         NI    DSKFL,255-WFM-WFT-WFN   Nothing wild yet                 05952500
         LA    3,NXFN                                          @SC86295 05953000
         BAL   14,NXFPAT                                       @SC86295 05953500
           OI  DSKFL,WFN                                       @SC86295 05954000
         LA    3,NXFT                                          @SC86295 05954500
         BAL   14,NXFPAT                                       @SC86295 05955000
           OI  DSKFL,WFT                                       @SC86295 05955500
         CLI   NXFM,C'A'                                       @SC86115 05956000
         BNL   NXFAFM                Go if mode letter is A or more     05956500
         MVI   NXFM,C'%'     Set to % if it was blank          @SC86115 05957000
         OI    DSKFL,WFM                                                05957500
NXFAFM   CLI   NXFM+1,C'0'                                     @SC86115 05958000
         BNL   NXFADT                Go if mode number is numeric       05958500
         MVI   NXFM+1,C'%'   Set to % if was blank or *        @SC86115 05959000
NXFADT   TM    ADTFLG1,ADTFRO+ADTFRW                                    05959500
         BZ    NXFNADT                                                  05960000
         CLI   NXFM,C'%'                                       @SC86115 05960500
         BE    NXFFFST               Go if he can use any               05961000
         CLC   ADTM,NXFM                                                05961500
         BE    NXFFFST               Go if it is this disk              05962000
         TM    DSKFL,CWDF    Called for CWD?                   @SC86295 05962500
         BO    NXFNADT       Just looking for disk             @SC86222 05963000
         CLC   ADTMX,NXFM    Check for read-only extension     @SC86222 05963500
         BE    NXFFFST       Yes, search here too              @SC86222 05964000
NXFNADT  ICM   9,15,ADTPTR   Use next ADT                      @SC86295 05964500
         BNZ   NXFADT                But ony if it exists               05965000
NXFER    MVI   ADT,255               For next time, start all over      05965500
         B     RTRN1         Bad return code                   @SC86295 05966000
*                                                                       05966500
NXFPAT   LA    1,8(3)        End addr of FN or FT              @SC86295 05967000
         TRT   0(8,3),TRTBL  Look for space                    @SC86295 05967500
         SR    1,3           Compute length                    @SC86295 05968000
         ST    1,NXFFNL-NXFN(3) Length of pattern              @SC86295 05968500
         MVI   TRTBL+C' ',0  Don't want to catch a blank       @SC86115 05969000
         MVI   TRTBL+C'%',1  Want to catch a percent           @SC86115 05969500
         MVI   TRTBL+C'*',1  Want to catch an asterisk         @SC86115 05970000
         TRT   0(8,3),TRTBL  See if any % or * in FN           @SC86295 05970500
         MVI   TRTBL+C'%',0  Restore TRTBL                     @SC86115 05971000
         MVI   TRTBL+C'*',0                                    @SC86115 05971500
         MVI   TRTBL+C' ',1                                    @SC86115 05972000
         BZ    4(14)         No wild chars found               @SC86295 05972500
         BR    14                                              @SC86295 05973000
*                                                                       05973500
NXFFFST  L     1,ADTFDA              Grab hyperblock ptr                05974000
         TM    DSKFL,CWDF    Called for CWD?                   @SC86295 05974500
         BO    NXFHSV        Yes, found it                     @SC86164 05975000
NXFHYP   ST    1,NXFHYPE             Save for later                     05975500
         LA    8,DCHDATA             Point to first FST                 05976000
         L     3,DCHDWSIZ            Get size of hyperblock             05976500
         SLL   3,3                   Convert to bytes                   05977000
         LA    2,DCHSECT(3)          Add to get end of hyperblk         05977500
         ST    2,NXFHEND             Save it                            05978000
*                                                                       05978500
* All initialized. Ready to step through files. R8 contains current     05979000
* FST, R9 contains current ADT, NXFHYPE contains current hyperblock     05979500
* NXFHEND has end of hyperblock.                                        05980000
*                                                                       05980500
NXFFST   CLI   FSTN,0        Check if DIRECTORY or map         @SC92350 05981000
         BE    NXFNFST       Skip if so (or other garbage)     @SC92350 05981500
         CLI   FSTFV,C'F'       Ordinary RECFM?                @SC90177 05982000
         BE    *+12             Yes, OK                        @SC90177 05982500
          CLI  FSTFV,C'V'       Ordinary RECFM?                @SC90177 05983000
          BNE  NXFNFST          No, skip this item             @SC90177 05983500
         LA    4,NXFN                                          @SC86295 05984000
         LA    5,FSTN                                          @SC86295 05984500
         TM    DSKFL,WFN                                       @SC86295 05985000
         BAL   14,NXFCOMP    Test pattern against token        @SC86295 05985500
         LA    4,NXFT                                          @SC86295 05986000
         LA    5,FSTT                                          @SC86295 05986500
         TM    DSKFL,WFT                                       @SC86295 05987000
         BAL   14,NXFCOMP    Test pattern against token        @SC86295 05987500
*                                                                       05988000
         CLI   NXFM+1,C'%'                                     @SC86115 05988500
         BE    NXFHAVE               Go if any FM is ok                 05989000
         CLC   NXFM+1(1),FSTM+1                                @SC86295 05989500
         BNE   NXFNFST               Go if no match                     05990000
NXFHAVE  MVC   FN,FSTN       Return FN                         @SC86164 05990500
         MVC   FT,FSTT               Return FT                          05991000
         MVC   FM+1(1),FSTM+1        Return FM number                   05991500
         LA    3,DSKSTT                                        @SC86295 05992000
         MVC   FDBSREC,F0    Length request not known          @SC89218 05992500
         BAL   14,DSKVALS    Copy out quantities               @SC86295 05993000
NXFHSV   MVC   FM(1),ADTM    Return FM letter                  @SC86164 05993500
         ST    9,ADT         Save ADT for him                  @SC86295 05994000
         ST    8,FST         Ditto for FST                     @SC86164 05994500
         B     RTRN0                                           @SC86295 05995000
*                                                                       05995500
* Come to NXFNFST to step to next file.                                 05996000
*                                                                       05996500
NXFNEXT  L     8,FST                                                    05997000
NXFNFST  TM    ADTFLG4,ADTEDF                                           05997500
         BZ    NXFNEDF               Go if not EDF                      05998000
         LA    8,FSTL2(8)            Point to next EDF FST              05998500
         AIF   ('&CMSSFS' NE 'YES').CMSFS3                     @SC92076 05999000
         TM    ADTFLG4,ADTDIR   Shared file system?            @EC89346 05999500
         BZ    NXFEDF           No, skip                       @EC89346 06000000
         LA    8,FSTL3-FSTL2(,8) Add additional dir ptr        @EC89346 06000500
.CMSFS3  ANOP                                                  @SC92076 06001000
         B     NXFEDF                                                   06001500
*                                                                       06002000
NXFNEDF  LA    8,FSTL(8)             Point to next non-EDF FST          06002500
NXFEDF   C     8,NXFHEND             End of hyperblock?                 06003000
         BL    NXFFST                No, there are more FSTs still      06003500
NXFNHYP  L     1,NXFHYPE             Point to current hyperblock        06004000
         ICM   1,B'1111',DCHFWPTR    Next hyperblock                    06004500
         BNZ   NXFHYP                Go use next hyperblock if any      06005000
         B     NXFNADT               Need to use next disk              06005500
*                                                                       06006000
DSKVALS  LA    0,FDBD        Ptr to FDB                        @SC86295 06006500
         RETREG (1,0)        Return (0) as R1 to caller        @SC89218 06007000
         NI    DSKFL,255-WARB                                  @SC86295 06007500
         TM    ADTFLG4,ADTEDF  Extended format?                @SC86149 06008000
         BZ    DSKVNEF                                         @SC86149 06008500
         L     1,ADTDBSIZ    Block size                        @SC86149 06009000
         M     0,FSTADBC     Number of blocks                  @SC86149 06009500
         L     7,FSTAIC      Get item count                    @SC86239 06010000
         MVC   FDBDATE+1(6),FSTADATI Copy file date/time       @SC88235 06010500
         B     DSKVEF                                          @SC86149 06011000
DSKVNEF  SR    0,0                                             @SC86149 06011500
         LA    1,800         Block size                        @SC86149 06012000
         MH    1,FSTDBC                                        @SC86149 06012500
         LH    7,FSTIC       Get item count                    @SC86239 06013000
         PACK  FDBDATE+1(2),FSTYR(3) Copy file year            @SC86295 06013500
         MVC   FDBDATE+2(4),FSTD     Copy file date/time       @SC88235 06014000
DSKVEF   SRDA  0,10          Convert to kbytes                 @SC86149 06014500
         ST    7,FDBNREC     Save number of records            @SC89218 06015000
         ICM   6,15,FDBSREC  Length requested to send          @SC89218 06015500
         BZ    DSKVFLN       Not known                         @SC89218 06016000
         CLR   7,6           Use min                           @SC89218 06016500
         BNH   *+6                                             @SC89218 06017000
          LR   7,6                                             @SC89218 06017500
DSKVFLN  DS    0H                                              @SC89218 06018000
         M     6,FSTIL       Compute byte count (approx. if V) @SC86239 06018500
         AL    7,=F'1023'    Round up                          @SC87007 06019000
         BC    12,*+8        No overflow                       @SC88092 06019500
         LA    6,1(6)                                          @SC86239 06020000
         SRDA  6,10                                            @SC86239 06020500
         CLR   1,7           Compare with official length      @SC86239 06021000
         BL    *+6                                             @SC86239 06021500
         LR    1,7           Use computed length instead       @SC86239 06022000
         LTR   1,1                                             @SC86239 06022500
         BNZ   *+8                                             @SC86239 06023000
         LA    1,1           Never say zero length             @SC86239 06023500
         ST    1,FDBSIZE     File size                         @SC86295 06024000
         MVI   FDBDATE,X'19' Assume 20th Cent                  @SC86295 06024500
         CLI   FDBDATE+1,X'50'                                 @SC86295 06025000
         BH    *+8           Ok                                @SC86295 06025500
         MVI   FDBDATE,X'20' Must be 21st                      @SC86295 06026000
         MVC   FDBRCF,FSTFV  Copy format                       @SC86295 06026500
         MVC   FDBLRC,FSTIL+2 No, copy from FST                @SC86295 06027000
         LR    7,14                                            @SC86295 06027500
         SR    0,0           Search from start                 @SC86295 06028000
         LR    1,3           Filename in FAB                   @SC86295 06028500
         A     13,F8         Preserve chain ptr in save area   @SC86295 06029000
         L     15,AACTLKP    Find if active file               @SC86295 06029500
         BALR  14,15                                           @SC86295 06030000
         S     13,F8         Resume ptr to save area           @SC86295 06030500
         LTR   15,15         Is it active?                     @SC86295 06031000
         BNZR  7                                               @SC86295 06031500
         OI    FDBFLGS,FDBACTV Yes                             @SC86295 06032000
         BR    7                                               @SC86295 06032500
*                                                                       06033000
         DROP  1,8,9                                           @SC86295 06033500
*                                                                       06034000
NXFCOMP  MVC   NXFSTR,0(5)   Copy name in                      @SC86295 06034500
         BO    NXFWF         Go if wild FN or FT               @SC86295 06035000
         CLC   NXFSTR,0(4)                                     @SC86295 06035500
         BNE   NXFNFST       Go if no match                    @SC86295 06036000
         BR    14                                              @SC86295 06036500
*                                                                       06037000
NXFWF    LA    1,8(5)        Assume end                        @SC86295 06037500
         TRT   0(8,5),TRTBL  Look for first non-space          @SC86295 06038000
         SR    1,5           Compute length                    @SC86295 06038500
         LR    7,1           Save length                       @SC86295 06039000
         L     5,NXFFNL-NXFN(4)                                @SC86295 06039500
         LA    6,NXFSTR                                        @SC86295 06040000
*                                                                       06040500
* Enter here with R4-R7 containing:                                     06041000
*    pattern address and length                                         06041500
*    source address and length                                          06042000
*                                                                       06042500
         NI    DSKFL,255-WARB Haven't seen any of these        @SC86295 06043000
         ICM   7,B'1000',ASTER       Use * as the fill char             06043500
WLDLOOP  CLCL  4,6                   Compare them                       06044000
         BER   14            They're equal, fine               @SC86295 06044500
*                                                                       06045000
* String mismatch - so examine offending pattern character.  If not     06045500
* % or * and we haven't seen any * yet, we fail.  If it's % we just     06046000
* skip it; if it's * we skip it and remember we've seen it.  Else       06046500
* back up to one past the last * and try again.                         06047000
*                                                                       06047500
         CLI   0(4),C'%'                                       @SC86115 06048000
         BE    WLDLEN1               Go if % = LEN(1) pattern           06048500
         CLI   0(4),C'*'                                       @SC86115 06049000
         BE    WLDARB                Go if * = ARB pattern              06049500
         TM    DSKFL,WARB                                      @SC86295 06050000
         BZ    NXFNFST       Go if ARB already seen            @SC86295 06050500
         CLM   7,B'0111',F0          More data to compare?              06051000
         BE    NXFNFST       Go if exhausted                   @SC86295 06051500
         LM    4,7,WLDPAT            Restore addr of old ARB char       06052000
         LA    6,1(6)                Push one past                      06052500
         BCTR  7,0                   Decrement length                   06053000
         STM   6,7,WLDSRC            Store changed addr                 06053500
         B     WLDLOOP               And go compare again.              06054000
*                                                                       06054500
WLDLEN1  LA    4,1(4)                Increment pattern addr             06055000
         BCTR  5,0                   Decrement pattern len              06055500
         CLM   7,7,F0        Length to compare more            @SC86119 06056000
         BE    NXFNFST       None, pattern '%' is extra        @SC86119 06056500
         LA    6,1(6)                Increment source addr              06057000
         BCTR  7,0                   Decrement source len               06057500
         CLM   7,7,F0        Length to compare more            @SC86119 06058000
         BNE   WLDLOOP               Go if more data                    06058500
         LTR   5,5                   Anything more in pattern?          06059000
         BZR   14            No, it's a match                  @SC86295 06059500
         CLI   0(4),C'*'                                       @SC86115 06060000
         BE    WLDLOOP               Go if ARB                          06060500
         B     NXFNFST       Failed                            @SC86295 06061000
*                                                                       06061500
* If pattern ends in ARB, then it will match anything.  So return to    06062000
* caller if the pattern is exhausted.                                   06062500
*                                                                       06063000
WLDARB   OI    DSKFL,WARB    Remember we saw one               @SC86295 06063500
         LA    4,1(4)                Pass the ARB                       06064000
         BCTR  5,0                   Decrement its length               06064500
         LTR   5,5                   Any more left?                     06065000
         BZR   14            No, it's a match                  @SC86295 06065500
         STM   4,7,WLDPAT            Save where they were               06066000
         B     WLDLOOP                                                  06066500
         DROP  3                                               @SC90264 06067000
*                                                                       06067500
         LOCALS ,                                              @SC86295 06068000
WLDPAT   DS    A                     Place in pattern of last ARB       06068500
         DS    F                     Length of pattern past ARB         06069000
WLDSRC   DS    A                     Place in source when ARB seen      06069500
         DS    F                     Length of source past WLDSRC       06070000
         ORG   WLDPAT                                          @SC92076 06070500
DSKQPLST DS    11F           Plist for getting SFS quota       @SC92076 06071000
DSKRTC   DS    F             Return code from CSL              @SC92076 06071500
DSKREAS  DS    F             Reason code from CSL              @SC92076 06072000
DSKGRP   DS    F             SFS storage group number (ignored)@SC92076 06072500
DSKMAX   DS    F             SFS storage maximum (4K blocks)   @SC92076 06073000
DSKUSD   DS    F             SFS storage used (4K)             @SC92076 06073500
DSKTHR   DS    F             SFS storage threshold             @SC92076 06074000
DSKPNLEN DS    F             SFS storage pool name length      @SC92076 06074500
DSKTRCF  DS    C             Record format for space test      @SC92234 06075000
         ORG   ,                                               @SC92076 06075500
DSKCOD   DS    X             Saved DISKIO code                 @SC88308 06076000
*                                                                       06076500
WILD     EXIT                                                           06077000
