//NJE38  JOB (TSO),
//             'Install NJE38',
//             CLASS=A,
//             MSGCLASS=A,
//             MSGLEVEL=(1,1),
//             USER=IBMUSER,
//             PASSWORD=SYS1
/*JOBPARM   LINES=1000
//*
//*  Installs SYSGEN.NJE38.MACLIB
//*
//NJE38MAC EXEC PGM=PDSLOAD
//STEPLIB  DD  DSN=SYSC.LINKLIB,DISP=SHR
//SYSPRINT DD  SYSOUT=*
//SYSUT2   DD  DSN=SYSGEN.NJE38.MACLIB,DISP=(NEW,CATLG),
//             VOL=SER=PUB001,
//             UNIT=3390,SPACE=(CYL,(1,1,5)),
//             DCB=(BLKSIZE=3120,RECFM=FB,LRECL=80)
//SYSUT1   DD  DATA,DLM=@@
./ ADD NAME=AUTHLIST
AUTHLIST DSECT
AUTHPTR  DS    A                   -> next AUTHLIST entry or 0
         DS    A                   Reserved
AUTHUSER DS    CL8                 Authorized userid
AUTHNODE DS    CL8                 Authorized node of above userid
AUTHSIZE EQU   *-AUTHLIST          Length of an authlist entry
./ ADD NAME=LINKTABL
LINKTABL DSECT
*
***                     LINKTABL  -  LINK TABLE ENTRY
*
*          0   +-----------------------------------------------+
*              |                   LINKID                      |
*          8   +-----------------------+-----------------------+
*              |       LDEFTNME        |     LACTTNME          |
*         10   +-----------------------+-----------------------+
*              |                  LDEFDRVR                     |
*         18   +-----------------------------------------------+
*              |                  LACTDRVR                     |
*         20   +-----------+-----------+-----------------------+
*              |  LDEFLINE | LACTLINE  |     LDRVRVAR          |
*         28   +-----+-----+-----+-----+-----+-----+-----+-----+
*              | L*1 | L*2 | L*3 | L*4 | L*5 | L*6 | L*7 | L*8 |
*         30   +-----+-----+-----+-----+-----+-----+-----+-----+
*              | L*9 |LFLAG| LBUFF     | LPENDING  |  LTAKEN   |
*         38   +-----+-----+-----------+-----------+-----------+
*              |       LPOINTER        |         LMSGQ         |
*         40   +-----------+-----------+-----------+-----------+
*              | LTRNSCNT  |  LERRCNT  |   LTOCNT  |
*         48   +-----------+-----------+-----------+-----------+
*              |                   LNKCLOCK                    |
*         50   +-----------------------------------------------+
*
*
***                     LINKTABL  -  LINK TABLE ENTRY
*
LINKID   DS    CL8                 EBCDIC LINK ID
LDEFTNME DS    CL4                 DEFAULT TASK NAME
LACTTNME DS    CL4                 ACTIVE TASK NAME
LDEFUSER DS    0CL8                DEFAULT USERID IF NO SECURITY   v130
LDEFDRVR DS    CL8                 DEFAULT DRIVER ID
LACTDRVR DS    CL8                 ACTIVE DRIVER ID
LDEFLINE DS    XL2                 DEFAULT VIRTUAL LINE ADDRESS   *XJE
LACTLINE DS    XL2                 ACTIVE VIRTUAL LINE ADDRESS    *XJE
LDRVRVAR DS    1F                  LINE DRIVER VARIABLE INFO
LDEFCLS1 DS    CL1             L*1 DEFAULT  SPOOL FILE CLS 1
LDEFCLS2 DS    CL1             L*2 DEFAULT  SPOOL FILE CLS 2
LDEFCLS3 DS    CL1             L*3 DEFAULT  SPOOL FILE CLS 3
LDEFCLS4 DS    CL1             L*4 DEFAULT  SPOOL FILE CLS 4
LACTCLS1 DS    CL1             L*5 ACTIVE   SPOOL FILE CLS 1
LACTCLS2 DS    CL1             L*6 ACTIVE   SPOOL FILE CLS 2
LACTCLS3 DS    CL1             L*7 ACTIVE   SPOOL FILE CLS 3
LACTCLS4 DS    CL1             L*8 ACTIVE   SPOOL FILE CLS 4
LTIMEZON DS    1X              L*9 2 COMP TIME ZONE DISP FROM GMT
LFLAG    DS    1X                  LINK FLAG BYTE
LACTIVE  EQU   X'80'                LINK ACTIVE
*LALERT   EQU   X'40'   ************AXS ALERT EXIT SET-not used in XJE
LAUTO    EQU   X'40'                LINK TO BE AUTOSTARTED        *XJE
LHOLD    EQU   X'20'                LINK HOLD SET
LDRAIN   EQU   X'10'                LINK DRAIN IN PROGRESS
LTRALL   EQU   X'08'                LINK TRANSACTION TRACING (ALL)
LTRERR   EQU   X'04'                LINK TRANSACTION TRACING (ERROR)
LCONNECT EQU   X'02'                Link successfully signed onHRC031DT
LHALT    EQU   X'01'                LINK TO BE FORCED INACTIVE
LBUFF    DS    1H                  Max buffer size for line       *XJE
LNEGO    DS    1H                  Negotiated actual buffer size  *XJE
LTAKEN   DS    1H                  COUNT OF TAG SLOTS IN USE
LPOINTER DS    1F                  LINK QUEUE ADDR
LMSGQ    DS    1F                  MSG QUEUE POINTER
LTRNSCNT DS    1H                  LINK TRANSACTION COUNT
LERRCNT  DS    1H                  ERROR COUNT
LTOCNT   DS    1H                  TIMEOUT COUNT
LSPARE   DS    1H                  SPARE HALF WORD
LNKCLOCK DS    8X             CLOCK COMP VALUE FOR THIS LINK   @VA03349
*
*- New fields for NJE/MVS use; below                              *XJE
*
LNEXT    DS    A                   -> next LINKTABL entry or 0
LTCBA    DS    A                   -> TCB for this link
LTRMECB  DS    F                   Link subtask termination ECB
LECB     DS    F                   ECB for main task notific'n to link
LNJEW    DS    A                   -> local work area for this link
         DS    F                   Available
LWRESWAP DS    0D                  CDS swap doubleword
LWREQIN  DS    A                   Incoming WREs Q chain anchor
LWREQCT  DS    F                   Incoming synchronization count
LINKLEN  EQU   *-LINKTABL          LENGTH OF LINK TABLE ENTRY
         SPACE
./ ADD NAME=MSGX
         MACRO
&LABEL   MSGX  &NUM,&VAR
.* REENTERABLE FORM OF MSG MACRO
         LCLA  &TOFF,&TVARS
         LCLC  &COFF
&LABEL   MVC   MSGXNUM,=AL2(&NUM)
         AIF   (N'&SYSLIST(2) EQ 0).NOVAR
&TOFF    SETA  N'&SYSLIST(2)
&COFF    SETC  '&TOFF'
.NOVAR   ANOP
         AIF   (N'&SYSLIST(2) EQ 0).NOVAR1
&TOFF    SETA  0
&TVARS   SETA  1
.MLOP    ANOP
&COFF    SETC  '&TOFF'
         MVC   MSGXVAL+&COFF.(8),&SYSLIST(2,&TVARS)
&TOFF    SETA  &TOFF+8
&TVARS   SETA  &TVARS+1
         AIF   (&TVARS LE N'&SYSLIST(2)).MLOP
.NOVAR1  ANOP
         LA    1,MSGXNUM
         LA    0,&TOFF+4
         BAL   14,MSG
         SPACE 1
         MEND
./ ADD NAME=NETSPOOL
*
* Change log:
*
* 23 Jul 20 - Add NCBPCT to return spool file percentage           v200
* 02 Jul 20 - Default userid to CSA in support of TRANSMIT/RECEOVE v200
* 21 May 20 - Add update directory entry funcation                 v120
* 04 May 20 - Show CONFIG assembly date and time on start up.      v102
*
*
NCB      DSECT                     NETSPOOL CONTROL BLOCK
NCBEYE   DS    CL4'NCB'            NCB id
NCBTKN   DS    F                   Token identifier (caller unique)
NCBFL1   DS    X                   Flag bits
NCBPRT   EQU   X'40'                PRT type data
NCBPUN   EQU   X'80'                PUN type data
NCBREQ   DS    X                   Request type
NCBOPEN  EQU   X'01'                Open NETSPOOL dataset
NCBCLOSE EQU   X'02'                Close NETSPOOL dataset
NCBPUT   EQU   X'03'                Write a logical record
NCBGET   EQU   X'04'                Read a logical record
NCBPURGE EQU   X'05'                Delete a file
NCBLOC   EQU   X'06'                Locate a file
NCBCON   EQU   X'07'                Get directory contents
NCBUDIR  EQU   X'08'                Update directory entry         v120
NCBRTNCD DS    X                   RC from VSAM macro (same as R15)
NCBERRCD DS    X                   Error code from VSAM macro
NCBMACAD DS    A                   Addr of failing VSAM macro
NCBTAG   DS    A                   Addr of associated TAG block
NCBEODAD DS    A                   Addr of End of Data routine
NCBAREAL DS    F                   Length of record area
NCBAREA  DS    A                   Addr of record area
NCBRECLN DS    AL2                 Length of record
NCBRECCT DS    AL2                 Record count
NCBPCT   DS    0AL2                Spool percentage full (NCBCON)  v200
NCBFID   DS    AL2                 File id # (avail on new file CLOSE)
NCBRESV1 DS    AL2                 Available bytes
NCBRESV2 DS    A                   Available bytes
         DS    0D                  Force doubleword boundary
NCBSZ    EQU   *-NCB               Size of NCB
*
*
NSDIR    DSECT                     NETSPOOL directory entry
NSLEN    DS    AL2(NSDIRLN)        Length of this record incl len
NSRESV1  DS    AL2                 Resv
NSBLK    DS    AL4                 Block number of file's ptr block
NSINLOC  DS    CL8                 Originating location
NSLINK   DS    CL8                 Next location for transmission
NSINTOD  DS    CL8                 Time of file origin
NSINVM   DS    CL8                 Originating virtual machine
NSRECNM  DS    1F                  Number of records in file
NSRECLN  DS    1H                  Maximum file data record length
NSINDEV  DS    1X                  Device code of originating dev
NSCLASS  DS    CL1                 File output class
NSID     DS    1H                  File number at origin location
NSCOPY   DS    1H                  Number of copies requested
NSFLAG   DS    1X                  VM/370 SFBLOK control flags
NSFLAG2  DS    1X                  VM/370 SFBLOK control flags
NSSPARE  DS    1H                  Spare
NSNAME   DS    CL12                File name
NSTYPE   DS    CL12                File type
NSDIST   DS    CL8                 File distribution code
NSTOLOC  DS    CL8                 Destination location id
NSTOVM   DS    CL8                 Destination virtual machine id
NSPRIOR  DS    1H                  Transmission priority
NSDEV    DS    2X                  Active file's virt dev addr
NSRESV2  DS    AL4                 Resv
NSDIRLN  EQU   *-NSDIR
*
NJ38CSA  DSECT                     NJE38 CSA STORAGE BLOCK
NJ38NODE DS    CL8                 Node name of this NJE38
NJ38ASCB DS    A                   ASCB address of NJE38 addr space
NJ38ECB  DS    F                   NJE38 ECB for cross memory post
NJ38SWAP DS    0D                  CDS swap doubleword
NJ38WRIN DS    A                   Incoming WREs Q chain anchor
NJ38WRCT DS    F                   Incoming synchronization count  v200
NJ38DUSR DS    CL8                 Default 'no security' userid    v200
NJ38CSAZ EQU   *-NJ38CSA           Size of CSA area
*
CMDBLOK  DSECT                     Map cmd area used by DMTXJE
CMDBLEN  DS    AL1                 CMDBLOK length
CMDBTYP  DS    AL1(0)              Type 0 = CMDBLOK request
         DS    AL1
         DS    AL1
CMDLINK  DS    CL8                 LINKID
CMDVMID  DS    CL8                 VIRTUAL MACHINE ID
CMDTEXT  DS    CL120' '            text of command
CMDBLOKL EQU   *-CMDBLOK           Size of dsect
*
STACKMSG DSECT                     Stacked message format
STKOWN   DS    A                   RQE owner
STKNEXT  DS    A                   -> next STACKMSG or zero
STKLEN   DS    AL1                 Stacked msg length
STKZERO  DS    AL1(0)              Must be 0
STKNODE  DS    CL8                 Node of receiver of this msg
STKID    DS    CL8                 userid of receiver of this msg
STKMSG   DS    CL238               Area for msg text
STKSZ    EQU   *-STACKMSG          Total size should be 264=RQESZ
*
*
*
RQE      DSECT
RQEOWN   DS    A                    ->LINKTABL entry of owner (0=free)
RQEDATA  DS    XL260                TANK or MSG data as used by DMTXJE
RQESZ    EQU   *-RQE                Size of RQE area
*
*
./ ADD NAME=NJE
*
*        DSECTs defining NJE headers
*
*        Prefix section common to all headers
*
NJEPDSEC DSECT                     NJE header prefix
NJEPLEN  DS    AL2                 NJE header segment length
NJEPFLGS DS    XL1                 NJE header segment flags
NJEPSEQ  DS    XL1                 NJE header segment sequence
NJEPSIZE EQU   *-NJEPDSEC          NJE header prefix size
*
*        NJE job header general section
*
NJHGDSEC DSECT                     NJE job hdr general section
NJHGLEN  DS    AL2                 NJE job gen. sect. length
NJHGTYPE DS    XL1                 NJE job gen. sect. type
NJHGMOD  DS    XL1                 NJE job gen. sect. modifier
NJHGJID  DS    AL2                 NJE job gen. sect. identif.
NJHGJCLS DS    CL1                 NJE job gen. sect. class
NJHGMCLS DS    CL1                 NJE job gen. sect. msg cls
NJHGFLG1 DS    XL1                 NJE job gen. sect. flags
NJHGPRIO DS    XL1                 NJE job gen. sect. priority
NJHGORGQ DS    XL1                 NJE job gen. sect. qualifier
NJHGJCPY DS    XL1                 NJE job gen. sect. copy
NJHGLNCT DS    XL1                 NJE job gen. sect. lpp
         DS    XL1                 NJE job gen. sect. reserved
NJHGHOPS DS    AL2                 NJE job gen. sect. hop count
NJHGACCT DS    CL8                 NJE job gen. sect. acct
NJHGJNAM DS    CL8                 NJE job gen. sect. name
NJHGUSID DS    CL8                 NJE job gen. sect. userid
NJHGPASS DS    XL8                 NJE job gen. sect. password
NJHGNPAS DS    XL8                 NJE job gen. sect. new pass
NJHGETS  DS    XL8                 NJE job gen. sect. TOD time
NJHGORGN DS    CL8                 NJE job gen. sect. org node
NJHGORGR DS    CL8                 NJE job gen. sect. org user
NJHGXEQN DS    CL8                 NJE job gen. sect. exe node
NJHGXEQU DS    CL8                 NJE job gen. sect. exe user
NJHGPRTN DS    CL8                 NJE job gen. sect. prt dest
NJHGPRTR DS    CL8                 NJE job gen. sect. prt user
NJHGPUNN DS    CL8                 NJE job gen. sect. pun dest
NJHGPUNR DS    CL8                 NJE job gen. sect. pun user
NJHGFORM DS    CL8                 NJE job gen. sect. form
NJHGICRD DS    XL4                 NJE job gen. sect. inp cards
NJHGETIM DS    XL4                 NJE job gen. sect. job time
NJHGELIN DS    XL4                 NJE job gen. sect. prt lines
NJHGECRD DS    XL4                 NJE job gen. sect. pun cards
NJHGPRGN DS    CL20                NJE job gen. sect. programmr
NJHGROOM DS    CL8                 NJE job gen. sect. room no
NJHGDEPT DS    CL8                 NJE job gen. sect. dept
NJHGBLDG DS    CL8                 NJE job gen. sect. building
NJHGNREC DS    XL4                 NJE job gen. sect. rec. cnt
NJHGSIZE EQU   *-NJHGDSEC          NJE job gen. sect. size
NJHSIZE  EQU   NJEPSIZE+NJHGSIZE   NJE job header total size
*
*        NJE data set header general section
*
NDHGDSEC DSECT                     NJE data set general sect.
NDHGLEN  DS    AL2                 NJE ds gen sect. length
NDHGTYPE DS    XL1                 NJE ds gen sect. type
NDHGMOD  DS    XL1                 NJE ds gen sect. type modif
NDHGNODE DS    CL8                 NJE ds gen sect. dest node
NDHGRMT  DS    CL8                 NJE ds gen sect. dest user
NDHGPROC DS    CL8                 NJE ds gen sect. proc name
NDHGSTEP DS    CL8                 NJE ds gen sect. step type
NDHGDD   DS    CL8                 NJE ds gen sect. ddname
NDHGDSNO DS    AL2                 NJE ds gen sect. count
         DS    XL1                 Reserved
NDHGCLAS DS    CL1                 NJE ds gen sect. class
NDHGNREC DS    XL4                 NJE ds gen sect. Record cnt
NDHGFLG1 DS    XL1                 NJE ds gen sect. flags
NDHGRCFM DS    XL1                 NJE ds gen sect. record fmt
NDHGLREC DS    AL2                 NJE ds gen sect. record len
NDHGDSCT DS    XL1                 NJE ds gen sect. copy count
NDHGFCBI DS    XL1                 NJE ds gen sect. print index
NDHGLNCT DS    XL1                 NJE ds gen sect. lpp
         DS    XL1                 Reserved
NDHGFORM DS    CL8                 NJE ds gen sect. form
NDHGFCB  DS    CL8                 NJE ds gen sect. FCB
NDHGUCS  DS    CL8                 Universal char set name
NDHGXWTR DS    CL8                 Data set external writer
NDHGNAME DS    CL8                 Data set name qualifier
NDHGFLG2 DS    XL1                 Second flag byte
NDHGUCSO DS    XL1                 NJE ds gen sect. UCS options
         DS    XL2                 Reserved
NDHGPMDE DS    CL8                 NJE ds gen sect. proc mode
NDHGSIZE EQU   *-NDHGDSEC          Ds hdr general section size
*
*        NJE data set header RSCS section
*
NDHVDSEC DSECT                     Data set header RSCS sect.
NDHVLEN  DS    AL2                 Ds header RSCS sect. length
NDHVTYPE DS    AL1                 Ds header RSCS sect. type
NDHVMOD  DS    AL1                 Ds header RSCS sec modifier
NDHVFLG1 DS    AL1                 Ds header RSCS sect flags
NDHVCLAS DS    CL1                 Ds header RSCS sect class
NDHVIDEV DS    AL1                 Ds header RSCS sect dev typ
NDHVPGLE DS    AL1                 Ds header RSCS 3800 page ln
NDHVDIST DS    CL8                 Ds header RSCS dist code
NDHVFNAM DS    CL12                Ds header RSCS filename
NDHVFTYP DS    CL12                Ds header RSCS filetype
NDHVPRIO DS    AL2                 Ds header RSCS trn priority
NDHVVRSN DS    AL1                 Ds header RSCS version no
NDHVRELN DS    AL1                 Ds header RSCS release no
NDHVSIZE EQU   *-NDHVDSEC          Ds header RSCS section size
NDHSIZE  EQU   NJEPSIZE+NDHGSIZE+NDHVSIZE Total ds header size
*
*        NJE job trailer general section
*
NJTGDSEC DSECT                     Job trailer general section
NJTGLEN  DS    AL2                 Job trailer gen sect length
NJTGTYPE DS    AL1                 Job trailer gen sect type
NJTGMOD  DS    AL1                 Job trailer gen sc modifier
NJTGFLG1 DS    AL1                 Job trailer gen sect flags
NJTGXCLS DS    CL1                 Job trailer execution class
         DS    XL2                 Reserved
NJTGSTRT DS    XL8                 Job trailer job start TOD
NJTGSTOP DS    XL8                 Job trailer job stop TOD
         DS    XL4                 Reserved
NJTGALIN DS    XL4                 Job trailer print lines
NJTGACRD DS    XL4                 Job trailer card images
         DS    XL4                 Reserved
NJTGIXPR DS    XL1                 Job trailer init exec prior
NJTGAXPR DS    XL1                 Job trailer actul exe prior
NJTGIOPR DS    XL1                 Job trailer init job prior
NJTGAOPR DS    XL1                 Job trailer actual job prio
NJTGSIZE EQU   *-NJTGDSEC          Job trailer gen. sect. size
NJTSIZE  EQU   NJEPSIZE+NJTGSIZE   Job trailer total size
*
* NMR record
*
NMRDSECT DSECT
NMRFLAG  DS    XL1                 NMR flags
NMRLVPR  DS    XL1                 NMR level / priority
NMRTYPE  DS    XL1                 NMR type
NMRML    DS    XL1                 Length of contents of NMRMSG
NMRTO    DS    0XL9                Destination system
NMRTONOD DS    CL8                 NMR destination node
NMRTOQUL DS    XL1                 Destination node system identifier
NMROUT   DS    CL8                 Userid / remote id / console id
NMRFM    DS    0XL9                NMR originating system
NMRFMNOD DS    CL8                 NMR originating node
NMRFMQUL DS    XL1                 Originating node system identifier
NMRHSIZE EQU   *-NMRDSECT          Size of NMR header only
NMRECSID DS    0CL8                Message origination node
NMRMSG   DS    CL148               NMR message / command
NMRSIZE  EQU   *-NMRDSECT          NMR size including message / command
*
*        Fields in NMRFLAG
*
NMRFLAGC EQU   X'80'               NMR is a command
NMRFLAGW EQU   X'40'               NMROUT has remote workstation id
NMRFLAGT EQU   X'20'               NMROUT contains a userid
NMRFLAGU EQU   X'10'               NMROUT contains console identifier
NMRFLAGR EQU   X'08'               Console is remote-authorized only
NMRFLAGJ EQU   X'04'               Console is not job-authorized
NMRFLAGD EQU   X'02'               Console is not device-authorized
NMRFLAGS EQU   X'01'               Console is not system-authorized
*
*        Fields in NMRTYPE
*
NMRTYPE4 EQU   X'08'               Source userid embedded in NMRMSG
NMRTYPET EQU   X'04'               Timestamp is not embedded in NMRMSG
NMRTYPEF EQU   X'02'               NMR comtains a formatted command
NMRTYPED EQU   X'02'               Contains a delete operator message
*
*        SYSIN RCBs
*
RRCB1    EQU   X'98'               Stream 1 sysin records
RRCB2    EQU   X'A8'               Stream 2 sysin records
RRCB3    EQU   X'B8'               Stream 3 sysin records
RRCB4    EQU   X'C8'               Stream 4 sysin records
RRCB5    EQU   X'D8'               Stream 5 sysin records
RRCB6    EQU   X'E8'               Stream 6 sysin records
RRCB7    EQU   X'F8'               Stream 7 sysin records
*
*        SYSOUT RCBs
*
PRCB1    EQU   X'99'               Stream 1 sysout records
PRCB2    EQU   X'A9'               Stream 2 sysout records
PRCB3    EQU   X'B9'               Stream 3 sysout records
PRCB4    EQU   X'C9'               Stream 4 sysout records
PRCB5    EQU   X'D9'               Stream 5 sysout records
PRCB6    EQU   X'E9'               Stream 6 sysout records
PRCB7    EQU   X'F9'               Stream 7 sysout records
./ ADD NAME=NJEPARMS
         MACRO
&X       NJEPARMS
.*
.* Change log:
.*
.*
.* 04 Dec 20 - Expanded internal trace table support               v212
.* 29 Nov 20 - Use text-based configuration; alternate routes      v211
.* 29 Nov 20 - Initial creation.                                   v211
.*
*--this area mapped as INITPARM; passed to NJEDRV/NJECMX/NJESCN    v211
         DS    0D                                                  v211
INITPARM DS    0XL72                                               v220
*                  Offset  Owner   Area to be passed               v211
*                  ------ -------  --------------------------------v211
LCLNODE  DS    CL8    0   NJEINIT  Local node name                 v211
CPUID    DS    D      8   NJEINIT  CPUID of this system            v211
ANJECMX  DS    A     10   NJEINIT  -> entry of NJECMX cmd processorv211
ANJESPL  DS    A     14   NJEINIT  -> NJESPOOL interface           v211
RQENUM   DS    F     18   NJEINIT  # RQEs in stg area              v211
ARQESTG  DS    A     1C   NJEINIT  -> RQE stg area                 v211
CSABLK   DS    A     20   NJEINIT  -> CSA communication area       v211
ALINKS   DS    A     24   NJEINIT  -> LINKS  (LINKTABL anchor)     v211
AROUTES  DS    A     28   NJEINIT  -> ROUTES (RTE list anchor)     v211
AAUTHS   DS    A     2C   NJEINIT  -> AUTHS  (AUTHLIST anchor)     v211
ACMDBLOK DS    A     30   NJEINIT  -> CMDBLOK dsect (CMNDBLOK)     v211
MSGQ     DS    A     34   NJEDRV   Stacked msg Q anchor            v211
XJELINK  DS    A     38   NJEDRV   -> task's LINKTABL              v211
ATRACE   DS    A     3C   NJEINIT  -> Trace table control          v212
AREGUSER DS    A     40   NJEINIT  -> REGUSER (REGUSER anchor)     v220
RESV1    DS    F     44            Available word                  v220
*                    48            Total length                    v220
INITPRML EQU   *-INITPARM          Length of this parm list        v211
*--end of passed area                                              v211
         MEND
./ ADD NAME=NJEQUMSG
         MACRO
&X       NJEQUMSG
.*
.* Change log:
.*
.* 11 Dec 20 - Initial creation.                                   v220
.*
QUMSG    DSECT                     Queued user message
QUMNEXT  DS    A                   -> next QUMSG or 0
QUMOWNER DS    A                   -> REGUSER that owns this msg
QUMSGTXT DS    CL120               Message text
QUMSIZE  EQU   *-QUMSG             Size of dsect
         MEND
./ ADD NAME=NJERUSER
         MACRO
&X       NJERUSER
.*
.* Change log:
.*
.* 10 Dec 20 - Initial creation.                                   v220
.*
*
REGUSERB DSECT                     Registered userid block
REGNEXT  DS    A                   -> next REGUSER or 0
REGEYE   DS    CL4'REGU'           Eyecatcher
REGWRE   DS    A                   -> user's registration WRE in CSA
REGMSGQ  DS    A                   -> user's queued msgs WRE chain
REGUSRID DS    CL8                 Userid
REGSIZE  EQU   *-REGUSERB          Size of dsect
         MEND
./ ADD NAME=NJETRACE
         MACRO
&X       NJETRACE &TYPE=
.*
.* Change log:
.*
.* 10 Dec 20 - Support for registered users and message queuing    v220
.* 10 Dec 20 - Create NJETRACE macro from old in-line TRACE macro  v220
.*
         AIF   ('&TYPE' EQ 'DSECT').DSECT
.*
&X       STM   R15,R2,16(R13)          R0-R2 restored by trace rtn
         L     R2,ATRACE               -> trace table
         L     R15,TRCRTN-TRCCTL(,R2)  -> trace routine
         BALR  R14,R15                 Go get a new trace entry
         L     R15,16(,R13)            Restore R15
         MVI   0(R14),&TYPE            Move in trace type code
         MEXIT
.*
.DSECT   ANOP
TRCCTL   DSECT
TRCEYE   DS    CL8'TRACETAB'       Eyecatcher
TRCRTN   DS    A                   -> Trace routine
         DS    A                   Reserved
TRCSTRT  DS    A                   -> Start of trace table
TRCCURR  DS    A                   -> Current trace entry
TRCEND   DS    A                   -> End of trace table
         DS    A                   Reserved
TRCSZ    EQU   32                  Size of each trace entry
*
*-- TRACE TABLE TYPES
*
TRCEXCP  EQU   X'01'                    EXCP operation
TRCWAIT  EQU   X'02'                    Wait completed
TRCDYNA  EQU   X'03'                    Dynamic Allocation
TRCMSG   EQU   X'04'                    Message
TRCRCMD  EQU   X'05'                    remote command
TRCGET   EQU   X'06'                    Getmain
TRCFREE  EQU   X'07'                    Freemain
TRCOPNO  EQU   X'08'                    Open output request
TRCCLSO  EQU   X'09'                    Close output request
TRCOPNI  EQU   X'0A'                    Open input request
TRCCONT  EQU   X'0B'                    Spool contents request
TRCCLSI  EQU   X'0C'                    Close input request
TRCPURG  EQU   X'0D'                    File Purge request
TRC0E    EQU   X'0E'                   Available
TRCGLQ   EQU   X'0F'                    GLINKREQ
TRCGRQ   EQU   X'10'                    GROUTREQ
TRCALQ   EQU   X'11'                    ALERTREQ
TRCGMQM  EQU   X'12'                    GMSGREQ from MSGQ
TRCGMQR  EQU   X'13'                    GMSGREQ from RQE
TRCIWRE  EQU   X'14'                    Incoming WRE
TRCOWRE  EQU   X'15'                    Outgoing WRE
TRCGWRE  EQU   X'16'                    Getmain WRE
TRCFWRE  EQU   X'17'                    Freemain WRE
*
         MEND
./ ADD NAME=NJEVER
         MACRO
         NJEVER
         GBLC  &VERS
&VERS    SETC  'v2.3.0'               -> Current version
         B     34(,R15)
         DC    AL1(29)
         DC    CL9'&SYSECT'
         DC    CL6'&VERS'
         DC    CL9'&SYSDATE'
         DC    CL5'&SYSTIME'
         MEND
./ ADD NAME=NJEWRE
         MACRO
&X       NJEWRE
.*
.* Change log:
.*
.* 10 Dec 20 - Support for registered users and message queuing    v220
.*
WRE      DSECT
WRENEXT  DS    A                    -> next WRE or 0
WRETYPE  DS    X                    WRE type
WRENEW   EQU   X'04'                 New file added to NETSPOOL
WRECMD   EQU   X'08'                 CMD type
WREMSG   EQU   X'0C'                 MSG type
WRESTAR  EQU   X'10'                 START type
WREREG   EQU   X'14'                 Registration request          v220
WREDREG  EQU   X'18'                 Deregistration request        v220
WREQRM   EQU   X'1C'                 Queue registered user msg     v220
WREDRM   EQU   X'20'                 Dequeue registered user msg   v220
WRECODE  DS    X                    Command code for link driver
WRETXTLN DS    X                    CMD or MSG text length
WRESP    DS    X                    Getmained subpool number       v220
WRELINK  DS    CL8                  Target link name for this WRE
WREUSER  DS    CL8                  Target user name for this WRE
WREORIG  DS    0CL8                 Originating userid of MSG      v220
WREASCB  DS    A                    Originating ASCB addr          v220
WREECB   DS    F                    Originator ECB for CM POST     v220
WRETXT   DS    CL120                Command or message text
WRESIZE  EQU   *-WRE                Size of WRE                    v220
*
*- Error codes for registered user services (POST code in WREECB)  v220
ERNOERR  EQU   0                    No errors                      v220
ERNOMSG  EQU   4                    No more messages               v220
ERSTOP   EQU   8                    STOP command issued            v220
ERINVREQ EQU   12                   Invalid request                v220
ERINACT  EQU   16                   NJE38 is not active            v220
ERPOST   EQU   20                   CM POST to NJE38 failure       v220
ERDUPUSR EQU   24                   User already registered        v220
ERUSERNF EQU   28                   Userid is not registered       v220
ERECBPST EQU   32                   User ECB was posted            v220
         MEND
./ ADD NAME=NSIO
         MACRO                                                          MAC00010
&L       NSIO  &TYPE=,                                                 XMAC00020
               &NCB=NCB,                                               XMAC00030
               &TAG=,                                                  XMAC00040
               &EODAD=,                                                XMAC00050
               &AREALEN=,                                              XMAC00060
               &AREA=,                                                 XMAC00070
               &RECLEN=,                                           v210XMAC00080
               &ENTRY=                                             v210 MAC00080
.*
.* Change log:
.*
.* 10 AUG 20 - Add alternate entry point via ENTRY=                v210
.* 21 May 20 - Add update directory entry functionality            v120
.*
.*                                                                      MAC00100
         LCLA  &OFFREQ                                                  MAC00110
         LCLA  &OFFTAG                                                  MAC00120
         LCLA  &OFFEOD                                                  MAC00130
         LCLA  &OFFARL                                                  MAC00140
         LCLA  &OFFARA                                                  MAC00150
         LCLA  &OFFRCL                                                  MAC00160
         LCLA  &NSIZE                                                   MAC00180
         LCLA  &REQ                                                     MAC00190
         LCLC  &W                                                       MAC00200
.*                                                                      MAC00210
.* Offsets within NCB block                                             MAC00220
&OFFREQ  SETA  9                       Offset of NCBREQ                 MAC00230
&OFFTAG  SETA  16                      Offset of NCBTAG                 MAC00240
&OFFEOD  SETA  20                      Offset of NCBEODAD               MAC00250
&OFFARL  SETA  24                      Offset of NCBAREAL               MAC00260
&OFFARA  SETA  28                      Offset of NCBAREA                MAC00270
&OFFRCL  SETA  32                      Offset of NCBRECLN               MAC00280
*                                                                       MAC00300
.* Assembled size of NCB DSECT                                          MAC00310
&NSIZE   SETA  48                      Size of an NCB                   MAC00320
.*                                                                      MAC00330
         AIF   (T'&NCB NE 'O').NCB1                                     MAC00340
         MNOTE 8,'NCB= PARAMETER REQUIRED'                              MAC00350
         AGO   .TYPE                                                    MAC00360
.*                                                                      MAC00370
.NCB1    ANOP                                                           MAC00380
         AIF   ('&NCB'(1,1) EQ '(').NCB1R                               MAC00390
&L       LA    1,&NCB                  -> NCB                           MAC00400
         AGO   .TYPE                                                    MAC00410
.NCB1R   ANOP                                                           MAC00420
&W       SETC  '&NCB'(2,K'&NCB-2)                                       MAC00430
&L       LR    1,&W                    -> NCB                           MAC00440
.*                                                                      MAC00450
.ISTYPE  ANOP                                                           MAC00460
         AIF   (T'&TYPE NE 'O').TYPE                                    MAC00470
         MNOTE 8,'TYPE= PARAMETER REQUIRED'                             MAC00480
         MEXIT                                                          MAC00490
.*                                                                      MAC00500
.TYPE    ANOP                                                           MAC00510
         AIF   ('&TYPE' EQ 'OPEN').OPEN                                 MAC00520
         AIF   ('&TYPE' EQ 'CLOSE').CLOSE                               MAC00530
         AIF   ('&TYPE' EQ 'PUT').PUT                                   MAC00540
         AIF   ('&TYPE' EQ 'GET').GET                                   MAC00550
         AIF   ('&TYPE' EQ 'PURGE').PURGE                               MAC00560
         AIF   ('&TYPE' EQ 'FIND').FIND                                 MAC00570
         AIF   ('&TYPE' EQ 'CONTENTS').CONTENT                          MAC00580
         AIF   ('&TYPE' EQ 'UDIR').UDIR                            v120 MAC00570
         MNOTE 8,'TYPE=&TYPE IS NOT A VALID FUNCTION TYPE'              MAC00590
         MEXIT                                                          MAC00600
.*                                                                      MAC00610
.OPEN    ANOP                                                           MAC00620
&REQ     SETA  1                                                        MAC00630
         XC    0(&NSIZE,1),0(1)        Initialize NCB                   MAC00640
         MVC   0(4,1),=CL4'NCB'        Set NCB identifier               MAC00650
         AGO   .SETREQ                                                  MAC00660
.*                                                                      MAC00670
.CLOSE   ANOP                                                           MAC00680
&REQ     SETA  2                                                        MAC00690
         AGO   .SETREQ                                                  MAC00700
.*                                                                      MAC00710
.PUT     ANOP                                                           MAC00720
&REQ     SETA  3                                                        MAC00730
         AGO   .SETREQ                                                  MAC00740
.*                                                                      MAC00750
.GET     ANOP                                                           MAC00760
&REQ     SETA  4                                                        MAC00770
         AGO   .SETREQ                                                  MAC00780
.*                                                                      MAC00790
.PURGE   ANOP                                                           MAC00800
&REQ     SETA  5                                                        MAC00810
         AGO   .SETREQ                                                  MAC00820
.*                                                                      MAC00830
.FIND    ANOP                                                           MAC00840
&REQ     SETA  6                                                        MAC00850
         AGO   .SETREQ                                                  MAC00860
.*                                                                      MAC00870
.CONTENT ANOP                                                           MAC00880
&REQ     SETA  7                                                        MAC00890
         AGO   .SETREQ                                             v120 MAC00860
.*                                                                      MAC00830
.UDIR    ANOP                                                      v120 MAC00840
&REQ     SETA  8                                                   v120 MAC00850
.*                                                                      MAC00900
.SETREQ  ANOP                                                           MAC00910
         MVI   &OFFREQ.(1),&REQ        Set NCBREQ type                  MAC00920
.*                                                                      MAC00930
.TAG     ANOP                                                           MAC00940
         AIF   (T'&TAG EQ 'O').EODAD                                    MAC00950
         AIF   ('&TAG'(1,1) EQ '(').TAG1R                               MAC00960
         LA    0,&TAG                  -> TAG data                      MAC00970
         ST    0,&OFFTAG.(,1)          Store in NCB                     MAC00980
         AGO   .EODAD                                                   MAC00990
.TAG1R   ANOP                                                           MAC01000
&W       SETC  '&TAG'(2,K'&TAG-2)                                       MAC01010
         ST    &W,&OFFTAG.(,1)         Store tag ptr in NCB             MAC01020
.*                                                                      MAC01030
.EODAD   ANOP                                                           MAC01040
         AIF   (T'&EODAD EQ 'O').AREALEN                                MAC01050
         AIF   ('&EODAD'(1,1) EQ '(').EODAD1R                           MAC01060
         LA    0,&EODAD                -> End of data routine           MAC01070
         ST    0,&OFFEOD.(,1)          Store in NCB                     MAC01080
         AGO   .AREALEN                                                 MAC01090
.EODAD1R ANOP                                                           MAC01100
&W       SETC  '&EODAD'(2,K'&EODAD-2)                                   MAC01110
         ST    &W,&OFFEOD.(,1)         Set EODAD address in NCB         MAC01120
.*                                                                      MAC01130
.AREALEN ANOP                                                           MAC01140
         AIF   (T'&AREALEN EQ 'O').AREA                                 MAC01150
         AIF   ('&AREALEN'(1,1) EQ '(').AREAL1R                         MAC01160
         MVC   &OFFARL.(4,1),=A(&AREALEN) Set area length value in NCB  MAC01170
         AGO   .AREA                                                    MAC01180
.AREAL1R ANOP                                                           MAC01190
&W       SETC  '&AREALEN'(2,K'&AREALEN-2)                               MAC01200
         ST    &W,&OFFARL.(,1)         Set area length in NCB           MAC01210
.*                                                                      MAC01220
.AREA    ANOP                                                           MAC01230
         AIF   (T'&AREA EQ 'O').RECLEN                                  MAC01240
         AIF   ('&AREA'(1,1) EQ '(').AREA1R                             MAC01250
         LA    0,&AREA                 -> Record buffer area            MAC01260
         ST    0,&OFFARA.(,1)          Store in NCB                     MAC01270
         AGO   .RECLEN                                                  MAC01280
.AREA1R  ANOP                                                           MAC01290
&W       SETC  '&AREA'(2,K'&AREA-2)                                     MAC01300
         ST    &W,&OFFARA.(,1)         Set area address in NCB          MAC01310
.*                                                                      MAC01320
.RECLEN  ANOP                                                           MAC01330
         AIF   (T'&RECLEN EQ 'O').ENTRY                            v210 MAC01340
         AIF   ('&RECLEN'(1,1) EQ '(').REC1R                            MAC01350
         MVC   &OFFRCL.(2,1),=Y(&RECLEN) Set record length in NCB       MAC01360
         AGO   .ENTRY                                              v210 MAC01370
.REC1R   ANOP                                                           MAC01380
&W       SETC  '&RECLEN'(2,K'&RECLEN-2)                                 MAC01390
         STH   &W,&OFFRCL.(,1)         Set record length in NCB         MAC01400
.*                                                                      MAC01500
.ENTRY   ANOP                                                           MAC01510
         AIF   (T'&ENTRY EQ 'O').VCON                              v210
         AIF   ('&ENTRY'(1,1) EQ '(').ENT1R                        v210 MAC01350
         L     15,&ENTRY               Load NJESPOOL entry addr    v210
         AGO   .LAUNCH                                             v210
.*                                                                      MAC01500
.ENT1R   ANOP                                                      v210 MAC01510
&W       SETC  '&ENTRY'(2,K'&ENTRY-2)                              v210 MAC01390
         AIF   ('&W' EQ '15').LAUNCH                               v210 MAC01350
         LR    15,&W                   Entry addr to R15           v210 MAC01400
         AGO   .LAUNCH                                             v210
.*
.VCON    ANOP                                                      v210
         L     15,=V(NJESPOOL)
.*
.LAUNCH  ANOP                                                      v210
         BALR  14,15
.*
.MEND    ANOP                                                      v210 MAC01510
         MEND                                                           MAC01520
./ ADD NAME=REGEQU
         MACRO                                                          REG00010
&X       REGEQU                                                         REG00020
*                                      DEFINES GENERAL REGISTERS        REG00030
R0       EQU   0                                                        REG00040
R1       EQU   1                                                        REG00050
R2       EQU   2                                                        REG00060
R3       EQU   3                                                        REG00070
R4       EQU   4                                                        REG00080
R5       EQU   5                                                        REG00090
R6       EQU   6                                                        REG00100
R7       EQU   7                                                        REG00110
R8       EQU   8                                                        REG00120
R9       EQU   9                                                        REG00130
R10      EQU   10                                                       REG00140
R11      EQU   11                                                       REG00150
R12      EQU   12                                                       REG00160
R13      EQU   13                                                       REG00170
R14      EQU   14                                                       REG00180
R15      EQU   15                                                       REG00190
*                                      DEFINES CONTROL REGISTERS        REG00200
C0       EQU   0                                                        REG00210
C1       EQU   1                                                        REG00220
C2       EQU   2                                                        REG00230
C3       EQU   3                                                        REG00240
C4       EQU   4                                                        REG00250
C5       EQU   5                                                        REG00260
C6       EQU   6                                                        REG00270
C7       EQU   7                                                        REG00280
C8       EQU   8                                                        REG00290
C9       EQU   9                                                        REG00300
C10      EQU   10                                                       REG00310
C11      EQU   11                                                       REG00320
C12      EQU   12                                                       REG00330
C13      EQU   13                                                       REG00340
C14      EQU   14                                                       REG00350
C15      EQU   15                                                       REG00360
*                                      DEFINES FLOATING PT REGISTERS    REG00370
F0       EQU   0                                                        REG00380
F2       EQU   2                                                        REG00390
F4       EQU   4                                                        REG00400
F6       EQU   6                                                        REG00410
         MEND                                                           REG00420
./ ADD NAME=ROUTE
         MACRO
&LABEL   ROUTE &PARM1,&PARM2,                                          X
               &TYPE=ENTRY
         GBLA  &RTETOT
         AIF   ('&TYPE' EQ 'FINAL').FINAL
         LCLC  &DEST,&NEXT
&RTETOT  SETA  &RTETOT+1
         AIF   (&RTETOT NE 1).NOT1
ROUTES   DS    0D
.NOT1    ANOP
&DEST    SETC  ' '
&NEXT    SETC  ' '
         AIF   (T'&PARM1 EQ 'O').NOID
&DEST    SETC  '&PARM1'
         AIF   (T'&PARM2 EQ 'O').NOID
&NEXT    SETC  '&PARM2'
.NOID    ANOP
&LABEL   DC    CL8'&DEST',CL8'&NEXT' DESTINATION, NEXT LINK
         MEXIT
.FINAL   ANOP
NUMRTES  EQU   &RTETOT
         AIF   (&RTETOT NE 0).MEND
ROUTES   DS    0D
.MEND    ANOP
         MEND
./ ADD NAME=RSSEQU
         PUSH  PRINT
         AIF   ('&SYSPARM' NE 'SUP').RSS01
         PRINT OFF,NOGEN
.RSS01   ANOP
*
***      RSS EQUATE SYMBOLS - MACHINE USAGE
*
          SPACE 1
*        BITS DEFINED IN STANDARD/EXTENDED PSW
EXTMODE  EQU   X'08'          BIT 12 - EXTENDED MODE
MCHEK    EQU   X'04'          BIT 13 - MACHINE CHECK ENABLED
WAIT     EQU   X'02'          BIT 14 - WAIT STATE
PROBMODE EQU   X'01'          BIT 15 - PROBLEM STATE
          SPACE 1
*        BITS DEFINED IN CHANNEL STATUS WORD - CSW
ATTN     EQU   X'80'          BIT 32 - ATTENTION
SM       EQU   X'40'          BIT 33 - STATUS MODIFIER
CUE      EQU   X'20'          BIT 34 - CONTROL UNIT END
BUSY     EQU   X'10'          BIT 35 - BUSY
CE       EQU   X'08'          BIT 36 - CHANNEL END
DE       EQU   X'04'          BIT 37 - DEVICE END
UC       EQU   X'02'          BIT 38 - UNIT CHECK
UE       EQU   X'01'          BIT 39 - UNIT EXCEPTION
*
PCI      EQU   X'80'          BIT 40 - PROGRAM-CONTROL INTERRUPT
IL       EQU   X'40'          BIT 41 - INCORRECT LENGTH
PRGC     EQU   X'20'          BIT 42 - PROGRAM CHECK
PRTC     EQU   X'10'          BIT 43 - PROTECTION CHECK
CDC      EQU   X'08'          BIT 44 - CHANNEL DATA CHECK
CCC      EQU   X'04'          BIT 45 - CHANNEL CONTROL CHECK
IFCC     EQU   X'02'          BIT 46 - INTERFACE CONTROL CHECK
CHC      EQU   X'01'          BIT 47 - CHAINING CHECK
          SPACE 1
*        BITS DEFINED IN CHANNEL COMMAND WORD - CCW
CD       EQU   X'80'          BIT 32 - CHAIN DATA
CC       EQU   X'40'          BIT 33 - COMMAND CHAIN
SILI     EQU   X'20'          BIT 34 - SUPPRESS INCORRECT LENGTH IND.
SKIP     EQU   X'10'          BIT 35 - SUPPRESS DATA TRANSFER
PCIF     EQU   X'08'          BIT 36 - PROGRAM-CONTROL INTERRUPT FETCH
IDA      EQU   X'04'          BIT 37 - INDIRECT DATA ADDRESS
          SPACE 1
*        BITS DEFINED IN SENSE BYTE 0 -- COMMON TO MOST DEVICES
CMDREJ   EQU   X'80'          BIT 0 - COMMAND REJECT
INTREQ   EQU   X'40'          BIT 1 - INTERVENTION REQUIRED
BUSOUT   EQU   X'20'          BIT 2 - BUS OUT
EQCHK    EQU   X'10'          BIT 3 - EQUIPMENT CHECK
DATACHK  EQU   X'08'          BIT 4 - DATA CHECK
         EJECT
*
***      CP370 EQUATE SYMBOLS - CP USAGE
*
*        SYMBOLIC REGISTER EQUATES
R0       EQU   0
R1       EQU   1
R2       EQU   2
R3       EQU   3
R4       EQU   4
R5       EQU   5
R6       EQU   6
R7       EQU   7              GENERAL
R8       EQU   8              REGISTER
R9       EQU   9              DEFINITIONS
R10      EQU   10
R11      EQU   11
R12      EQU   12
R13      EQU   13
R14      EQU   14
R15      EQU   15
*
Y0       EQU   0              FLOATING
Y2       EQU   2              POINT
Y4       EQU   4              REGISTER
Y6       EQU   6              DEFINITIONS
         EJECT
         POP   PRINT
         SPACE
./ ADD NAME=RTE
RTE      DSECT
ROUTPTR  DS    A                   -> next RTE entry or 0
         DS    A                   Reserved
ROUTNAME DS    CL8                 Route destination node
ROUTNEXT DS    CL8                 Link id for indirect routing
ROUTALT1 DS    CL8                 Alternate link id for indirect rt'g
ROUTALT2 DS    CL8                 Alternate link id for indirect rt'g
ROUTALT3 DS    CL8                 Alternate link id for indirect rt'g
ROUTSIZE EQU   *-RTE               Length of a routing table entry
./ ADD NAME=TAG
         PUSH  PRINT
         AIF   ('&SYSPARM' NE 'SUP').TAG01
         PRINT OFF,NOGEN
.TAG01   ANOP
TAG      DSECT
         SPACE 1
***                          TAG  -  FILE TAG
*
*          0   +-----------------------+-----------------------+
*              |      TAGNEXT          |     TAGBLOCK          |
*          8   +-----------------------+-----------------------+
*              |                   TAGINLOC                    |
*         10   +-----------------------------------------------+
*              |                   TAGLINK                     |
*         18   +-----------------------------------------------+
*              |                   TAGINTOD                    |
*         20   +-----------------------------------------------+
*              |                   TAGINVM                     |
*         28   +-----------------------+-----------+-----+-----+
*              |      TAGRECNM         | TAGRECLN  | T*1 | T*2 |
*         30   +-----------+-----------+-----------+-----+-----+
*              |   TAGID   |  TAGCOPY  | T*3 | T*4 |   SPARE   |
*         38   +-----------+-----------+-----------------------+
*              |                   TAGNAME                     |
*         40   |                       +-----------------------+
*              |                       |                       |
*         48   +-----------------------+                       |
*              |                   TAGTYPE                     |
*         50   +-----------------------------------------------+
*              |                   TAGDIST                     |
*         58   +-----------------------------------------------+
*              |                   TAGTOLOC                    |
*         60   +-----------------------------------------------+
*              |                   TAGTOVM                     |
*         68   +-----------------------------------------------+
*              | TAGPRIOR  |  TAGDEV   |
*         70   +-----------+-----------+
*
***                          TAG  -  FILE TAG
         SPACE 1
TAGNEXT  DS    1F                  ADDR OF NEXT ACTIVE QUEUE ENTRY
TAGBLOCK DS    1F                  ADDR OF ASSOCIATED I/O AREA
         SPACE
TAGINLOC DS    CL8                 ORIGINATING LOCATION
TAGLINK  DS    CL8                 NEXT LOCATION FOR TRANSMISSION
TAGINTOD DS    CL8                 TIME OF FILE ORIGIN
TAGINVM  DS    CL8                 ORIGINATING VIRTUAL MACHINE
TAGRECNM DS    1F                  NUMBER OF RECORDS IN FILE
TAGRECLN DS    1H                  MAXIMUM FILE DATA RECORD LENGTH
TAGINDEV DS    1X              T*1 DEVICE CODE OF ORIGINATING DEV
TAGCLASS DS    CL1             T*2 FILE OUTPUT CLASS
TAGID    DS    1H                  FILE NUMBER AT ORIGIN LOCATION
TAGCOPY  DS    1H                  NUMBER OF COPIES REQUESTED
TAGFLAG  DS    1X              T*3 VM/370 SFBLOK CONTROL FLAGS
TAGFLAG2 DS    1X              T*4 VM/370 SFBLOK CONTROL FLAGS
         DS    1H                  SPARE
TAGNAME  DS    CL12                FILE NAME
TAGTYPE  DS    CL12                FILE TYPE
TAGDIST  DS    CL8                 FILE DISTRIBUTION CODE
TAGTOLOC DS    CL8                 DESTINATION LOCATION ID
TAGTOVM  DS    CL8                 DESTINATION VIRTUAL MACHINE ID
TAGPRIOR DS    1H                  TRANSMISSION PRIORITY
TAGDEV   DS    2X                  ACTIVE FILE'S VIRT DEV ADDR
         SPACE
TAGUSELN EQU   *-TAGINLOC          USABLE TAG INFO LEN            *XJE
TAGLEN   EQU   *-TAGNEXT           LENGTH OF THE FILE TAG
         EJECT
         POP   PRINT
         SPACE
@@
//*
//*  Installs SYSGEN.NJE38.ASMSRC
//*
//ASMSRC   EXEC PGM=PDSLOAD
//STEPLIB  DD  DSN=SYSC.LINKLIB,DISP=SHR
//SYSPRINT DD  SYSOUT=*
//SYSUT2   DD  DSN=SYSGEN.NJE38.ASMSRC,DISP=(NEW,CATLG),
//             VOL=SER=PUB001,
//             UNIT=3390,SPACE=(CYL,(2,1,10)),
//             DCB=(BLKSIZE=6160,LRECL=80,RECFM=FB)
//SYSUT1   DD  DATA,DLM=@@
./ ADD NAME=DMTMSG
*
*
*-- NJE38 - Message modules carried over from VM/370 RSCS
*
*
*   Used by DMTXJE for message formatting
*   Invoked by DMTXJE via the MSGX macro
*
*
*
         MACRO
&LABEL   MDEF  &MNUM,&RCOD,&SCOD,&TEXT
         LCLC  &VRCOD,&VSCOD,&NDX
         AIF   (T'&MNUM EQ 'O').MERR1
         AIF   (T'&TEXT EQ 'O').MERR2
&VRCOD   SETC  '0'
&VSCOD   SETC  '0'
         AIF   (T'&RCOD EQ 'O').RTOK
&VRCOD   SETC  '&RCOD'
.RTOK    AIF   (T'&SCOD EQ 'O').STOK
&VSCOD   SETC  '&SCOD'
.STOK    ANOP
&NDX     SETC  '&SYSNDX'(2,3)
&LABEL   DC    A(MSG&NDX)
         DC    H'&MNUM',AL1(&VRCOD),AL1(&VSCOD),AL1(L'MTXT&NDX)
MTXT&NDX DC    C&TEXT
MSG&NDX  DC    0F'0'
         MEXIT
.MERR1   MNOTE 16,'MSG NUMBER NOT SPECIFIED'
         MEXIT
.MERR2   MNOTE 16,'MSG TEXT NOT SPECIFIED'
         MEXIT
         MEND
         EJECT
*.
* MODULE NAME -
*
*        DMTMSG
*
* FUNCTION -
*
*        THIS MODULE CONTAINS NO EXECUTABLE CODE AND CONTAINS
*        ONLY A LIST OF ERROR MSGS TO BE USED EXTERNALLY BY
*        DMTMGX
*
* ATTRIBUTES -
*
*        REUSABLE
*
* ENTRY POINTS -
*
*
*        DMTMSG - MESSAGE TABLE
*
*.
         EJECT
DMTMSG   CSECT
         SPACE 2
*        MESSAGE ROUTING CODE EQUATES
         SPACE
RSS      EQU   X'80'               RSS OPERATOR CONSOLE
ORIG     EQU   X'40'               'ORIGINATING' LINK ID
VMID     EQU   X'20'               VIRTUAL MACHINE USER ID
CP       EQU   X'10'               LOCAL CP OPERATOR
         SPACE 2
         PRINT ON,GEN
         SPACE 1
         MDEF  000,RSS+CP,,'I RSCS (REL $, LEV $, $) READY'    @VA08219
         MDEF  001,RSS,,'I Free storage = $ pages'
         MDEF  002,RSS,,'I Link $ deactivated'
         MDEF  003,RSS,,'I Link $ executing:  $$$$$$$$$$$$$$$$$$$$$$$$$x
               $$$$$$$$$$$$$$$'
         MDEF  004,RSS,,'I Location $ executing: $$$$$$$$$$$$$$$$$$$$$$x
               $$$$$$$$$$$$$$$$$$$$$$'                         hrc016dt
         MDEF  005,RSS,,'I Location $($) executing: $$$$$$$$$$$$$$$$$$$x
               $$$$$$$$$$$$$$$$$$$'                            hrc016dt
         MDEF  070,RSS,,'E i/o error $ SIOCC $ CSW $ $ Sense $ CCW $ $'
         MDEF  080,RSS,,'E Program check -- link $ deactivated'
         MDEF  090,RSS+CP,,'T Program check in supervisor -- RSCS shutdx
               own'
         MDEF  091,RSS+CP,,'T Initialization failure -- RSCS shutdown' x
               *  comment continuation  *                      @vm01115
         MDEF  101,VMID,,'I File $ enqueued on link $'
         MDEF  102,VMID,,'I File $ pending for link $'
         MDEF  103,VMID,,'E File $ rejected -- invalid destination addrx
               ess'
         MDEF  104,RSS+VMID,,'I File spooled to $ -- org $ ($) $$$ GMT'
*              *** comment continuation ***                   @va09277
         MDEF  105,RSS,,'I File $ purged'
         MDEF  106,RSS,,'I File $ missing -- dequeued from link $'
         MDEF  107,RSS,,'I $ Pending files for link $ missing'
         MDEF  108,RSS+CP,,'E System error reading spool file $'
         MDEF  141,RSS,,'I Line $ ready for connection to link $'
         MDEF  142,RSS,,'I Link $ line $ connected'
         MDEF  143,RSS,,'I Link $ line $ disconnected'
         MDEF  144,RSS,,'I Receiving: file from $ $ for $ $'
*        MDEF  145,RSS,,'I Received: file from $ $ for $ $'
         MDEF  145,RSS+VMID,,'I Received: file($) from $ $ for $ $'
         MDEF  146,RSS,,'I Sending: file $ on link $, rec $'
         MDEF  147,RSS+VMID,,'I Sent: file $ on link $'
         MDEF  148,RSS,,'I Active file $ sending resumed on link $'
         MDEF  149,RSS,,'I Link $ line activity: tot= $; errs= $; tmoutx
               s= $'
         MDEF  160,RSS,,'I Line $ disabled for $'
         MDEF  170,VMID,,'I From $: $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$x
               $$$$$'
         MDEF  171,VMID,,'I From $($): $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$x
               $$$$$$$$'                                       hrc016dt
         MDEF  172,ORIG,,'I CPQ: $$$$$$$$$$$$$$$$$$$$'         hrc022dt
         MDEF  190,RSS,,'E Invalid spool block format on file $'
         MDEF  200,ORIG,,'I RSCS'
         MDEF  201,ORIG,,'E Invalid command $'
         MDEF  202,ORIG,,'E Invalid link $'
         MDEF  203,ORIG,,'E Invalid spool id $'
         MDEF  204,ORIG,,'E Invalid keyword $'
         MDEF  205,ORIG,,'E Conflicting keyword $'
         MDEF  206,ORIG,,'E Invalid option $ $'
         MDEF  207,ORIG,,'E Conflicting option $ $'
         MDEF  208,ORIG,,'E Invalid user id $'
         MDEF  300,ORIG,,'I Accepted by task $'
         MDEF  301,ORIG,,'E Rejected by task $ -- previous command actix
               ve'
         MDEF  302,ORIG,,'E Link $ is not defined'
         MDEF  303,ORIG,,'E Link $ is not active'
         MDEF  304,ORIG,,'E Rejected by task $ -- not receiving'
         MDEF  310,ORIG,,'E Location $ is not defined'         hrc024dt
         MDEF  495,RSS+CP,,                                            x
               'T Virtual storage size insufficient for initialization'x
                                                               hrc025dt
         MDEF  928,RSS+ORIG,,'E sSorage not available to transmit file x
               $ ($) on link $ - file held'                    hrc025dt
         MDEF  510,ORIG,,'I File $ backspaced'
         MDEF  511,ORIG,,'E No file active on link $'
         MDEF  520,RSS+ORIG,,'I File $ changed'
         MDEF  521,RSS+ORIG,,'I File $ held for link $'
         MDEF  522,RSS+ORIG,,'I File $ released for link $'
         MDEF  523,RSS+ORIG,,'I Link $ queue reordered'
         MDEF  524,RSS+ORIG,,'E File $ active -- no action taken'
         MDEF  525,RSS+ORIG,,'E File $ is for link $ -- no action takenx
               '
         MDEF  526,RSS+ORIG,,'E File $ not found -- no action taken'
         MDEF  530,RSS,,'I Command forwarded on link $'
         MDEF  540,RSS,,'I New link $ defined'
         MDEF  541,RSS,,'I Link $ redefined'
         MDEF  542,RSS,,'E Link $ active -- not redefined'
         MDEF  543,RSS,,'E Link $ not defined -- link limit reached'
         MDEF  544,RSS,,'E Link $ not defined -- type not specified'
         MDEF  550,RSS,,'I Link $ now deleted'
         MDEF  551,RSS,,'E Link $ active -- not deleted'
         MDEF  552,RSS,,'E Link $ has a file queue -- not deleted'
         MDEF  560,RSS,,'I RSCS disconnecting'
         MDEF  561,RSS,,'E Userid $ not receiving'
         MDEF  570,RSS+ORIG,,'I Link $ now set to deactivate'
         MDEF  571,RSS+ORIG,,'E Link $ already set to deactivate'
         MDEF  580,RSS+ORIG,,'I File $ processing terminated'
         MDEF  581,ORIG,,'E File $ not active'
         MDEF  590,RSS+ORIG,,'I Link $ resuming file transfer'
         MDEF  591,RSS+ORIG,,'E Link $ not in hold status'
         MDEF  600,ORIG,,'I File $ forwarded spaced'
         MDEF  610,RSS+ORIG,,'I Link $ to suspend file transmission'
         MDEF  611,RSS+ORIG,,'I Link $ file transmission suspended'
         MDEF  612,RSS+ORIG,,'E Link $ already in hold status'
         MDEF  620,X'00',,'I Message forwarded on link $'
         MDEF  630,ORIG,,'I $ Now routed through link $'       hrc024dt
         MDEF  631,ORIG,,'I Indirect routing for $ deactivated'  c024dt
         MDEF  632,ORIG,,'E $ invalid route specified'         hrc042dt
         MDEF  633,ORIG,,'E $ not routed -- route limit reached' c024dt
         MDEF  634,ORIG,,'I No locations routed'               hrc024dt
         MDEF  636,ORIG,,'I $ routed through link $'           hrc024dt
         MDEF  637,ORIG,,'E $ not routed'                      hrc024dt
         MDEF  640,RSS+ORIG,,'I $ File(s) purged on link $'
         MDEF  651,ORIG,,'I Link $ inactive'
         MDEF  652,ORIG,,'I Link $ $ $ $ $ $ $ $ $'            hrc031dt
         MDEF  653,ORIG,,'I Link $ default $ $ $ $ r=$'
         MDEF  654,ORIG,,'I Link $ q=$ p=$'
         MDEF  655,ORIG,,'I File $ $ $ cl $ pr $ rec $ $'
         MDEF  660,ORIG,,'I File $ inactive on link $'
         MDEF  661,ORIG,,'I File $ active on link $'
         MDEF  662,ORIG,,'I File $ org $ $ $$$ to $ $'
         MDEF  663,ORIG,,'I File $ pr $ cl $ co $ $ di $, na $$$'
         MDEF  664,ORIG,,'E File $ not found'
         MDEF  670,ORIG,,'I Kink $ $ -- line $ $'              hrc031dt
         MDEF  671,ORIG,,'I Kink $ inactive'
         MDEF  672,ORIG,,'I No link active'
         MDEF  673,ORIG,,'I No link defined'
         MDEF  700,RSS,,'I Activating link $ $ $ $ $'
         MDEF  701,RSS,,'E No switched line available -- link $ not actx
               ivated'
         MDEF  702,RSS,,'E Line $ is in use by link $ -- link $ not actx
               ivated'
         MDEF  703,RSS,,'E Dev $ is not a line port -- link $ not activx
               ated'
         MDEF  704,RSS,,'E Line $ cc=3 not operational -- link $ not acx
               tivated'
         MDEF  705,RSS,,'E Driver $ not found on disk $ -- link $ not ax
               ctivated'
         MDEF  706,RSS,,'E Fatal error loading from $ -- link $ not actx
               ivated'
         MDEF  707,RSS,,'E Driver $ file format invalid -- link $ not ax
               ctivated'
         MDEF  708,RSS,,'E Virtual storage capacity exceeded -- link $ x
               not activated'
         MDEF  709,RSS,,'E Task name $ already in use -- link $ not actx
               ivated'
         MDEF  710,RSS,,'E Max ($) active -- link $ not activated'
         MDEF  750,RSS+ORIG,,'e Link $ already active -- no action takex
               n'
         MDEF  751,RSS+ORIG,,'I Link $ already active -- new class(es) x
               set as requested'
         MDEF  752,RSS+ORIG,,'I Link $ still active -- drain status resx
               et'
         MDEF  801,RSS,,'I Link $ error trace started'
         MDEF  802,RSS,,'I Link $ trace started'
         MDEF  803,RSS,,'I Link $ trace ended'
         MDEF  810,RSS,,'E Link $ trace already active'
         MDEF  811,RSS,,'E Link $ trace not active'
         MDEF  901,RSS,,'E Invalid sml mode specified -- link $ not actx
               ivated'
         MDEF  902,RSS+ORIG,,                                  @va04614x
               'E Non-signon card read on link $'              @va04614
         MDEF  903,RSS+ORIG,,'E Password supplied on link $ is invalid'
         MDEF  904,ORIG,,'E Signon parameter=$ on link $ invalid'
         MDEF  905,RSS+ORIG,,'I Signon of link $ complete, buffer size=x
               $'                                              hrc023dt
         MDEF  906,RSS,,'E Invalid sml buffer parameter --  link $ not a
               activated'
         MDEF  907,ORIG,,'E Signon type parameter missing'     @va03420
         MDEF  934,ORIG,,'E Id card missing on link $ -- input file purx
               ged'
         MDEF  935,RSS+VMID,,'E Link $ in rje mode -- print file $ purgx
               ed'
         MDEF  936,RSS+VMID,,'E No remote punch available on link $ -- x
                file $ purged'
         MDEF  937,RSS+ORIG,,                                          x
               'E decompression error on link $  '
         MDEF  938,RSS+ORIG,,'E Resources not available to receive fileX
                ($) on link $'                                 HRC025DT
         MDEF  939,RSS+ORIG,,'E Protocol error in file ($) on link $ --X
                reason code $'                                 HRC025DT
MSGEND   DC    F'0'
         END
./ ADD NAME=DMTXJE
*
*
*-- NJE38 - NJE Line Driver carried over from VM/370 RSCS
*
*
*   This program is the RSCS line driver DMTSML that was modified to
*   perform NJE functionality in VM/370 RSCS and was called DMTYJE.
*   It was modified again for MVS invocations and renamed to DMTXJE.
*   It is used by NJE38 to provide NJE service to MVS 3.8J.
*
*   This program is called by NJEDRV.
*
*
*   NOTE!  This program is 100% reenterable but despite that statement
*   it cannot be assembled with the RENT option.
*
*
*
*
*
*---------------------------------------------------------------------
*
* MVS use modifications other than entry and exit linkages
*
*- Module made re-enterable and multi-csect to provide base reg relief
*- Task r9 commented out after label SETNOBUF
*- WAITREQ call commented out in MSG (wait done by MVS)
*- WAITREQ call commented out after cmd received (after WGET1A)
*- Several DIAG instructions commented out
*- TLINKS -> 1st LINKTABL. (used to -> LINKTABL-8). TLINKS original
*-  purpose no longer needed or used.
*- Remove LACTIVE flag from link that becomes connected.
*- Comment out branch to PNOTLOCL for store&forward.
*- Use new LINKTABL field LTCBA to identify task, label WGOTLINK
*- Changed name of ROUTE dsect to RTE
*- Several COPY statements no longer used or required
*- Pass via R0 # of pages requested to GPAGEREQ calls
*- Pass max buffer size as a parameter
*- Set negotiated buffer size in LINKTABL  (MC7SGNON)
*- Dont issue Command Forward msg 530 (label CMD12)
*- Support for alternate routes (after label WTRYROUT)
*- Comment out the test for SRCB plausibility when connecting to
*-  JES2 TCPNJE, after label PNEXT.   02 MAR 2021.
*
*---svectors calls redirected
* TLINKS
* ASYNREQ
* POSTREQ
* TCOM
* IOREQ
* WAITREQ
* ALERTREQ
* GIVEREQ
*
*--comdsect calls redirected
* PMSGREQ
* GPAGEREQ
* GLINKREQ
* GROUTREQ
* GMSGREQ
* GTODEBCD
*
*
* GENERALLY and in MOST cases:
*
*   Code lines marked '*XJE' represent modifications for NJE38 use.
*   Code lines marked 'SML2NJE4' represent the NJE modifications to
*    the original DMTSML line driver.
*   Code lines marked 'HRCxxxDT' represent the NJE modifications to
*    the original DMTSML line driver.
*   All other lines are original DMTSML code.
*
*
*
*
*
*
*
XJE      TITLE 'DMTXJE     (RSCS)      VM/370 - RELEASE 6'     HRC000DT DMT00250
*********ISEQ  73,80               VALIDATE INPUT FILE SEQUENCEING      DMT00260
*.                                                                      DMT00270
* MODULE NAME -                                                         DMT00280
*                                                                       DMT00290
*        DMTXJE                                                HRC000DT DMT00300
*                                                                       DMT00310
* FUNCTION -                                                            DMT00320
*                                                                       DMT00330
*        Attempt at an NJE Bisync line driver for              HRC000DT DMT00340
*        VM/370 Release 6 RSCS.  Hacked from DMTSML.           HRC000DT DMT00350
*                                                                       DMT00360
* ATTRIBUTES -                                                          DMT00370
*                                                                       DMT00380
*        NON-REUSABLE                                                   DMT00390
*                                                                       DMT00400
* ENTRY POINTS -                                                        DMT00410
*                                                                       DMT00420
*        XJEINIT                                               HRC000DT DMT00430
*                                                                       DMT00440
*                                                                       DMT00450
* ENTRY CONDITIONS -                                                    DMT00460
*                                                                       DMT00470
*        GPR 0 CONTAINS THE LENGTH OF THE PARM FIELD IN BYTES           DMT00480
*        GPR 1 CONTAINS THE ADDRESS OF THE PARM FIELD ON THE START CMD  DMT00490
*        GPR 2 CONTAINS THE ADDRESS OF THE LINK TABLE ENTRY FOR THIS    DMT00500
*                 TASK                                                  DMT00510
*                                                                       DMT00520
* EXIT CONDITIONS -                                                     DMT00530
*                                                                       DMT00540
*        NORMAL/ERROR -                                                 DMT00550
*                                                                       DMT00560
*              RETURN TO SUPVISOR VIA GIVE TERMINATE REQUEST TO DMTREX  DMT00570
         EJECT                                                          DMT00580
*                                                                       DMT00590
* CALLS TO OTHER ROUTINES -                                             DMT00600
*                                                                       DMT00610
*              SEE BEGINNING OF EACH SECTION                            DMT00620
*                                                                       DMT00630
* EXTERNAL REFERENCES -                                                 DMT00640
*                                                                       DMT00650
*              LINK TABLE ENTRY FOR THIS LINKID                         DMT00660
*              MAIN STORAGE MAP                                         DMT00670
*                                                                       DMT00680
* TABLES / WORKAREAS -                                                  DMT00690
*                                                                       DMT00700
*              TASK CONTROL TABLE FOR EACH PROCESSOR                    DMT00710
*                                                                       DMT00720
*                                                                       DMT00730
* REGISTER USAGE -                                                      DMT00740
*                                                                       DMT00750
*        ALL SUBROUTINES IN THE MODULE CONFORM GENERALLY TO THIS USAGE; DMT00760
*        ANY INDIVIDUAL  DEVIATIONS OR EXTENSIONS ARE LISTED WITH THE   DMT00770
*        COMMAND DESCRIPTION                                            DMT00780
*                                                                       DMT00790
*        GPR0   = ALTERNATE PARAMETER REGISTER                          DMT00800
*        GPR1   = PARAMETER REGISTER                                    DMT00810
*        GPR2   = WORK                                                  DMT00820
*        GPR3   = WORK                                                  DMT00830
*        GPR4   = WORK                                                  DMT00840
*        GPR5   = WORK                                                  DMT00850
*        GPR6   = WORK                                                  DMT00860
*        GPR7   = TCT ADDRESSABILITY                                    DMT00870
*        GPR8   = WORK                                                  DMT00880
*        GPR9   = Base register for variables csect DMTXJEA             DMT00890
*        GPR10  = BASE REGISTER                                         DMT00900
*        GPR11  = BASE REGISTER                                         DMT00910
*        GPR12  = BASE REGISTER                                         DMT00920
*        GPR13  = BUFFER POINTER                                        DMT00930
*        GPR14  = LINK REGISTER                                         DMT00940
*        GPR15  = LINK REGISTER                                         DMT00950
*                                                                       DMT00960
* NOTES -                                                               DMT00970
*                                                                       DMT00980
*        NONE                                                           DMT00990
*                                                                       DMT01000
* OPERATION -                                                           DMT01010
*                                                                       DMT01020
*                                                                       DMT01030
*              SEE OPERATION IN EACH SECTION OF PROGRAM                 DMT01040
*                                                                       DMT01050
* HISTORY -                                                             DMT01060
*                                                                       DMT01070
*                                                                       DMT01080
*         -    Pre-2019: first created from the DMTSML RJE line         DMT01090
*              driver plus many NJE related modifications and           DMT01100
*              was named DMTYJN and then DMTYJB.                        DMT01110
*                                                                       DMT01120
*         -    December 2019: renamed to DMTXJE and split into          DMT01130
*              multiple csects to provide base register relief.         DMT01140
*.                                                                      DMT01150
         EJECT                                                          DMT01160
*                                                                       DMT01170
********************                                                    DMT01180
*                  *   Main entry.  Performs general initialization.    DMT01190
* CSECT DMTXJE     *   This program is called by NJEDRV when a          DMT01200
*                  *   link is started by NJE38 Start command.          DMT01210
********************                                                    DMT01220
*                                                                       DMT01230
DMTXJE   CSECT                                                 HRC000DT DMT01240
*
*-- On entry to DMTXJE:                                           *XJE
*                                                                 *XJE
*    R0  = length of input parameters or 0                        *XJE
*    R1 -> input parameters or 0                                  *XJE
*    R2 -> LINKTABL entry for the node being started              *XJE
*    R7 -> SVECTORS list that replaces RSCS functions             *XJE
*    R8 -> list of addrs that DMTXJE fills for use by NJEDRV      *XJE
*    R9 -> two pages of storage for DMTXJE working storage        *XJE
*    R10-> working storage area of caller NJEDRV                  *XJE
*    R13-> OS save area and working storage for the main csect    *XJE
*                                                                 *XJE  DMT01860
*                                                                 *XJE  DMT01870
         B     12(,R15)                                           *XJE
         DC    CL8'DMTXJE'                                        *XJE
         USING DMTXJE,R12                                         *XJE
         USING LINKTABL,R6         GET LINKTABL ADDRESSABILTIY    *XJE
         USING DMTXJEA,R9          Global addressability          *XJE
TCTR     EQU   7                   TCT BASE REGISTER              *XJE
*                                                                 *XJE
         STM   R14,R12,12(R13)     Save caller's regs             *XJE
         LR    R12,R15                                            *XJE
*                                                                 *XJE
         LR    R4,R0               Save entry R0                  *XJE
         LR    R5,R1               Save entry R1                  *XJE
*                                                                 *XJE
         LR    R1,R9               -> storage page to be XJEMAIN  *XJE
         LR    R0,R1               Copy stg address               *XJE
         LA    R1,4095             Get size of storage area - 1   *XJE
         LA    R1,1(,R1)           Full size of storage area      *XJE
         L     R14,=A(DMTXJEA)     -> Constants and variables area*XJE
         LA    R15,DMTXJEAZ        Size of area; pad char = 0     *XJE
         MVCL  R0,R14              Init reenterable cpy of DMTXJEA*XJE
*                                                                 *XJE
         LA    R1,4095             Get size of storage area - 1   *XJE
         LA    R1,1(,R1)           Full size of storage area      *XJE
         L     R14,=A(DMTXJEB)     -> Constants and variables area*XJE
         LA    R15,DMTXJEBZ        Size of area; pad char = 0     *XJE
         MVCL  R0,R14              Init reenterable cpy of DMTXJEB*XJE
*                                                                 *XJE
         ST    R10,XJESAVE         Save caller wk'g stg in SA+0   *XJE
         ST    R13,XJESAVE+4       Save callers SA ptr            *XJE
         ST    R9,8(,R13)          Set fwd SA ptr                 *XJE
*  No SA in R13 as used in DMTXJE                                 *XJE
         MVC   TLINKS(SVLEN),0(R7) Set up input svectors          *XJE
         LA    R1,MSGECB           -> this ECB                    *XJE
         ST    R1,0(,R8)           Pass its addr back to NJEDRV   *XJE
         LA    R1,CMDECB           -> this ECB                    *XJE
         ST    R1,4(,R8)           Pass its addr back to NJEDRV   *XJE
         LA    R1,CMDRESP          -> this area                   *XJE
         ST    R1,8(,R8)           Pass its addr back to NJEDRV   *XJE
         LA    R1,ADAECB           -> this area                   *XJE
         ST    R1,12(,R8)          Pass its addr back to NJEDRV   *XJE
         LA    R1,RDEVSYNC         -> this area                   *XJE
         ST    R1,16(,R8)          Pass its addr back to NJEDRV   *XJE
*                                                                 *XJE
         L     R1,TLINKS           offset to ALINKS word NJEDRV   *XJE
         AR    R1,R10              Compute actual addr            *XJE
         L     R1,0(,R1)           Get ptr to LINKS anchor word   *XJE
         L     R1,0(,R1)           Get ptr to first LINKTABL entry*XJE
         ST    R1,TLINKS           Store addr of 1st LINKTABL entr*XJE
*
*-- Set the buffer sizes for this link
*
         LH    R1,LBUFF-LINKTABL(R2)    Get configured buff size  *XJE
         ST    R1,TPBUFSIZ              Set buffer size           *XJE
         ST    R1,MAXBUF                Set maximum size          *XJE
*
*                                                                 *XJE
*-- Relocate the adcons from DMTXJEA into the new page            *XJE
*                                                                 *XJE
RELOC000 EQU   *                                                  *XJE
         LA    R0,RELOCNUM         Number of entries to relocate  *XJE
         L     R7,=A(DMTXJEA)      -> constants and adcons csect  *XJE
         LA    R14,RELOC           -> first relocation description*XJE
*                                                                 *XJE
RELOC020 EQU   *                                                  *XJE
         SR    R15,R15             Clear for IC                   *XJE
         IC    R15,0(,R14)         Get offset to adcon            *XJE
         SR    R6,R6                                              *XJE
         ICM   R6,3,2(R14)         Get base/displacement of adcon *XJE
         N     R6,=X'00000FFF'     Keep only the displacement     *XJE
         AR    R6,R15              offset of the actual adcon     *XJE
         LA    R1,0(R6,R7)         -> original location of adcon  *XJE
         LA    R3,0(R6,R9)         -> new location of adcon       *XJE
         CLI   1(R14),4            4-byte adcon length?           *XJE
         BE    RELOC040            Yes                            *XJE
*                                                                 *XJE
RELOC030 EQU   *                ** Handle 3-byte adcons           *XJE
         ICM   R15,7,0(R1)         Load original adcon value      *XJE
         SR    R15,R7              Compute relative offset        *XJE
         AR    R15,R9              Compute new adcon value        *XJE
         STCM  R15,7,0(R3)         Str new adcon value in new loc *XJE
         B     RELOC050                                           *XJE
*                                                                 *XJE
RELOC040 EQU   *                ** Handle 4-byte adcons           *XJE
         ICM   R15,15,0(R1)        Load original adcon value      *XJE
         SR    R15,R7              Compute relative offset        *XJE
         AR    R15,R9              Compute new adcon value        *XJE
         STCM  R15,15,0(R3)        Str new adcon value in new loc *XJE
*                                                                 *XJE
RELOC050 EQU   *                                                  *XJE
         LA    R14,4(,R14)         Next reloc descriptor          *XJE
         BCT   R0,RELOC020         Continue through the adcons    *XJE
*                                                                 *XJE
         LR    R0,R4               Restore entry R0               *XJE
         LR    R1,R5               Restore entry R1               *XJE
*                                                                 *XJE
*-- begin original DMT code                                       *XJE
*        SAVE LINK TABLE ADDRESS                                        DMT02920
XJEINIT  EQU   *                                               HRC000DT
         ST    R2,XJELINK         Save the link table address  HRC000DT DMT02930
         LR    R6,R2               GET LINKTABL ADDR FOR DSECT          DMT02940
         MVC   ADACUU(2),LACTLINE  MOVE THE LINE ADDRESS TO IOBLOCK     DMT02950
         MVC   AXSLINK(8),LINKID   AND THE LINK ID FOR AXS              DMT02960
         UNPK  XJELINE(5),ADACUU(3) Unpk the device address    HRC000DT DMT02970
         MVC   XJELINE(3),XJELINE+1 Move to fld first 3 bytes  HRC000DT DMT02980
         MVI   XJELINE+3,C' '      Blank the next byte         HRC000DT DMT02990
         MVC   XJELINE+4(4),XJELINE+3 And the rest of the fld  HRC000DT DMT03000
         TR    XJELINE(3),AXSTRTAB-240 Translate to EBCDIC     HRC000DT DMT03010
         LH    R4,LACTLINE         GET ACTIVE LINE ADDRESS              DMT03020
*        DIAG  R4,R5,X'24'         FIND DEVICE TYPE                     DMT03030
         STCM  R5,B'0100',ADACUU+3 AND SAVE IN DEVICE BLOCK             DMT03040
         L     R15,TLINKS          GET START OF LINK CHAIN              DMT03050
         LR    R6,R15              THE FIRST ENTRY ADDR (LOCAL)   *XJE  DMT03060
         MVC   LOCATION(8),LINKID  AND SAVE FOR MSGS                    DMT03070
         MVC   NCCINODE,LINKID     Link name -> signon record  SML2NJE4 DMT03080
         DROP  R6                  Finished with link table    SML2NJE3 DMT03090
         SPACE 1                                                        DMT03100
         LTR   R0,R0               WAS A PARAMETER SPECIFIED?           DMT03110
         BZ    SETTAG              Nope - use all defaults     SML2NJE4 DMT03120
         SPACE 2                                                        DMT03130
*        SET UP REMOTE SYSTEM TYPE                                      DMT03140
         LA    R3,0(,R1)           GET START OF PARM FIELD IN R1        DMT03150
         LR    R5,R3               AND ALSO IN R4                       DMT03160
         ALR   R5,R0               ADD IN CNT TO PNT R4 AT END          DMT03170
         BAL   R14,PARMGET         GO GET IT                            DMT03180
         CLR   R3,R5               WAS IT SPECIFIED?                    DMT03190
         BNL   SETNOPAS            NO CONTINUE                          DMT03200
         SLR   R4,R3               R4 CONTAINS PARM LENGTH              DMT03210
         CL    R4,BUFMAXCT         TOO LONG?                            DMT03220
         BH    XJEIERR2            Yes - error exit            HRC000DT DMT03230
         STH   R4,BUFFCNT          SAVE FOR LATER                       DMT03240
         BCTR  R4,0                REDUCE BY ONE                        DMT03250
         EX    R4,ICTMOV2          AND MOVE FOR LATER                   DMT03260
         LA    R3,2(R4,R3)         POINT TO START OF NEXT PARM          DMT03270
         BAL   R14,PARMGET         FRAME IT                             DMT03280
         CLR   R3,R5               WAS IT SPECIFIED?                    DMT03290
         BNL   SETNOPAS            NO - EXIT                            DMT03300
         SLR   R4,R3               CALCULATE LENGTH                     DMT03310
         CL    R4,PASSMAX          WAS THE PASSWORD TOO LONG?  @VM01162 DMT03320
         BH    XJEIERR1            Yes..error exit             HRC000DT DMT03330
         BCTR  R4,0                DOWN BY ONE FOR CHAR OP              DMT03340
         EX    R4,ICTMOV3          AND MOVE IN THE PASSWORD             DMT03350
         EJECT                                                          DMT03360
SETNOPAS EQU   *                                                        DMT03370
         MVC   NCCILPAS,PASSWORD   Line passwd -> signon card  SML2NJE4 DMT03380
         EJECT                                                          DMT03390
*        INITIALIZE THE TASK NAME                                       DMT03400
         SPACE 1                                                        DMT03410
SETTAG   EQU   *                                                        DMT03420
         USING TAG,R8              GET TAG ADDRESSABILITY               DMT03430
*        INITIALIZE PRINT, JOB AND PUNCH TAGS                           DMT03440
         L     R8,APDEVTAG         Get SYSOUT tag address      SML2NJE4 DMT03450
         MVI   TAGINDEV,0          Could be PRT or PUN         SML2NJE4 DMT03460
         MVC   TAGINLOC(8),AXSLINK SET LOCATION ID                      DMT03470
         MVC   TAGDIST(8),AXSLINK  SET LOCATION ID                      DMT03480
         MVC   TAGLINK(8),AXSLINK SET DEFAULT LINK             @VA03300 DMT03490
         MVC   TAGTOLOC(8),LOCATION SET DEFAULT TOLOC          @VA03300 DMT03500
         MVI   PDEVSOPT,MULTOPEN   INDICATE MULTOPEN FOR PRT            DMT03510
         MVC   PDEVLINK(8),AXSLINK SET LOCATION ID                      DMT03520
         SPACE 1                                                        DMT03530
         L     R8,AJDEVTAG         GET JOB (SYSIN) TAG ADDRESS SML2NJE4 DMT03540
         MVI   TAGINDEV,TYPPUN     SET JOB DEVICE TYPE                  DMT03550
         MVC   TAGINLOC(8),AXSLINK SET LOCATION ID                      DMT03560
         MVC   TAGDIST(8),AXSLINK  SET LOCATION ID                      DMT03570
         MVC   TAGLINK(8),AXSLINK SET DEFAULT LINK             @VA03300 DMT03580
         MVC   TAGTOLOC(8),LOCATION SET DEFAULT TOLOC          @VA03300 DMT03590
         MVI   JDEVSOPT,MULTOPEN   INDICATE MULTOPEN FOR PRT            DMT03600
         MVC   JDEVLINK(8),AXSLINK SET LOCATION ID                      DMT03610
         SPACE 1                                                        DMT03620
         L     R8,ALDEVTAG         GET LOG TAG ADDRESS         SML2NJE4 DMT03630
         MVI   TAGINDEV,TYPPRT SET PRINTER DEVICE TYPE                  DMT03640
         MVC   TAGINLOC(8),AXSLINK SET LOCATION ID                      DMT03650
         MVC   TAGDIST(8),AXSLINK  SET LOCATION ID                      DMT03660
         MVC   TAGLINK(8),AXSLINK SET DEFAULT LINK             @VA03300 DMT03670
         MVC   TAGTOLOC(8),LOCATION SET DEFAULT TOLOC          @VA03300 DMT03680
         MVC   LOGGREQ+12(R8),AXSLINK SET LOCATION ID                   DMT03690
         MVI   LOGGREQ+3,MULTOPEN  SET MULTOPEN FOR PRT                 DMT03700
         DROP  R8                  DROP ADDRESSABILITY                  DMT03710
         EJECT                                                          DMT03720
*                                                                       DMT03730
*        SPECIFY TP BUFFER SIZE                                         DMT03740
*                                                                       DMT03750
         CLI   BUFFER,C' '         WAS THE BUFFER PARAMETER SPECIFIED?  DMT03760
         BE    SETNOBUF            NO - USE DEFAULT                     DMT03770
         CLI   BUFFER,C'B'         DOES IT START RIGHT?                 DMT03780
         BNE   XJEIERR2            No - error                  HRC000DT DMT03790
         LA    R1,BUFFER           GET START OF FIELD                   DMT03800
         AH    R1,BUFFCNT          AND POINT TO THE END OF IT           DMT03810
         OI    0(R1),X'C0'         SET ZONE                             DMT03820
         LH    R1,BUFFCNT          GET THE COUNT                        DMT03830
         BCTR  R1,0                DOWN BY ONE TO SHIP B                DMT03840
         BCTR  R1,0                AND AGAIN FOR CHAR OP                DMT03850
         EX    R1,PACKBUF          AND PACK THE FIELD                   DMT03860
         CVB   R1,AXSCVD           CONVERT IT TO BINARY                 DMT03870
         SRL   R1,1                SHIFT TO EVEN               @VM01162 DMT03880
         SLL   R1,1                TPBUFSIZ                    @VM01162 DMT03890
         CL    R1,MAXBUF           TOO BIG?                             DMT03900
         BH    XJEIERR2            Yes - error exit            HRC000DT DMT03910
         CL    R1,MINBUF           Too small?                  SML2NJE4 DMT03920
         BL    XJEIERR2            Yes - error exit            SML2NJE4 DMT03930
         ST    R1,TPBUFSIZ         AND SAVE                             DMT03940
SETNOBUF EQU   *                                                        DMT03950
         L     R1,TPBUFSIZ         GET SIZE OF BUFFER OR DEFAULT        DMT03960
         STH   R1,CCWC+6           AND STORE IN READ CCW                DMT03970
         STH   R1,NCCIBFSZ         And in signon card          SML2NJE4 DMT03980
         STH   R1,RDCOUNT     SET READ COUNT FIELD             @VA07451 DMT03990
         LA    R1,BUFDATA-BUFDSECT+3(R1) Size of TPB DSECT + 3 HRC001DT DMT04000
         SRL   R1,2                Round DOWN to word boundary HRC001DT DMT04010
         SLL   R1,2                Realign bits correctly      HRC001DT DMT04020
         ST    R1,BUFLN1           SAVE TO BUFFER CONSTRUCT ROUTINE     DMT04030
         SLL   R1,1                ALSO NEED 2*BUFFER SIZE              DMT04040
         ST    R1,BUFLN2           THAT GOES HERE FOR LATER             DMT04050
         SPACE 2                                                        DMT04060
*                                                                       DMT04070
*        SPECIFY ALERT ASYN EXIT                                        DMT04080
*                                                                       DMT04090
***???   ST    R9,XJEREG9          Set task r9                    *XJE  DMT04100
         LA    R1,ASYNEXIT                                              DMT04110
         SR    R0,R0               INDICATE INITIATING REQUEST          DMT04120
         L     R15,ASYNREQ         GET THE ROUTINE ADDR                 DMT04130
         BALR  R14,R15             AND SET THE EXIT                     DMT04140
*                                                                       DMT04150
         LA    R0,XJE1ISIO         Entry code 0 init successful   *XJE  DMT04160
         L     R15,=A(DMTXJE1)     -> main NJE processing rtn     *XJE  DMT04170
         BR    R15                 Go there; no return            *XJE  DMT04180
*                                                                       DMT04190
ICTMOV2  MVC   BUFFER(0),0(R3)     TO BE EXECUTED BY ABOVE CODE         DMT04200
ICTMOV3  MVC   PASSWORD(0),0(R3)   TO BE EXECUTED BY ABOVE CODE         DMT04210
PACKBUF  PACK  AXSCVD(8),BUFFER+1(0) TO BE EXECUTED FROM ABOVE          DMT04220
*                                                                       DMT04230
* Address constants from csect DMTXJEA that must be relocated     *XJE  DMT04240
* after dynamic memory is allocated and this csect is moved into  *XJE  DMT04250
* it. This is performed by routine RELOC000 above.                *XJE  DMT04260
*                                                                 *XJE  DMT04270
*                                                                 *XJE  DMT04280
*              O = offset from FIELD NAME of adcon value          *XJE  DMT04290
*              L = length of adcon                                *XJE  DMT04300
*                                                                 *XJE  DMT04310
*              ----O-L--FIELD NAME-----Sample from DMTXJEA csect--*XJE  DMT04320
*                                                                 *XJE  DMT04330
RELOC    DC    AL1(0,4),S(CCTNEXT)     DC    A($TCT2)             *XJE  DMT04340
         DC    AL1(0,4),S(CCTCOM)      DC    A($CCOMM1)           *XJE  DMT04350
         DC    AL1(0,4),S(CDEVREQ)     DC    A(*+8)               *XJE  DMT04360
         DC    AL1(1,3),S(CDEVRESP)    DC    AL1(19),AL3(*+3)     *XJE  DMT04370
         DC    AL1(0,4),S(WCTNEXT)     DC    A($TCT3)             *XJE  DMT04380
         DC    AL1(0,4),S(WCTCOM)      DC    A($WCOMM1)           *XJE  DMT04390
         DC    AL1(0,4),S(WDEVREQ)     DC    A(*+8)               *XJE  DMT04400
         DC    AL1(1,3),S(WDEVRESP)    DC    AL1(19),AL3(*+3)     *XJE  DMT04410
         DC    AL1(0,4),S(PCTNEXT)     DC    A($TCT4)             *XJE  DMT04420
         DC    AL1(0,4),S(PCTCOM)      DC    A($PCOMM1)           *XJE  DMT04430
         DC    AL1(0,4),S(PDEVREQ)     DC    A(*+8)               *XJE  DMT04440
         DC    AL1(1,3),S(PDEVRESP)    DC    AL1(19),AL3(*+3)     *XJE  DMT04450
         DC    AL1(0,4),S(APDEVTAG)    DC    A(PDEVTAG)           *XJE  DMT04460
         DC    AL1(0,4),S(APNJEHDR)    DC    A(PNJEHEAD)          *XJE  DMT04470
         DC    AL1(0,4),S(APNJEHND)    DC    A(PNJEHEND)          *XJE  DMT04480
         DC    AL1(0,4),S(RCTNEXT)     DC    A($TCT6)             *XJE  DMT04490
         DC    AL1(0,4),S(RCTCOM)      DC    A($RCOMM1)           *XJE  DMT04500
         DC    AL1(0,4),S(RDEVREQ)     DC    A(*+8)               *XJE  DMT04510
         DC    AL1(1,3),S(RDEVRESP)    DC    AL1(19),AL3(*+3)     *XJE  DMT04520
         DC    AL1(0,4),S(ARNJEHDR)    DC    A(RNJEHEAD)          *XJE  DMT04530
         DC    AL1(0,4),S(ARNJEHND)    DC    A(RNJEHEND)          *XJE  DMT04540
         DC    AL1(0,4),S(JCTCOM)      DC    A($JCOMM1)           *XJE  DMT04550
         DC    AL1(0,4),S(JDEVREQ)     DC    A(*+8)               *XJE  DMT04560
         DC    AL1(1,3),S(JDEVRESP)    DC    AL1(19),AL3(*+3)     *XJE  DMT04570
         DC    AL1(0,4),S(AJDEVTAG)    DC    A(JDEVTAG)           *XJE  DMT04580
         DC    AL1(0,4),S(AJNJEHDR)    DC    A(JNJEHEAD)          *XJE  DMT04590
         DC    AL1(0,4),S(AJNJEHND)    DC    A(JNJEHEND)          *XJE  DMT04600
         DC    AL1(0,4),S(INTFAKE)     DC    AL4($START)          *XJE  DMT04610
         DC    AL1(0,4),S(INITWAIT)    DC    A(ADAECB)            *XJE  DMT04620
         DC    AL1(1,3),S(CECBA)       DC    X'80',AL3(CMDECB)    *XJE  DMT04630
         DC    AL1(1,3),S(INITCCW)     CCW   X'2F',INITCCW+5,CC+SILI,1  DMT04640
         DC    AL1(1,3),S(INITCCWS)    CCW   X'23',ISETMODE,CC+SILI,1   DMT04650
         DC    AL1(1,3),S(INITCCWR)    CCW   1,INITSEQ,CC+SILI,2  *XJE  DMT04660
         DC    AL1(1,3),S(INITCCRD)    CCW   2,IREADRES,SILI,2    *XJE  DMT04670
         DC    AL1(0,4),S(ECBLIST)     DC    A(RDEVSYNC)          *XJE  DMT04680
         DC    AL1(0,4),S(LOKCMDA)     DC    A(CMDECB)            *XJE  DMT04690
         DC    AL1(0,4),S(LOKMSGA)     DC    A(MSGECB)            *XJE  DMT04700
         DC    AL1(0,3),S(LOKADAA)     DC    AL3(ADAECB)          *XJE  DMT04710
         DC    AL1(8,4),S(TODEBCON)    DC    F'-1',A(0+4,TIMEZON+4*XJE  DMT04720
         DC    AL1(0,4),S(WCMDA)       DC    A(WTOMBUF)           *XJE  DMT04730
         DC    AL1(0,4),S(MREQA)       DC    A(MSGBLK)            *XJE  DMT04740
         DC    AL1(0,4),S(TANKCON)     DC    A(TTANK)             *XJE  DMT04750
         DC    AL1(0,4),S(LOGREQA)     DC    A(LOGGREQ)           *XJE  DMT04760
         DC    AL1(1,3),S(LOGREQG)     DC    AL1(19),AL3(LOGGREQ) *XJE  DMT04770
         DC    AL1(0,4),S(ALDEVTAG)    DC    A(LDEVTAG)           *XJE  DMT04780
         DC    AL1(1,3),S(LOGCCW)      CCW   X'09',IOLINE,SILI,120*XJE  DMT04790
         DC    AL1(1,3),S(LOGHDCCW)    CCW   X'19',LOGHDLNE,SILI,LOG..  DMT04800
         DC    AL1(8,4),S(TERMBLK)     DC    F'0',CL4'REX ',A(TERMRE..  DMT04810
         DC    AL1(0,4),S($COMEXIT)    DC    A($START)            *XJE  DMT04820
         DC    AL1(0,4),S(ADCCWA)      DC    A(CCTCCW)            *XJE  DMT04830
         DC    AL1(1,3),S(CCWS)        CCW   1,XSYNSEQ,CD+SILI,4  *XJE  DMT04840
         DC    AL1(1,3),S(CCWB)        CCW   1,XETBSEQ,CC+SILI,2  *XJE  DMT04850
         DC    AL1(1,3),S(SGNOFCCW)    CCW   1,SGNOFDTA,CC+SILI,SG*XJE  DMT04860
         DC    AL1(1,3),S(SGNCCWA)     CCW   1,SGNOFEND,SILI,2    *XJE  DMT04870
RELOCNUM EQU   (*-RELOC)/4             Number of ADCONS           *XJE  DMT04880
*.                                                                *XJE  DMT04890
*                                                                 *XJE  DMT04900
* ENTRY NAME -                                                          DMT04910
*                                                                       DMT04920
*        PARMGET                                                        DMT04930
*                                                                       DMT04940
* FUNCTION -                                                            DMT04950
*                                                                       DMT04960
*        LINE SCANNING SUBROUTINE                                       DMT04970
*                                                                       DMT04980
* CALLS TO OTHER ROUTINES -                                             DMT04990
*                                                                       DMT05000
*        NONE                                                           DMT05010
*                                                                       DMT05020
* OPERATION -                                                           DMT05030
*                                                                       DMT05040
*        1. TEST FOR DELIMETER CHARACTER                                DMT05050
*                                                                       DMT05060
*        2. WHEN FOUND OR END OF STRING FOUND UPDATE R4                 DMT05070
*                                                                       DMT05080
*        3. AND RETURN                                                  DMT05090
*                                                                       DMT05100
* ENTRY -                                                               DMT05110
*                   REG.3 = ADDRESS OF START OF STRING                  DMT05120
*                   REG.5 = ADDRESS OF END OF STRING                    DMT05130
*                                                                       DMT05140
* EXIT -                                                                DMT05150
*                   REG.3 = FIRST NONDELIMETER CHARACTER SCANNED;       DMT05160
*                           IF NONE FOUND, END OF STRING                DMT05170
*                   REG.4 = UNMODIFIED IF NO NONDELIMETER CHAR SCANNED; DMT05180
*                           OTHERWISE, ADDRESS OF FIRST DELIMETER CHAR  DMT05190
*                           AFTER FIRST NONDELIMETER CHAR SCANNED;      DMT05200
*                           IF NONE, END OF STRING.                     DMT05210
*                   REG.5 = UNMODIFIED                                  DMT05220
*                                                                       DMT05230
*        A DELIMETER CHAR IS ANY CHARACTER OF THE FORM B'XX000000'      DMT05240
*                                                                       DMT05250
* RESPONSES -                                                           DMT05260
*                                                                       DMT05270
*        NONE                                                           DMT05280
*                                                                       DMT05290
* ERROR MESSAGES -                                                      DMT05300
*                                                                       DMT05310
*        NONE                                                           DMT05320
*                                                                       DMT05330
*.                                                                      DMT05340
         EJECT                                                          DMT05350
PARMGET  DC    0H'0'                                                    DMT05360
         LA    R5,0(R5)            CLEAR HIGH ORDER BYTE JUST IN CASE   DMT05370
         BCTR  R3,0                BUMP START OF STRING PTR BACK FOR C  DMT05380
PARMFIND EQU   *                                                        DMT05390
         LA    R3,1(R3)            LOOK AT THE NEXT CHARACTER           DMT05400
         CLR   R3,R5               HAVE WE HIT THE END OF THE STRING?   DMT05410
         BCR   11,R14              (BNL) YEP - LOOK NO MORE             DMT05420
         TM    0(R3),X'3F'         IS THIS CHARACTER A DELIMETER?       DMT05430
         BZ    PARMFIND            YEP- KEEP LOOKING FOR A NONDELIMETER DMT05440
         LR    R4,R3               SET UP FOR NEXT PHASE OF SCAN        DMT05450
PARMSCAN EQU   *                                                        DMT05460
         LA    R4,1(R4)            LOOK AT THE NEXT CHARACTER           DMT05470
         CLR   R4,R5               ARE WE AT THE END OF THE STRING YET? DMT05480
         BCR   11,R14              (BNL) RETURN IMMEDIATELY IF SO       DMT05490
         TM    0(R4),X'3F'         IS THIS CHARACTER A DELIMETER?       DMT05500
         BNZ   PARMSCAN            KEEP SCANNING FOR A DELIMETER IF NOT DMT05510
         BR    R14                 OTHERWISE ALL DONE - RETURN          DMT05520
         EJECT                                                          DMT05530
*---------------------------------------------------------------------* DMT05540
*                                                                     * DMT05550
*                 INITIALIZATION ERROR PROCESSOR                      * DMT05560
*                                                                     * DMT05570
*---------------------------------------------------------------------* DMT05580
         SPACE 1                                                        DMT05590
         DS    0H                                                       DMT05600
XJEIERR1 EQU   *                                               HRC000DT DMT05610
         LA    R0,XJE1ERR1         Display init error msg 901     *XJE  DMT05620
         L     R15,=A(DMTXJE1)     -> main NJE processing rtn     *XJE  DMT05630
         BR    R15                 Go there to handle this error  *XJE  DMT05640
*                                                                       DMT05650
XJEIERR2 EQU   *                                               HRC000DT DMT05660
         LA    R0,XJE1ERR2         Display init error msg 906     *XJE  DMT05670
         L     R15,=A(DMTXJE1)     -> main NJE processing rtn     *XJE  DMT05680
         BR    R15                 Go there to handle this error  *XJE  DMT05690
*                                                                       DMT05700
         LTORG                                                          DMT05710
         EJECT                                                          DMT05720
*.                                                                      DMT05730
*                                                                       DMT05740
* ENTRY NAME -                                                          DMT05750
*                                                                       DMT05760
*        ASYNEXIT                                                       DMT05770
*                                                                       DMT05780
* FUNCTION -                                                            DMT05790
*                                                                       DMT05800
*        THIS IS THE ALERT EXIT ENTERED BY DMTSIG.  TWO TASKS MAY       DMT05810
*        ALERT THIS LINE DRIVER: DMTREX WHEN A COMMAND HAS BEEN         DMT05820
*        ENTERED FOR THE DMTXJE LINE DRIVER TO PROCESS OR DMTAXS  000DT DMT05830
*        TO ASYNCHRONOUSLY NOTIFY DMTXJE A FILE HAS ARRIVED FOR   000DT DMT05840
*        TRANSMISSION.                                                  DMT05850
*                                                                       DMT05860
* CALLS TO OTHER ROUTINES -                                             DMT05870
*                                                                       DMT05880
*        DMTPST - TO POST AN EVENT COMPLETION                           DMT05890
*                                                                       DMT05900
* OPERATION -                                                           DMT05910
*                                                                       DMT05920
*        1. TEST IF THE ALERTING TASK IS DMTAXS OR DMTREX.              DMT05930
*                                                                       DMT05940
*        2. IF DMTAXS POST READER SYNCH LOCK COMPLETE.                  DMT05950
*                                                                       DMT05960
*        3. IF DMTREX AND MSG, QUEUE THE MSG FOR LATER                  DMT05970
*           PROCESSING BY A CALL TO PMSGREQ.                            DMT05980
*                                                                       DMT05990
*        4. IF A COMMAND MOVE THE COMMAND TO XJE STORAGE AND POST 000DT DMT06000
*           THE COMMAND SYNCH LOCK COMPLETE.                            DMT06010
*                                                                       DMT06020
* RESPONSES -                                                           DMT06030
*                                                                       DMT06040
*        NONE                                                           DMT06050
*                                                                       DMT06060
* ERROR MESSAGES -                                                      DMT06070
*                                                                       DMT06080
*        NONE                                                           DMT06090
*                                                                       DMT06100
*.                                                                      DMT06110
         SPACE 2                                                        DMT06120
ASYNEXIT EQU   *                                                        DMT06130
***      L     R12,TASKSAVE-TASKE(R13) GET THE FIRST BASE REGISTER*XJE  DMT06140
***      L     R9,XJEREG9          -> DMTXJEA stg area            *XJE  DMT06150
         CLI   1(R1),NMR           Is it an NMR?               SML2NJE4 DMT06160
         BE    ASYNENQ             Go and stack NMR            SML2NJE4 DMT06170
         CL    R0,REXNAME          IS IT THE CONTROLLING TASK CALLING   DMT06180
         BNE   ASYN1               NO                                   DMT06190
         CLI   1(R1),MSGCMD        IS IT A MSG ELEMENT?                 DMT06200
         BE    ASYNENQ             Yes. Stack message          SML2NJE4 DMT06210
         EJECT                                                          DMT06220
ASYNCONT EQU   *                                                        DMT06230
         CLI   CMDINPGS,X'FF'      IS A COMMAND ALREADY IN PROCESS      DMT06240
         BE    ASYNCMD             YES TIME TO EXIT                     DMT06250
         MVI   2(R1),X'00'         INDICATE ACCEPTING COMMAND           DMT06260
         OI    CMDINPGS,X'FF'      SHOW COMMAND ACTIVE                  DMT06270
         SR    R15,R15             ZERO FO IC                           DMT06280
         IC    R15,0(R1)           GET COMMAND ELEMENT LENGTH           DMT06290
         EX    R15,CMDMVC          AND MOVE TO MY BUFFER                DMT06300
         LA    R1,CMDECB           MUST NEED CMD                        DMT06310
         B     ASYNRET             GO TO COMMON EXIT                    DMT06320
         SPACE 1                                                        DMT06330
ASYN1    EQU   *                                                        DMT06340
         CL    R0,AXSNAME          IS IT FILE ACCESS                    DMT06350
         BNER  R14                 NOPE..RETURN                         DMT06360
         TM    RCTECB,TCTBUSY    IS READER BUSY???            @VA10416  DMT06370
         BOR   R14               BR, IF YES                   @VA10416  DMT06380
         LA    R1,RDEVSYNC         READER TO BE POSTED                  DMT06390
ASYNRET  EQU   *                                                        DMT06400
         LA    R0,0                POST CODE                            DMT06410
         L     R15,POSTREQ         SYSTEM POST PROCESSOR                DMT06420
         BR    R15                 AND CONTINUE                         DMT06430
         SPACE 1                                                        DMT06440
ASYNCMD  EQU   *                                                        DMT06450
         MVI   2(R1),X'10'         SHOW COMMAND REFUSAL                 DMT06460
         BR    R14                 AND RETURN TO REX                    DMT06470
         SPACE 1                                                        DMT06480
ASYNENQ  EQU   *                                                        DMT06490
         L     R2,XJELINK          Get link table address      HRC000DT DMT06500
         LA    R13,ASYNSAVE        Get save area for ASYNEXIT  SML2NJE4 DMT06510
*DEL     L     R15,TCOM            GET COMMON ROUTINES LIST       *XJE  DMT06520
         L     R15,PMSGREQ         AND THE MSG STACK ROUTINE ADDR       DMT06530
         LR    R3,R14              SAVE RETURN REGISTER                 DMT06540
         BALR  R14,R15             AND STACK THE MSG                    DMT06550
         LR    R14,R3              RESTORE RETURN REGISTER              DMT06560
         LTR   R15,R15             DID MSG STACK?                       DMT06570
         BNZ   ASYNCMD             NO                                   DMT06580
         MVI   2(R1),X'00'         INDICATE ACCEPTANCE                  DMT06590
         LA    R1,MSGECB           INDICATE THE CORRECT ECB FOR POST    DMT06600
         B     ASYNRET             AND CONTINUE                         DMT06610
         SPACE 1                                                        DMT06620
CMDMVC   MVC   CMDRESP(0),0(R1)    TO BE EXECUTED BY ABOVE CODE         DMT06630
         LTORG                                                          DMT06640
         EJECT                                                          DMT06650
*                                                                       DMT06660
********************                                                    DMT06670
*                  *   Core line driver functions.                      DMT06680
* CSECT DMTXJE1    *                                                    DMT06690
*                  *                                                    DMT06700
********************                                                    DMT06710
*                                                                       DMT06720
DMTXJE1  CSECT                                                    *XJE  DMT06730
         LR    R12,R15             Set entry addr                 *XJE  DMT06740
         LA    R11,2048                                           *XJE  DMT06750
         LA    R11,2048(R11,R12)   Get 2nd base                   *XJE  DMT06760
         LA    R10,2048                                           *XJE  DMT06770
         LA    R10,2048(R10,R11)   Get 3rd base                   *XJE  DMT06780
         USING DMTXJE1,R12,R11,R10                                *XJE  DMT06790
*                                                                       DMT06800
         LR    R14,R0              Get entry code                 *XJE  DMT06810
         B     XJE1FUNC(R14)       Branch into table of functions *XJE  DMT06820
*                                                                       DMT06830
XJE1FUNC B     ISIO                Code 00 Initialization complete*XJE  DMT06840
         B     XJELERR1            Code 04 Initialization error 1 *XJE  DMT06850
         B     XJELERR2            Code 08 Initialization error 2 *XJE  DMT06860
*                                                                       DMT06870
*.                                                                      DMT06880
*                                                                       DMT06890
* ENTRY NAME -                                                          DMT06900
*                                                                       DMT06910
*        ISIO                                                           DMT06920
*                                                                       DMT06930
* FUNCTION -                                                            DMT06940
*                                                                       DMT06950
*        THIS ROUTINE PERFORMS THE ENABLE SEQUENCE ON THE               DMT06960
*        COMMUNICATIONS LINE, ANALYZES THE RESPONSE RECEIVED, AND       DMT06970
*        WHEN CORRECT WRITES THE LINE CONNECTED MSG.                    DMT06980
*                                                                       DMT06990
* CALLS TO OTHER ROUTINES -                                             DMT07000
*                                                                       DMT07010
*        DMTIOMRQ - TO INITIATE AN I/O OPERATION                        DMT07020
*        DMTWAT - TO WAIT FOR AN EVENT COMPLETION                       DMT07030
*                                                                       DMT07040
* OPERATION -                                                           DMT07050
*                                                                       DMT07060
*        1. ISSUE INITIAL MESSAGE 141.                                  DMT07070
*                                                                       DMT07080
*        2. ENABLE TP LINE AND WAIT FOR ENABLE TO COMPLETE.             DMT07090
*                                                                       DMT07100
*        3. EXAMINE RESPONSE FROM INITIAL READ AND VALIDATE             DMT07110
*           DEPENDENT ON SML MODE.                                      DMT07120
*                                                                       DMT07130
*        4. WHEN CORRECT REPLY HAS BEEN RECEIVED ISSUE MSG 142          DMT07140
*           AND EXIT TO IBLDBUFS.                                       DMT07150
*                                                                       DMT07160
* RESPONSES -                                                           DMT07170
*                                                                       DMT07180
*        DMTXJE141I  LINK 'VADDR' READY FOR CONNECTION TO ...  HRC000DT DMT07190
*        DMTXJE142I  LINK 'LINKID' LINE 'VADDR' CONNECTED      HRC000DT DMT07200
*                                                                       DMT07210
* ERROR MESSAGES -                                                      DMT07220
*                                                                       DMT07230
*        NONE                                                           DMT07240
*                                                                       DMT07250
*.                                                                      DMT07260
ISIO     DS    0H                                                       DMT07270
         L     R6,XJELINK          Get linktable address for.. HRC031DT DMT07280
         USING LINKTABL,R6         Link table addressability   HRC031DT DMT07290
         OI    LFLAG,LACTIVE       Mark link as active            *XJE  DMT07300
         NI    LFLAG,255-LCONNECT  Mark link as not connected  HRC031DT DMT07300
         DROP  R6                  Finished with link table    HRC031DT DMT07310
         MVC   INITSEQ(2),IPRISEQ  Reset greeting sequence     SML2NJE4 DMT07320
         MVI   INITCCW,DISABLE     Replace DISABLE             SML2NJE4 DMT07330
         MVI   INITCCWS,SETMODE    Replace SETMODE             SML2NJE4 DMT07340
         MVI   INITCCWR,WRITE      Replace WRITE if changed    SML2NJE4 DMT07350
         MVI   INITCCRD,READ       Replace READ if changed     SML2NJE4 DMT07360
         NI    XJESYS,PRIMONLY     Clear signon etc status     SML2NJE4 DMT07370
         MVI   CBCBCNTO,X'80'      Reset outgoing BCB value    SML2NJE4 DMT07380
         MVI   CBCBCNTI,X'80'      Reset incoming BCB value    SML2NJE4 DMT07390
         MVC   $FCSOUT(2),=X'8FCF' Reset outgoing FCS to open  SML2NJE4 DMT07400
         MSGX  141,(XJELINE,AXSLINK) Write msg                 HRC000DT DMT07410
         EJECT                                                          DMT07420
         TM    XJESYS,PRIMONLY     Are we defined as secondary?SML2NJE4 DMT07430
         BNO   ISIO1               NOPE CONTINUE                        DMT07440
         MVI   INITCCWR,NOP     IN HOST NOP WRITE ENQUE       @VA09842  DMT07450
ISIO1    EQU   *                                                        DMT07460
         LA    R7,15               SET RETRY COUNTER                    DMT07470
RISIO    EQU   *                   Establish comms with remote SML2NJE4 DMT07480
         LA    R6,INITCCW          INITIALIZATION CCW STRING            DMT07490
I27XXIO  EQU   *                   ENTRY                                DMT07500
         ST    R6,ADCCWA           STORE IN CAW                         DMT07510
         XC    ADAECB(4),ADAECB    CLEAR OUT SYNCH LOCK                 DMT07520
         MVI   ADASENSE,X'00'      ZERO SENSE BYTE                      DMT07530
         LA    R1,ADAECB           GET ADAPTER IO BLOCK                 DMT07540
         L     R15,IOREQ           SYSTEM I/O PROCESSOR                 DMT07550
         BALR  R14,R15             GO EXECUTE THE I/O                   DMT07560
         CLI   ADASIOCC,X'03'      DOES THE ADAPTER EXIST?              DMT07570
         BNE   RISIO1              OKAY CONTINUE                        DMT07580
         LA    R1,INITCCW          GET FAILING CCW ADDR                 DMT07590
         BAL   R14,IOERRPRT        GO WRITE ERR MSG                     DMT07600
         B     XJECRASH                Exit w/o disable        HRC000DT DMT07610
         EJECT                                                          DMT07620
RISIO1   EQU   *                                                        DMT07630
         LA    R1,INITWAIT         GET WAIT LIST                        DMT07640
         L     R15,WAITREQ         SYSTEM WAIT PROCESSOR                DMT07650
         BALR  R14,R15             WAIT FOR I/O TO COMPLETE             DMT07660
         TM    CMDECB,X'40'        WAS IT A COMMAND?              *XJE  DMT07670
         BO    INITCMD             YES                                  DMT07680
RISIO2   EQU   *                                                        DMT07690
         MVI   INITCCW,SENSE       CHANGE DISABLE TO SENSE              DMT07700
         MVI   INITCCWS,NOP        NOP SET MODE                         DMT07710
         TM    ADACSW+4,UE         Did we get unit exception?  SML2NJE4 DMT07720
         BZ    RISIO3              No data lost condition then SML2NJE4 DMT07730
         MVC   INITCCWS(8),IREADSKP Replace SET MODE / NOP CCW SML2NJE4 DMT07740
         B     RISIO               Go do I/O to clear data lostSML2NJE4 DMT07750
RISIO3   EQU   *                                               SML2NJE4 DMT07760
         CLC   ADACSW+4(2),=X'0C00' DID IT END OKAY                     DMT07770
         BNZ   SLOOP               RETRY IF PREVIOUS I/O BAD            DMT07780
         TM    XJESYS,RESPEND      Secondary response sent?    SML2NJE4 DMT07790
         BO    SIGNOK              Yes.  Go wait for signon.   SML2NJE4 DMT07800
         CLC   ISECRES(2),IREADRES Secondary response arrived? SML2NJE4 DMT07810
         BE    GOTSECRS            Other end is secondary      SML2NJE4 DMT07820
         CLC   IPRISEQ(2),IREADRES Primary sequence arrived?   SML2NJE4 DMT07830
         BE    GOTPRISQ            Other end is primary        SML2NJE4 DMT07840
         CLC   IALTSEQ(2),IREADRES Alternate sequence arrived? SML2NJE4 DMT07850
         BE    RISIO               Other end can't decide.     SML2NJE4 DMT07860
         SPACE 1                                                        DMT07870
SLOOP    EQU   *                                                        DMT07880
         TM    ADASENSE,B'00000001' TIMEOUT?                            DMT07890
         BO    RISIO               YES..DONT COUNT                      DMT07900
         BCT   R7,RISIO            RETRY 15 TIMES                       DMT07910
         XR    R1,R1          Clear top byte of R1             HRC004DT DMT07920
         ICM   R1,B'0111',ADACSW Get CCW address and set CC    HRC004DT DMT07930
         BZ    RISIOCSW       Avoid PROG 0005 in IOERRPRT      HRC004DT DMT07940
         SH    R1,=H'8'            Back up 8                   HRC001DT DMT07950
RISIOCSW EQU   *                                               HRC004DT DMT07960
         BAL   R14,IOERRPRT        WRITE THE ERR MSG                    DMT07970
         B     EOJ                 TERMINATE THE TASK                   DMT07980
         SPACE 1                                                        DMT07990
INITCMD  EQU   *                                                        DMT08000
         XC    CMDECB(4),CMDECB    CLEAR SYNCH LOCK                     DMT08010
         LM    R3,R5,CMDSETUP      PREPARE FOR COMMAND SCAN             DMT08020
INITCDSN EQU   *                                                        DMT08030
         CLC   0(1,R3),CMDRESP+1   IS IT THIS ONE                       DMT08040
         BE    INTCALL             YES                                  DMT08050
         BXLE  R3,R4,INITCDSN      PREPARE FOR NEXT COMPARE             DMT08060
INTCALL  EQU   *                                                        DMT08070
         L     R6,XJELINK          Get link table address      HRC000DT DMT08080
         MVC   MSGLINK(8),CMDRESP+4 MOVE IN RESPONSE LINKID             DMT08090
         L     R15,0(R3)           GET ROUTINE TO CALL                  DMT08100
         BALR  R14,R15             GO EXECUTE THE COMMAND               DMT08110
         MVI   CMDINPGS,X'00'      RESET COMMAND IN PROGRESS SWITCH     DMT08120
         TM    ADAECB,X'40'        WAS THE ADAPTER ALSO POSTED?   *XJE  DMT08130
         BO    RISIO2              YES                                  DMT08140
         B     RISIO1              NO..WAIT AGAIN                       DMT08150
         EJECT                                                          DMT08160
GOTPRISQ EQU   *                                               SML2NJE4 DMT08170
         OI    XJESYS,PRIMARY+RESPEND Mark other end primary   SML2NJE4 DMT08180
         MVC   INITSEQ(2),ISECRES  Set up secondary response   SML2NJE4 DMT08190
         MVI   INITCCWR,WRITE      Put back in write CCW       SML2NJE4 DMT08200
         MVI   INITCCRD,NOP        Do not do read after write  SML2NJE4 DMT08210
         B     RISIO               Go do I/O to send response  SML2NJE4 DMT08220
GOTSECRS EQU   *                                               SML2NJE4 DMT08230
         OI    XJESYS,SECONDRY     Mark other end as secondary SML2NJE4 DMT08240
         B     SIGNOK              Go send signon record       SML2NJE4 DMT08250
SIGNOK   EQU   *                                                        DMT08260
         MVC   $COMEXIT(4),INTFAKE SET FAKE INTERRUPT                   DMT08270
         MSGX  142,(AXSLINK,XJELINE) Write message             HRC000DT DMT08280
         XC    ADAECB(4),ADAECB    Clear adapter synch lock    HRC002DT DMT08290
         LA    R8,CCTCCW           GET RIGHT CCW ADDR                   DMT08300
         ST    R8,ADCCWA           AND SET CAW                          DMT08310
         B     IBLDBUFS            GO CONSTRUCT BUFFER POOL             DMT08320
         SPACE 1                                                        DMT08330
IBLDBUFS DS    0H                                                       DMT08340
         ICM   R1,B'1111',BUFSPAGE Get address of buffer page  SML2NJE4 DMT08350
         BNZ   SKIPBUFS            Buffers allocated already?  SML2NJE4 DMT08360
*DEL     L     R15,TCOM            GET COMMON ROUTINES LIST       *XJE  DMT08370
         SR    R0,R0               Init                           *XJE
         L     R1,MAXBUF           Get line's buffer size         *XJE
         LA    R1,12(,R1)          Add in overhead                *XJE
         M     R0,BNUMBUFS         Times number of buffers        *XJE
         SLDL  R0,20               # of pages to R0               *XJE
         LTR   R1,R1               Even page size?                *XJE
         BZ    *+8                 Yes, R0 is perfect             *XJE
         A     R0,BONE             Else add 1 additional page     *XJE
         L     R15,GPAGEREQ        Get # pages specified by R0          DMT08380
         LA    R13,COMSAVE         USE THIS SAVE AREA                   DMT08390
         BALR  R14,R15             AND GET A PAGE                       DMT08400
         LTR   R1,R1               Did request succeed?        SML2NJE4 DMT08410
         BZ    MSG495              Issue error message and exitSML2NJE4 DMT08420
         ST    R1,BUFSPAGE         Set address of buffer page     *XJE  DMT08350
SKIPBUFS EQU   *                   Buffers already allocated   SML2NJE4 DMT08430
         LR    R4,R1               LOAD ADDR OF 1ST BUFFER              DMT08440
         LR    R5,R1               LOAD ADDR OF 1ST BUFFER              DMT08450
         ST    R1,$BUFPOOL         STORE START OF FREE BUFFER POOL      DMT08460
         L     R6,BNUMBUFS         NUMBER OF BUFFERS TO BE BUILT        DMT08470
BULDMORE DS    0H                                                       DMT08480
         A     R5,BUFLN2           CALCULATE IFLAST BUFFER ADDR         DMT08490
         S     R6,BONE             DOWN BY ONE                          DMT08500
         BZ    BUFSDONE            BR IF LAST BUFFER                    DMT08510
         S     R5,BUFLN1           AND THE NEXT ONE                     DMT08520
         ST    R5,0(0,R4)          STORE POINTER IN PREV BUF            DMT08530
         MVC   L'BUFCHAIN((BUFSTART-BUFCOUNT),R4),BUFZEROS MOVE IN      DMT08540
*                                  INITIAL VALUES                       DMT08550
         L     R4,0(0,R4)          CHAIN                                DMT08560
         B     BULDMORE            BR TO BUILD ANOTHER BUFF             DMT08570
         SPACE 1                                                        DMT08580
BUFSDONE DS    0H                                                       DMT08590
         L     R5,BUFZEROS         LOAD CHAIN TERMINATOR                DMT08600
         ST    R5,0(0,R4)          STORE IT IN THE LAST BUFFER          DMT08610
         MVC   L'BUFCHAIN((BUFSTART-BUFCOUNT),R4),BUFZEROS MOVE IN      DMT08620
*                                  INITIAL VALUES                       DMT08630
         EJECT                                                          DMT08640
*        NOW BUILD THE TANK QUEUE                                       DMT08650
         ICM   R1,B'1111',TANKPAGE Get address of tanks page   SML2NJE4 DMT08660
         BNZ   SKIPTANK            Tanks allocated already?    SML2NJE4 DMT08670
*DEL     L     R15,TCOM            GET COMMON ROUTINES LIST       *XJE  DMT08680
         LA    R0,1                # of pages requested           *XJE
         L     R15,GPAGEREQ        GET THE RIGHT ROUTINE                DMT08690
         LA    R13,COMSAVE         USE THIS SAVE AREA                   DMT08700
         BALR  R14,R15             AND GET A PAGE                       DMT08710
         LTR   R1,R1               Did request succeed?        SML2NJE4 DMT08720
         BZ    MSG495              Issue error message and exitSML2NJE4 DMT08730
         ST    R1,TANKPAGE         Set address of tanks page      *XJE  DMT08350
SKIPTANK EQU   *                   Tanks already allocated     SML2NJE4 DMT08740
         LR    R4,R1               LOAD ADDR OF 1ST TANK                DMT08750
         LR    R5,R1               LOAD ADDR OF 1ST TANK                DMT08760
         ST    R1,$TANKPOL         STORE START OF FREE TANK POOL        DMT08770
         L     R6,TNUMBUFS         NUMBER OF TANKS TO BE BUILT          DMT08780
TBLDMORE DS    0H                                                       DMT08790
         A     R5,TNKLN2           GET THE LAST ONE                     DMT08800
         S     R6,BONE             DOWN BY ONE                          DMT08810
         BZ    TNKSDONE            BR IF LAST TANK                      DMT08820
         S     R5,TNKLN1           AND THE NEXT ONE                     DMT08830
         ST    R5,0(0,R4)          STORE POINTER IN PREV BUF            DMT08840
         MVC   L'TANKCHN((TANKDATA-TANKRCB),R4),BUFZEROS MOVE IN        DMT08850
*                                  INITIAL VALUES                       DMT08860
         L     R4,0(0,R4)          CHAIN                                DMT08870
         B     TBLDMORE            BR TO BUILD ANOTHER TANK             DMT08880
         SPACE 1                                                        DMT08890
TNKSDONE DS    0H                                                       DMT08900
         L     R5,BUFZEROS         LOAD CHAIN TERMINATOR                DMT08910
         ST    R5,0(0,R4)          STORE IT IN THE LAST BUFFER          DMT08920
         MVC   L'TANKCHN((TANKDATA-TANKRCB),R4),BUFZEROS MOVE IN        DMT08930
*                                  INITIAL VALUES                       DMT08940
         EJECT                                                          DMT08950
*        Send the initial signon record if we are primary               DMT08960
         USING BUFDSECT,R13        *                                    DMT08970
         TM    XJESYS,PRIMARY      Is remote end the primary?  SML2NJE4 DMT08980
         BO    NSGNCRD             YES DO NOT NEED SIGNON CARD          DMT08990
*        Set parts of initial signon record which might change SML2NJE4 DMT09000
         MVI   NCCSRCB,C'I'        SRCB for initial signon rec SML2NJE4 DMT09010
         XC    NCCIEVNT,NCCIEVNT   Connection event sequence   SML2NJE4 DMT09020
         CLC   $BUFPOOL,=F'0'      ARE WE EMPTY                         DMT09030
         BE    IBUF1               YES                                  DMT09040
         L     R13,$BUFPOOL        GET FIRST BUFFER ADDR                DMT09050
         MVC   $BUFPOOL(4),0(R13)  REMOVE THIS ONE FROM CHAIN           DMT09060
IBUF1    EQU   *                                                        DMT09070
         MVC   BUFCOUNT(ICTLE-ICTLS),ICTLS SETUP CONTROL REPLY          DMT09080
         LA    R8,$OUTBUF          GET NEXT PTR                   *XJE  DMT09090
IBUF2    EQU   *                                                        DMT09100
         CLC   0(4,R8),=F'0'       IS IT THE LAST                       DMT09110
         BE    IBUF3               YES                                  DMT09120
         L     R8,0(0,R8)          GET THE NEXT ONE                     DMT09130
         B     IBUF2               AND COMPARE                          DMT09140
         SPACE 1                                                        DMT09150
IBUF3    EQU   *                                                        DMT09160
         ST    R13,0(0,R8)         CHAIN THIS ONE TO IT                 DMT09170
         MVC   0(4,R13),=F'0'      SET NEW FORWARD ZERO                 DMT09180
NSGNCRD  EQU   *                                                        DMT09190
         CLC   $BUFPOOL,=F'0'      ARE WE EMPTY                         DMT09200
         BE    IBUF4               YES                                  DMT09210
         L     R13,$BUFPOOL        GET FIRST BUFFER ADDR                DMT09220
         MVC   $BUFPOOL(4),0(R13)  REMOVE THIS ONE FROM CHAIN           DMT09230
IBUF4    EQU   *                                                        DMT09240
         ST    R13,CBUFFER         SET FOR I/O ROUTINES                 DMT09250
         MVC   BUFSTART,XACKSEQ    FAKE AN ACK                          DMT09260
         B     $ENDREAD            FAKE AN INTERRUPT                    DMT09270
         DROP  R13                                                      DMT09280
MSG495   EQU   *                                               SML2NJE4 DMT09290
         MSGX  495                 Virtual storage size insuff SML2NJE4 DMT09300
         B     EOJ                 Exit task                   SML2NJE4 DMT09310
         EJECT                                                          DMT09320
*.                                                                      DMT09330
*                                                                       DMT09340
* ENTRY NAME -                                                          DMT09350
*                                                                       DMT09360
*        $START                                                         DMT09370
*                                                                       DMT09380
* FUNCTION -                                                            DMT09390
*                                                                       DMT09400
*        THIS IS THE SUPERVISOR ROUTINE FOR DMTXJE.  THE       HRC000DT DMT09410
*        COMMUTATOR WILL CYCLE LOOKING FOR A ROUTINE TO ENTER           DMT09420
*        UNTIL ALL COMMUTATOR ENTRIES ARE CLOSED, THEN IT WILL          DMT09430
*        WAIT ON A SYNCH LOCK LIST TO BE POSTED.                        DMT09440
*                                                                       DMT09450
* CALLS TO OTHER ROUTINES -                                             DMT09460
*                                                                       DMT09470
*        DMTWAT - TO WAIT FOR AN EVENT COMPLETION                       DMT09480
*                                                                       DMT09490
* OPERATION -                                                           DMT09500
*                                                                       DMT09510
*        1. EXIT TO ANY ROUTINE WHOSE COMMUTATOR GATE IS OPEN.          DMT09520
*                                                                       DMT09530
*        2. CHECK THE STATUS OF THE SYNCH LOCK FOR EACH PROCESSOR, IF   DMT09540
*           THE SYNCH LOCK IS POSTED, OPEN THE PROCESSORS COMMUTATOR    DMT09550
*           GATE.                                                       DMT09560
*                                                                       DMT09570
*        3. CHECK THE PROGRESS OF A DRAIN OR HOLD. IF COMPLETE ISSUE    DMT09580
*           APPROPRIATE MESSAGE.                                        DMT09590
*                                                                       DMT09600
*        4. CHECK TO SEE IF ANY COMMUTATOR GATES ARE OPEN, IF NONE      DMT09610
*           ARE OPEN WAIT ON THE LIST OF PROCESSOR SYNCH LOCKS.         DMT09620
*                                                                       DMT09630
* RESPONSES -                                                           DMT09640
*                                                                       DMT09650
*        DMTXJE611I  LINK 'LINKID' FILE TRANSMISSION SUSPENDED HRC000DT DMT09660
*                                                                       DMT09670
* ERROR MESSAGES -                                                      DMT09680
*                                                                       DMT09690
*        NONE                                                           DMT09700
*                                                                       DMT09710
*.                                                                      DMT09720
         SPACE 1                                                        DMT09730
         USING IOTABLE,R8          GET IOTABLE ADDRESSABILITY           DMT09740
CMDECK   EQU   *                                                        DMT09750
         TM    CMDECB,X'40'        IS CMD NEEDED                  *XJE  DMT09760
         BZ    MSGECK              NO                                   DMT09770
         XC    CMDECB(4),CMDECB    CLEAR OUT SYNCH LOCK                 DMT09780
         MVI   $CMDCOM+1,OPEN      OPEN CMD GATE                        DMT09790
MSGECK   EQU   *                                                        DMT09800
         TM    MSGECB,X'40'        IS MSG NEEDED                  *XJE  DMT09810
         BZ    RDRECBCK            NO                                   DMT09820
         XC    MSGECB(4),MSGECB    CLEAR OUT SYNCH LOCK                 DMT09830
         MVI   $MSGCOM+1,OPEN      OPEN MSG GATE                        DMT09840
         SPACE                                                          DMT09850
RDRECBCK EQU   *                                                        DMT09860
         TM    RDEVSYNC,X'40'      IS THE READER POSTED?          *XJE  DMT09870
         BNO   JOBECBCK            No                          SML2NJE4 DMT09880
         XC    RDEVSYNC(4),RDEVSYNC CLEAR OUT SYNCH LOCK                DMT09890
         MVI   $RCOMM1+1,OPEN      OPEN READER GATE                     DMT09900
         SPACE 1                                                        DMT09910
JOBECBCK EQU   *                                                        DMT09920
         TM    MASTERSW,JOB        IS THE DEVICE OPEN                   DMT09930
         BNO   PRTECBCK            NO                                   DMT09940
         L     R8,JDEVFIOA         GET IOTABLE ADDRESS                  DMT09950
         TM    IOSYNCH,X'40'       SEE IF DONE                    *XJE  DMT09960
         BNO   PRTECBCK            NOT DONE YET                         DMT09970
         OI    $JCOMM1+1,OPEN      OPEN GATE                            DMT09980
         OC    JCTECB,ENDCSW+4     OR IN CSW STATUS                     DMT09990
         NI    JCTECB,X'EF'        TURN OFF BUSY                        DMT10000
         XC    IOSYNCH(4),IOSYNCH  CLEAR ECB                            DMT10010
         SPACE 1                                                        DMT10020
PRTECBCK EQU   *                                                        DMT10030
         TM    MASTERSW,SYSOUT     Is UR output device open?   SML2NJE4 DMT10040
         BNO   ADAECBCK            NOPE                                 DMT10050
         L     R8,PDEVFIOA         GET IOBABLE ADDRESS                  DMT10060
         TM    IOSYNCH,X'40'       SEE IF COMPLETE                *XJE  DMT10070
         BNO   ADAECBCK            NOT DONE YET                         DMT10080
         OI    $PCOMM1+1,OPEN      OPEN GATE                            DMT10090
         OC    PCTECB(1),ENDCSW+4  SET ECB WITH CSW STATUS              DMT10100
         NI    PCTECB,X'EF'        TURN OFF INUSE                       DMT10110
         XC    IOSYNCH(4),IOSYNCH  CLEAR OUT SYNCH LOCK                 DMT10120
         SPACE 1                                                        DMT10130
ADAECBCK EQU   *                                                        DMT10140
         TM    ADAECB,X'40'        IS THE ADAPTER POSTED          *XJE  DMT10150
         BNO   ALLCHK              NO                                   DMT10160
         OI    $COMCOM+5,OPEN      OPEN GATE                            DMT10170
         B     GOLOGIT             GO LOG THE RECEIVED BUFFER           DMT10180
         SPACE                                                          DMT10190
LOGITBK  EQU   *                                                        DMT10200
         XC    ADAECB(4),ADAECB    CLEAR ECB                            DMT10210
         USING LINKTABL,R6         Link table addressability   SML2NJE3 DMT10220
         L     R6,XJELINK          Get link table address      HRC000DT DMT10230
         TM    LFLAG,LDRAIN        IS A DRAIN IN PROGRESS?              DMT10240
         BNO   ALLHLD              NO CONTINUE                          DMT10250
         CLI   MASTERSW,X'00'      ALL FUNCTIONS COMPLETED?             DMT10260
         BNE   ALLHLD         NO..CONTINUE                     @VA03276 DMT10270
         CLC   $OUTBUF(4),=F'0' ALL BUFFERS SENT               @VA03276 DMT10280
         BE    SIGNOFF             Go send signoff record      SML2NJE4 DMT10290
ALLHLD   EQU   *                                                        DMT10300
         TM    RDRCMD,RHLDIPGS     IS A HOLD PENDING?                   DMT10310
         BNO   ALLCHK              NO CONTINUE                          DMT10320
         CLI   MASTERSW,X'00'      NOTHING ACTIVE?                      DMT10330
         BNE   ALLCHK              YES..ACTIVE PROCESSOR                DMT10340
         CLC   $OUTBUF(4),=F'0' ALL BUFFERS SENT?              @VA03276 DMT10350
         BNE   ALLCHK         NO..CONTINUE ON                  @VA03276 DMT10360
         OI    LFLAG,LHOLD         INDICATE WE ARE HELD                 DMT10370
         DROP  R6                  Finished with link table    SML2NJE3 DMT10380
         MVC   MSGLINK(8),HLDCMDLK SET RESPONSE LINKID                  DMT10390
         MSGX  611,AXSLINK         WRITE HELD MSG                       DMT10400
         NI    RDRCMD,255-RHLDIPGS TURN OFF COMMAND                     DMT10410
ALLCHK   EQU   *                                                        DMT10420
         CLC   $START($COMEND-$START),$ALLOFF ARE ALL BRANCHES NO-OPD   DMT10430
         BNE   $START              IF NO GO AROUND AGAIN                DMT10440
         L     R15,WAITREQ         SYSTEM WAIT PROCESSOR                DMT10450
         LA    R1,ECBLIST          GET ECBLIST ADDR                     DMT10460
         BALR  R14,R15             GO WAIT FOR POSTING                  DMT10470
         B     CMDECK              GO FIND WHO WOKE US UP               DMT10480
         DROP  R8                                                       DMT10490
         EJECT                                                          DMT10500
         SPACE 1                                                        DMT10510
$ALLOFF  NOP   $CONTROL            DUMMY COMMUTATOR                     DMT10520
         NOP   $TPGET              TO COMPARE FOR ALL NO-OPS            DMT10530
         NOP   $PCOM1              -                                    DMT10540
         NOP   $RCOM1              -                                    DMT10550
         NOP   $JCOM1              -                                    DMT10560
         NOP   $WCOM1              -                                    DMT10570
         NOP   CMDPROC             -                                    DMT10580
         NOP   MSGPROC             -                                    DMT10590
         NOP   $COMSUP             -                                    DMT10600
         NOP   $INTRUPT            -                                    DMT10610
         SPACE 1                   -                                    DMT10620
GOLOGIT  EQU   *                                                        DMT10630
         STM   R14,R1,KRSAV        SAVE REGISTERS                       DMT10640
         L     R14,CBUFFER         GET LAST TP BUFFER ADDR              DMT10650
         LA    R14,7(R14)          START OF DATA                        DMT10660
         LA    R1,R                INDICATE READ                        DMT10670
         BAL   R15,KLOGIT          GO LOG IT                            DMT10680
         LM    R14,R1,KRSAV        RESTORE REGISTERS                    DMT10690
         B     LOGITBK             AND CONTINUE                         DMT10700
         SPACE 3                                                        DMT10710
OPEN     EQU   X'F0'               GATE OPEN                            DMT10720
CLOSE    EQU   X'00'               GATE CLOSED                          DMT10730
         EJECT                                                          DMT10740
*.                                                                      DMT10750
*                                                                       DMT10760
* ENTRY NAME -                                                          DMT10770
*                                                                       DMT10780
*        $CRTN1                                                         DMT10790
*                                                                       DMT10800
* FUNCTION -                                                            DMT10810
*                                                                       DMT10820
*        THIS ROUTINE DEQUEUES TANKS FROM ITS TANK QUEUE AND            DMT10830
*        PERFORMS THE ACTION REQUESTED IN BY THE CONTROL RECORD         DMT10840
*        IN THE DEQUEUED TANK.                                          DMT10850
*                                                                       DMT10860
* CALLS TO OTHER ROUTINES -                                             DMT10870
*                                                                       DMT10880
*        NONE                                                           DMT10890
*                                                                       DMT10900
* OPERATION -                                                           DMT10910
*                                                                       DMT10920
*        1. TRY TO GET ANOTHER CONTROL TANK.                            DMT10930
*                                                                       DMT10940
*        2. IF ONE IS OBTAINED, EXAMINE THE SRCB TO DETERMINE ITS TYPE. DMT10950
*                                                                       DMT10960
*        3. BRANCH TO THE APPROPRIATE ROUTINE TO PROCESS                DMT10970
*           EACH TYPE OF CONTROL RECORD.                                DMT10980
*                                                                       DMT10990
*        4. FREE THE TANK AND EXIT THROUGH THE COMMUTATOR.              DMT11000
*                                                                       DMT11010
* RESPONSES -                                                           DMT11020
*                                                                       DMT11030
*        NONE                                                           DMT11040
*                                                                       DMT11050
* ERROR MESSAGES -                                                      DMT11060
*                                                                       DMT11070
*        DMTXJE902E  NON-SIGNON CARD READ ON LINK (LINKID)     HRC000DT DMT11080
*        DMTXJE903E  PASSWORD=(PASSWORD) ON LINK (LINKID) IS INVALID    DMT11090
*                                                                       DMT11100
*.                                                                      DMT11110
         EJECT                                                          DMT11120
*                                                                       DMT11130
*                                                                       DMT11140
$CRTN1   DS    0H                                                       DMT11150
*                                                                       DMT11160
$CONTROL DS    0H                  ENTRY POINT                          DMT11170
         LA    R13,$CTLTCT         GET CONTROL TCT                      DMT11180
         USING TCTDSECT,R13        *                                    DMT11190
         SPACE 1                                                        DMT11200
         CLC   TCTTANK,=F'0'       ARE WE EMPTY                         DMT11210
         BE    MNONE               YES                                  DMT11220
         L     R8,TCTTANK          GET FIRST BUFFER ADDRESS             DMT11230
         MVC   TCTTANK(4),0(R8)    REMOVE THIS ONE FROM CHAIN           DMT11240
         B     MPROCESS            BR IF GOTTEN                         DMT11250
         SPACE 1                                                        DMT11260
MNONE    EQU   *                                                        DMT11270
         MVI   $CCOMM1+1,CLOSE     NONE... CLOSE ENTRY                  DMT11280
         B     CCTRTN              AND EXIT                             DMT11290
         EJECT                                                          DMT11300
*---------------------------------------------------------------------* DMT11310
*                                                                     * DMT11320
*              PROCESS A CONTROL RECORD                               * DMT11330
*                                                                     * DMT11340
*---------------------------------------------------------------------* DMT11350
         SPACE 3                                                        DMT11360
MPROCESS DS    0H                  *                                    DMT11370
         LH    R5,TCTTNKLM         REDUCES COUNT IN TNKCT               DMT11380
         BCTR  R5,0                DOWN BY ONE                          DMT11390
         STH   R5,TCTTNKLM         AND REPLACE COUNT                    DMT11400
         OI    TCTSTAT,TCTACT      SIGNAL WE HAVE RECEIVED TANK         DMT11410
         MVI   $TPGETCM+1,OPEN     OPEN THE GATE TO TPGET ROUTINE       DMT11420
         DROP  R13                 DONE FOR NOW                         DMT11430
         USING TANKDSEC,R8         *                                    DMT11440
         IC    R6,TANKRCB          Get RCB                     HRC001DT DMT11450
         N     R6,=X'00000070'     Select relevant bits        HRC001DT DMT11460
         SRL   R6,4-2              Move to bottom, * by 4      HRC001DT DMT11470
         L     R6,MCONTTAB(R6)     Get routine address in tableHRC001DT DMT11480
         BR    R6                  ENTER ROUTINE                        DMT11490
         EJECT                                                          DMT11500
*---------------------------------------------------------------------* DMT11510
*                                                                     * DMT11520
*              SUBROUTINE TO FIND TCT CORRESPONDING TO SRCB FUNCTION  * DMT11530
*                R14=RETURN , CC NE 0 -R13 CONTAINS TCT,CC=0-NOT FOUND* DMT11540
*---------------------------------------------------------------------* DMT11550
         SPACE 3                                                        DMT11560
MTCTFIND DS    0H                  ENTRY POINT                          DMT11570
         LA    R13,$TCT1           FIRST TCT                            DMT11580
         USING TCTDSECT,R13        ADDRESSABILITY                       DMT11590
MNEXTTCT DS    0H                  *                                    DMT11600
         CLC   TCTRCBR,TANKSRCB    IS THIS CORRECT TCT                  DMT11610
         BE    MTCTOK              BR IF YES                            DMT11620
         ICM   R13,B'1111',TCTNEXT NO..TO NEXT AND CHECK FOR LAST       DMT11630
         BNZ   MNEXTTCT            BR IF MORE                           DMT11640
         BR    R14                 RETURN WITH COND. CODE = 0           DMT11650
         SPACE 1                                                        DMT11660
MTCTFNDT DS    0H                  ENTRY POINT                          DMT11670
         LA    R13,$TCT1           FIRST TCT                            DMT11680
         USING TCTDSECT,R13        ADDRESSABILITY                       DMT11690
MNXTTCTT DS    0H                  *                                    DMT11700
         CLC   TCTRCBT,TANKSRCB    IS THIS CORRECT TCT                  DMT11710
         BE    MTCTOK              BR IF YES                            DMT11720
         ICM   R13,B'1111',TCTNEXT NO..TO NEXT AND CHECK FOR LAST       DMT11730
         BNZ   MNXTTCTT            BR IF MORE                           DMT11740
         BR    R14                 RETURN WITH COND. CODE = 0           DMT11750
         SPACE 1                                                        DMT11760
MTCTOK   EQU   *                                                        DMT11770
         LTR   R14,R14             SET COND. CODE NON-ZERO              DMT11780
         BR    R14                 AND RETURN                           DMT11790
         EJECT                                                          DMT11800
         SPACE 5                                                        DMT11810
*---------------------------------------------------------------------* DMT11820
*                                                                     * DMT11830
*              SUBROUTINE TO $TPPUT AN ANSWERING CTL RECORD           * DMT11840
*                   R8 = TANKADDR                                     * DMT11850
*                                                                     * DMT11860
*---------------------------------------------------------------------* DMT11870
         SPACE 3                                                        DMT11880
MPUT     DS    0H                  ENTRY POINT                          DMT11890
         BAL   R14,$TPPUT          GO PUT RECORD                        DMT11900
         BNZ   MEXIT               EXIT IF ACCEPTED                     DMT11910
         MVC   $CCOMM1+2(2),MREPUTA SET COMUTATOR RE-ENTRY              DMT11920
         ST    R8,MTANK            SAVE TANK ADDR                       DMT11930
         B     CCTRTN              EXIT TO COMUTATOR                    DMT11940
         SPACE 1                                                        DMT11950
MREPUT   DS    0H                  RETRY PUTTING RECORD                 DMT11960
         L     R8,MTANK            RESTORE TANK ADDR                    DMT11970
         BAL   R14,$TPREPUT        TRY IT                               DMT11980
         BZ    $CCOMM1+4           CYCLE IF STILL NOT ACCEPTED          DMT11990
         SPACE 1                                                        DMT12000
MEXIT    DS    0H                  ENTRY AT END OF PROCESSING           DMT12010
         MVC   0(4,R8),$TANKPOL    GET FIRST FREE OFF QUEUE             DMT12020
         ST    R8,$TANKPOL         MAKE THIS ONE THE FIRST              DMT12030
         MVI   $TPGETCM+1,OPEN     OPEN TPGET GATE                      DMT12040
         MVC   $CCOMM1+2(2),MCONTROL RESET COMUTATOR                    DMT12050
         B     $CONTROL            AND TRY NEXT TANK                    DMT12060
MREPUTA  DC    S(MREPUT)           COMMUTATOR ADJUSTMENT ADDR           DMT12070
MCONTROL DC    S($CONTROL)         COMMUTATOR ADJUSTMENT ADDR           DMT12080
MCONTTAB DS    0F                  CONTROL TYPE BRANCH TABLE            DMT12090
         DC    A(MC0)              000  Reserved               SML2NJE4 DMT12100
         DC    A(MC1)              001  START FUNCTION REQUEST          DMT12110
         DC    A(MC2)              010  START FUNCTION PERMISSION       DMT12120
         DC    A(MC3)              011  RESERVED                        DMT12130
         DC    A(MC4)              100  RESERVED                        DMT12140
         DC    A(MC5)              101  RESERVED                        DMT12150
         DC    A(MC6)              110  RESERVED                        DMT12160
         DC    A(MC7)              111  GENERAL CONTROL TYPE            DMT12170
         EJECT                                                          DMT12180
         SPACE 3                                                        DMT12190
*                                                                       DMT12200
* MC0          CONTROL RECORD , TYPE = 000 (RESERVED)                   DMT12210
*                                                                       DMT12220
         SPACE 3                                                        DMT12230
*                                                                       DMT12240
*              RESERVED FOR FUTURE USE                                  DMT12250
*                                                                       DMT12260
MC0      EQU   MEXIT               TO DEFINE SYMBOL                     DMT12270
         SPACE 3                                                        DMT12280
*                                                                       DMT12290
* MC1          CONTROL RECORD , TYPE = 001(REQUEST TO START FUNCTION)   DMT12300
*                                                                       DMT12310
         SPACE 3                                                        DMT12320
MC1      DS    0H                  *                                    DMT12330
*                                                                       DMT12340
         BAL   R14,MTCTFIND        GO FIND TCT                          DMT12350
         BZ    MEXIT               IGNORE REQUEST IF NOT FOUND          DMT12360
         TM    XJESYS,SGNONREC     Has link signed on?         HRC000DT DMT12370
         BNO   MEXIT               NO...NOTHING TILL THEN               DMT12380
         SPACE 1                                                        DMT12390
MTCTSET  DS    0H                  CORRECT TCT FOUND                    DMT12400
         TM    TCTSTAT,TCTOPEN     CAN DEVICE BE STARTED                DMT12410
         NI    TCTSTAT,255-TCTOPEN SHOW USE                             DMT12420
         OC    $FCSOUT,TCTFCS      ALLOW BUFFERS                        DMT12430
*        Initialise variables to process expected incoming job SML2NJE4 DMT12440
*        This both to avoid revealing leftovers from previous  SML2NJE4 DMT12450
*        files and also to avoid ending up with random garbage SML2NJE4 DMT12460
*        if relevant fields are not supplied in NJE headers.   SML2NJE4 DMT12470
         MVI   PNSEGTYP,X'C0'      Expect job header next      SML2NJE4 DMT12480
         MVI   PNSEGNUM,0          Expect segment zero next    SML2NJE4 DMT12490
         MVC   PNJEBPTR,APNJEHDR   Point to start of NJE bufferSML2NJE4 DMT12500
         L     R3,APDEVTAG         Get address of SYSOUT tag   SML2NJE4 DMT12510
         LA    R0,XJE3JEHD         Code for routine DEFNJEHD      *XJE  DMT12520
         L     R15,=A(DMTXJE3)     -> NJE functions csect         *XJE  DMT12530
         BALR  R14,R15             Fill in default NJE headers SML2NJE4 DMT12540
         USING TAG,R3                                          SML2NJE4 DMT12550
         MVC   PNRECLEN,TAGRECLN   Assume punch record length  SML2NJE4 DMT12560
         DROP  R3                  Finished with TAG for now   SML2NJE4 DMT12570
         MVI   TANKRCB,X'A0'       Change request to permissionHRC001DT DMT12580
         B     MPUT                AND SEND IT                          DMT12590
         SPACE 3                                                        DMT12600
*                                                                       DMT12610
* MC2          CONTROL RECORD , TYPE = 010(PERMISSION TO START FCN)     DMT12620
*                                                                       DMT12630
         SPACE 3                                                        DMT12640
MC2      DS    0H                  ENTRY POINT                          DMT12650
         BAL   R14,MTCTFNDT        GO LOOK-UP TCT                       DMT12660
         BZ    MEXIT               IGNORE IF NOT FOUND                  DMT12670
         L     R14,TCTCOM          GET COMUTATOR ENTRY                  DMT12680
         MVI   1(R14),OPEN         OPEN IT                              DMT12690
         NI    TCTSTAT,255-TCTOPEN SHOW OPEN                            DMT12700
         B     MEXIT               AND EXIT                             DMT12710
         EJECT                                                          DMT12720
*                                                                       DMT12730
* MC3          CONTROL RECORD , TYPE = 011 (RESERVED)                   DMT12740
         SPACE 3                                                        DMT12750
MC3      EQU   MEXIT               NOT YET DEFINED                      DMT12760
         SPACE 3                                                        DMT12770
*                                                                       DMT12780
* MC4          Control record , typ = 100 (ACK file received)  SML2NJE4 DMT12790
*                                                              SML2NJE4 DMT12800
MC4      DS    0H                  Entry point                 SML2NJE4 DMT12810
         BAL   R14,MTCTFNDT        Go look up TCT              SML2NJE4 DMT12820
         BZ    MEXIT               Ignore if not found         SML2NJE4 DMT12830
         TM    RSW1,RWAITACK       Are we waiting for an ACK?  SML2NJE4 DMT12840
         BZ    MEXIT               No. Ignore it.              SML2NJE4 DMT12850
         NI    RSW1,255-RWAITACK   Reset waiting for ACK flag  SML2NJE4 DMT12860
         OI    $RCOMM1+1,OPEN      Open RDR commutator gate    SML2NJE4 DMT12870
         B     MEXIT               And exit                    SML2NJE4 DMT12880
         SPACE 3                                                        DMT12890
*                                                                       DMT12900
* MC5          CONTROL RECORD , TYPE = 101 (RESERVED)                   DMT12910
*                                                                       DMT12920
         SPACE 3                                                        DMT12930
MC5      EQU   MEXIT               TO DEFINE SYMBOL                     DMT12940
*                                  FUNCTION IS NOT YET SUPPORTED        DMT12950
         SPACE 3                                                        DMT12960
*                                                                       DMT12970
* MC6          CONTROL RECORD , TYPE = 110(RESERVED)                    DMT12980
*                                                                       DMT12990
         SPACE 3                                                        DMT13000
*                                                                       DMT13010
*              THIS CONTROL TYPE IS CURRENTLY UNDEFINED BUT IS          DMT13020
*              RESERVED FOR FUTURE USE.                                 DMT13030
*                                                                       DMT13040
MC6      EQU   MEXIT               TO DEFINE SYMBOL                     DMT13050
         EJECT                                                          DMT13060
*                                                                       DMT13070
* MC7          CONTROL RECORD , TYPE = 111 (GENERALIZED CONTROL)        DMT13080
*                                          (TYPE INDICATED IN SRCB)     DMT13090
*                                                                       DMT13100
         SPACE 3                                                        DMT13110
MC7      EQU   *                   ENTRY POINT                          DMT13120
         CLI   TANKSRCB,C'I'       Initial signon record?      SML2NJE4 DMT13130
         BE    MC7INIT                                         SML2NJE4 DMT13140
         CLI   TANKSRCB,C'J'       Response signon record?     SML2NJE4 DMT13150
         BNE   MEXIT               No. Ignore it.              SML2NJE4 DMT13160
         SPACE 1                                               SML2NJE4 DMT13170
MC7RESP  EQU   *                                               SML2NJE4 DMT13180
         TM    XJESYS,SECONDRY     Is remote end secondary?    SML2NJE4 DMT13190
         BNO   MC7ERR1             Response must be from sec   SML2NJE4 DMT13200
         BAL   R14,MC7VER          Verify signon parameters    SML2NJE4 DMT13210
         XR    R1,R1               Clear R1 for ICM            SML2NJE4 DMT13220
         ICM   R1,B'0011',TANKDATA+16 Get secondarys buf size  SML2NJE4 DMT13230
         CL    R1,TPBUFSIZ         Compare with our buffr size SML2NJE4 DMT13240
         BNL   MC7SGNON            Not smaller - do nothing    SML2NJE4 DMT13250
         ST    R1,TPBUFSIZ         Smaller - use theirs        SML2NJE4 DMT13260
         STH   R1,CCWC+6           Also store in read CCW      SML2NJE4 DMT13270
         STH   R1,RDCOUNT          And in read count           SML2NJE4 DMT13280
MC7SGNON EQU   *                                               SML2NJE4 DMT13290
         L     R1,TPBUFSIZ         Get negotiated buffer size  SML2NJE4 DMT13300
         USING LINKTABL,R6         Link table addressability   HRC031DT DMT13310
         L     R6,XJELINK          Get linktable address for.. HRC031DT DMT13320
         STH   R1,LNEGO            Set negotiated buffer size     *XJE
         NI    LFLAG,255-LACTIVE   Link no longer active          *XJE  DMT13330
         OI    LFLAG,LCONNECT      Mark link as connected      HRC031DT DMT13330
         DROP  R6                  Finished with link table    HRC031DT DMT13340
         CVD   R1,AXSCVD           Convert buffer size to BCD  SML2NJE4 DMT13350
         MVC   AXSRECS,=X'0020202020202020' Specify edit word  SML2NJE4 DMT13360
         ED    AXSRECS,AXSCVD+4    Convert to character        SML2NJE4 DMT13370
         LM    R2,R3,AXSRECS       Load result into double reg SML2NJE4 DMT13380
MC7BUFLP EQU   *                                               SML2NJE4 DMT13390
         SLDA  R2,8                Shift out one character     SML2NJE4 DMT13400
         BNO   MC7BUFLP            Stop when we hit a digit    SML2NJE4 DMT13410
         STM   R2,R3,AXSRECS       Store left justified result SML2NJE4 DMT13420
         OI    AXSRECS,X'80'       Restore lost sign bit       SML2NJE4 DMT13430
         MSGX  905,(AXSLINK,AXSRECS) Indicate signon complete  SML2NJE4 DMT13440
         OI    XJESYS,SGNONREC     Indicate signon accepted    SML2NJE4 DMT13450
         OI    $RCOMM1+1,OPEN      Open RDR commutator gate    SML2NJE4 DMT13460
         B     MEXIT               Return and free TP buffer   SML2NJE4 DMT13470
         SPACE 1                                               SML2NJE4 DMT13480
MC7INIT  EQU   *                                               SML2NJE4 DMT13490
         TM    XJESYS,PRIMARY      Is the remote end primary?  SML2NJE4 DMT13500
         BNO   MC7ERR1             Init signon not from primarySML2NJE4 DMT13510
         BAL   R14,MC7VER          Verify signon parameters    SML2NJE4 DMT13520
         XR    R1,R1               Clear R1 for ICM            SML2NJE4 DMT13530
         ICM   R1,B'0011',TANKDATA+16 Get primarys buffer size SML2NJE4 DMT13540
         CL    R1,TPBUFSIZ         Compare with our buffr size SML2NJE4 DMT13550
         BNL   MC7I1               Not smaller - leave alone   SML2NJE4 DMT13560
         ST    R1,TPBUFSIZ         Smaller - use theirs        SML2NJE4 DMT13570
         STH   R1,CCWC+6           Also store in read CCW      SML2NJE4 DMT13580
         STH   R1,RDCOUNT          And in read count           SML2NJE4 DMT13590
         STH   R1,NCCIBFSZ         And in signon resp record   SML2NJE4 DMT13600
MC7I1    EQU   *                                               SML2NJE4 DMT13610
* Set response signon fields that differ from initial signon   SML2NJE4 DMT13620
SIGNONJ  EQU   *                                                  *XJE
         MVI   NCCSRCB,C'J'        Signon response record      SML2NJE4 DMT13630
         MVC   NCCIEVNT,=X'FFFFFFFF' Connection event sequence SML2NJE4 DMT13640
* Now send the response signon record. I copied this from the  SML2NJE4 DMT13650
* code that sends the initial signon record. I don't really    SML2NJE4 DMT13660
* follow what is supposed to happen if there are no TP buffers SML2NJE4 DMT13670
* available ...                                                SML2NJE4 DMT13680
         SPACE 1                                               SML2NJE4 DMT13690
         USING BUFDSECT,R13        *                           SML2NJE4 DMT13700
         CLC   $BUFPOOL,=F'0'      Is free TPbuff queue empty? SML2NJE4 DMT13710
         BE    JBUF1               Yes                         SML2NJE4 DMT13720
         L     R13,$BUFPOOL        Get first buffer address    SML2NJE4 DMT13730
         MVC   $BUFPOOL(4),0(R13)  Make second buffer first    SML2NJE4 DMT13740
JBUF1    EQU   *                                               SML2NJE4 DMT13750
         MVC   BUFCOUNT(ICTLE-ICTLS),ICTLS Setup control reply SML2NJE4 DMT13760
         LA    R6,$OUTBUF          Get start of outgoing queue    *XJE  DMT13770
JBUF2    EQU   *                                               SML2NJE4 DMT13780
         CLC   0(4,R6),=F'0'       Is it the last in chain?    SML2NJE4 DMT13790
         BE    JBUF3               Yes.  Add ours on here.     SML2NJE4 DMT13800
         L     R6,0(0,R6)          Get the next buffer         SML2NJE4 DMT13810
         B     JBUF2               Try again                   SML2NJE4 DMT13820
         SPACE 1                                               SML2NJE4 DMT13830
JBUF3    EQU   *                                               SML2NJE4 DMT13840
         ST    R13,0(0,R6)         Chain our buffer to it      SML2NJE4 DMT13850
         MVC   0(4,R13),=F'0'      Mark it as last buffer      SML2NJE4 DMT13860
*                                                              SML2NJE4 DMT13870
         B     MC7SGNON            Go complete signon          SML2NJE4 DMT13880
         SPACE 1                                               SML2NJE4 DMT13890
*                                                              SML2NJE4 DMT13900
*        Verify initial/response signon parameters are correct SML2NJE4 DMT13910
*                                                              SML2NJE4 DMT13920
MC7VER   EQU   *                                               SML2NJE4 DMT13930
         CLC   TANKDATA+NCCINODE-NCCIDL(8),AXSLINK Right link? SML2NJE4 DMT13940
         BNE   MC7ERR1             Wrong link                  SML2NJE4 DMT13950
         CLI   PASSWORD,C' '       Was a password specified?   SML2NJE4 DMT13960
         BE    MC7VRET             No. No need to check it so. SML2NJE4 DMT13970
         CLC   TANKDATA+NCCILPAS-NCCIDL(8),PASSWORD Line pw    SML2NJE4 DMT13980
         BNE   MC7ERR2             Incorrect password          SML2NJE4 DMT13990
MC7VRET  BR    R14                                             SML2NJE4 DMT14000
         SPACE 1                                               SML2NJE4 DMT14010
MC7ERR1  MSGX  902,AXSLINK         Not ideal - will do for now SML2NJE4 DMT14020
         B     EOJ                                             SML2NJE4 DMT14030
         SPACE 1                                               SML2NJE4 DMT14040
MC7ERR2  MSGX  903,AXSLINK         Password invalid            SML2NJE4 DMT14050
         B     EOJ                                             SML2NJE4 DMT14060
         SPACE 1                                               SML2NJE4 DMT14070
*                                                                       DMT14080
*              CURRENTLY NO OTHER FUNCTIONS ARE IMPLEMENTED FOR THIS    DMT14090
*              CONTROL FUNCTION. THE TYPE OF CONTROL RECORD, SUCH       DMT14100
*              AS ACCOUNTING,SIGN-ON,INITIALIZATION,ETC, IS             DMT14110
*              INDICATED IN THE SRCB.                                   DMT14120
*              THE SRCB IDENTIFICATION CHARACTERS 'A' THRU 'R'          DMT14130
*              AND '0' THRU '9' ARE RESERVED FOR FUTURE RSCS            DMT14140
*              DEVELOPMENT. ALL OTHER EBCDIC CHARACTERS , WHICH         DMT14150
*              ARE TRANSMISSION COMPATIBLE ARE AVAILABLE TO THE         DMT14160
*              USER TO ADD ADDITIONAL CONTROL FUNCTIONS.                DMT14170
*                                                                       DMT14180
         SPACE 3                                                        DMT14190
         DROP  R8,R13                                                   DMT14200
         EJECT                                                          DMT14210
*.                                                                      DMT14220
*                                                                       DMT14230
* ENTRY NAME -                                                          DMT14240
*                                                                       DMT14250
*        $PRTN1                                                         DMT14260
*                                                                       DMT14270
* FUNCTION -                                                            DMT14280
*                                                                       DMT14290
*        THIS ROUTINE DEQUEUES TANKS FROM ITS TANK QUEUE, OBTAINS       DMT14300
*        A NEW OUTPUT SPOOL DEVICE IF NEEDED FROM DMTAXS, AND           DMT14310
*        OUTPUTS THE TANK TO A VIRTUAL PRINTER OR PUNCH.       SML2NJE4 DMT14320
*                                                                       DMT14330
* CALLS TO OTHER ROUTINES -                                             DMT14340
*                                                                       DMT14350
*        DMTIOMRQ - TO INITIATE AN I/O OPERATION                        DMT14360
*                                                                       DMT14370
* OPERATION -                                                           DMT14380
*                                                                       DMT14390
*        1. OBTAIN A TANK FROM $GETTNK                                  DMT14400
*                                                                       DMT14410
*        2. IF OBTAINED CHECK TO SEE IF OUTPUT FILE IS OPENED,          DMT14420
*           IF NOT OBTAIN A OUTPUT DEVICE BY A CALL TO AXS.             DMT14430
*                                                                       DMT14440
*        3. CONTRUCT THE CARRIAGE CONTROL FROM THE INFORMATION          DMT14450
*           CONTAINED IN THE SRCB.                                      DMT14460
*                                                                       DMT14470
*        4. WRITE THE RECORD TO THE VM/370 SPOOL FILE SYSTEM.           DMT14480
*                                                                       DMT14490
*        5. WHEN EOF IS OBTAINED CLOSE THE FILE VIA ANOTHER CALL        DMT14500
*           TO AXS.                                                     DMT14510
*                                                                       DMT14520
*        6. EXIT TO COMMUTATOR                                          DMT14530
*                                                                       DMT14540
* RESPONSES -                                                           DMT14550
*                                                                       DMT14560
*        DMTXJE144I  RECEIVING: FILE FROM 'LOCID1' ('USERID1') HRC000DT DMT14570
*                    FOR 'LOCID2' ('USERID2')                  HRC000DT DMT14580
*        DMTXJE145I  RECEIVED: FILE FROM 'LOCID1' ('USERID1')  HRC000DT DMT14590
*                    FOR 'LOCID2' ('USERID2')                  HRC000DT DMT14600
*                                                                       DMT14610
* ERROR MESSAGES -                                                      DMT14620
*                                                                       DMT14630
*        NONE                                                           DMT14640
*                                                                       DMT14650
*.                                                                      DMT14660
         SPACE 1                                                        DMT14670
         USING TANKDSEC,R8         GET TANK ADDRESSABILITY              DMT14680
$PRTN1   DS    0H                                                       DMT14690
PNEXT    EQU   *                   BASIC LOOP                           DMT14700
         BAL   R14,$GETTNK         WAIT FOR THE NEXT TANK               DMT14710
         TM    XJESYS,SGNONREC     Is link signed on?          SML2NJE4 DMT14720
         BZ    PFREE               No. Ignore until signed on. SML2NJE4 DMT14730
         TM    PSW1,DISCARD        Is job being discarded?     SML2NJE4 DMT14740
         BO    PNDISCRD            Discard tanks until job end SML2NJE4 DMT14750
         L     R3,APDEVTAG         Get address of RSCS "TAG"   SML2NJE4 DMT14760
         LA    R0,1                Error code                  SML2NJE4 DMT14770
         TM    TANKSRCB,B'10000000' Is SRCB plausable looking? SML2NJE4 DMT14780
*XJE     BZ    MSG939              Declare protocol error      SML2NJE4 DMT14790
         TM    TANKSRCB,B'01000011' Is this a data record?     SML2NJE4 DMT14800
         BZ    PDATAREC            Looks like a data record    SML2NJE4 DMT14810
         CLC   TANKSRCB,PNSEGTYP   Is this the expected header SML2NJE4 DMT14820
         BE    PNEXPECT            This is the expected header SML2NJE4 DMT14830
         LA    R0,2                Error code                  SML2NJE4 DMT14840
         CLI   TANKSRCB,X'D0'      Is it a trailer record...   SML2NJE4 DMT14850
         BNE   MSG939              (Not a trailer record)      SML2NJE4 DMT14860
         LA    R0,3                Error code                  SML2NJE4 DMT14870
         CLI   PNSEGTYP,X'02'      ... after some data?        SML2NJE4 DMT14880
         BNE   MSG939              Trailer not expected here   SML2NJE4 DMT14890
PNEXPECT EQU   *                                               SML2NJE4 DMT14900
         LA    R0,4                Error code                  SML2NJE4 DMT14910
         CLC   TANKCNT,=H'4'       Can tank contain a segment? SML2NJE4 DMT14920
         BNH   MSG939              Declare protocol error      SML2NJE4 DMT14930
         IC    R1,TANKDATA+NJEPSEQ-NJEPDSEC Get segment number SML2NJE4 DMT14940
         N     R1,=X'0000007F'     Select segment number only  SML2NJE4 DMT14950
         XR    R2,R2               Clear R2 for IC             SML2NJE4 DMT14960
         IC    R2,PNSEGNUM         Get expected segment number SML2NJE4 DMT14970
         LA    R0,5                Error code                  SML2NJE4 DMT14980
         CR    R1,R2               Is this the right segment?  SML2NJE4 DMT14990
         BNE   MSG939              Declare protocol error      SML2NJE4 DMT15000
         LA    R2,1(,R2)           Increment segment number    SML2NJE4 DMT15010
         STC   R2,PNSEGNUM         Expect this segment next    SML2NJE4 DMT15020
         ICM   R1,B'0011',TANKDATA+NJEPLEN-NJEPDSEC Segment ln SML2NJE4 DMT15030
         LA    R0,6                Error code                  SML2NJE4 DMT15040
         CH    R1,TANKCNT          Segment len == tank count?  SML2NJE4 DMT15050
         BNE   MSG939              Declare protocol error      SML2NJE4 DMT15060
         SH    R1,=AL2(NJEPSIZE)   Reduce by seg. prefix len.  SML2NJE4 DMT15070
         L     R2,PNJEBPTR         Get buffer pointer          SML2NJE4 DMT15080
         LR    R0,R2               Make temporary copy         SML2NJE4 DMT15090
         AR    R0,R1               Add length of segment       SML2NJE4 DMT15100
         CL    R0,APNJEHND         Compare to end of buffer    SML2NJE4 DMT15110
         BNL   MSG938              Segment won't fit in buffer SML2NJE4 DMT15120
         BCTR  R1,0                Reduce by one for EX        SML2NJE4 DMT15130
         EX    R1,COPYSEGM         Copy segment to NJEH buffer SML2NJE4 DMT15140
         LA    R2,1(R1,R2)         +1. Update buffer pointer.  SML2NJE4 DMT15150
         ST    R2,PNJEBPTR         Save buffer pointer         SML2NJE4 DMT15160
         TM    TANKDATA+NJEPSEQ-NJEPDSEC,X'80' Last segment?   SML2NJE4 DMT15170
         BO    PFREE               Not last.  Get next segment SML2NJE4 DMT15180
*                                                              SML2NJE4 DMT15190
         MVI   PNSEGNUM,X'00'      Expect segment zero next    SML2NJE4 DMT15200
         LA    R4,NJEPSIZE(,R2)    Leave room for segment hdr  SML2NJE4 DMT15210
         ST    R4,PNJEBPTR         Save buffer ptr for nxt hdr SML2NJE4 DMT15220
         USING TAG,R3              Use R3 to address RSCS tag  SML2NJE4 DMT15230
*                                                              SML2NJE4 DMT15240
         CLI   TANKSRCB,X'C0'      Is this a job header?       SML2NJE4 DMT15250
         BNE   PNOTJHDR            Not a job header            SML2NJE4 DMT15260
*                                                              SML2NJE4 DMT15270
         MVI   PNSEGTYP,X'E0'      Expect dataset header next  SML2NJE4 DMT15280
         ST    R4,APNJEDTA         Save address of data set hdrSML2NJE4 DMT15290
         L     R4,APNJEHDR         Get addr. of job hdr prefix SML2NJE4 DMT15300
         USING NJEPDSEC,R4         Use R4 for NJEP* locations  SML2NJE4 DMT15310
         SR    R2,R4               Get length of job header    SML2NJE4 DMT15320
         STH   R2,NJEPLEN          Save job hdr len in prefix  SML2NJE4 DMT15330
         DROP  R4                  Finished with seg. prefix   SML2NJE4 DMT15340
         LA    R4,NJEPSIZE(,R4)    Get address of 1st section  SML2NJE4 DMT15350
         USING NJHGDSEC,R4         Assume general section      SML2NJE4 DMT15360
PHLOOP   EQU   *                                               SML2NJE4 DMT15370
         LTR   R2,R2               Reached end of job header?  SML2NJE4 DMT15380
         BE    PFREE               Finished with job header    SML2NJE4 DMT15390
         LA    R0,7                Error code                  SML2NJE4 DMT15400
         CH    R2,=H'4'            Ensure 4 bytes or more left SML2NJE4 DMT15410
         BNH   MSG939              Declare protocol error      SML2NJE4 DMT15420
         XR    R1,R1               Clear R1 for ICM            SML2NJE4 DMT15430
         ICM   R1,B'0011',NJHGLEN  Get section length          SML2NJE4 DMT15440
         LA    R0,8                Error code                  SML2NJE4 DMT15450
         CH    R1,=H'4'            Minimum section length is 5 SML2NJE4 DMT15460
         BNH   MSG939              Declare protocol error      SML2NJE4 DMT15470
         LA    R0,9                Error code                  SML2NJE4 DMT15480
         SR    R2,R1               Subtract from header len    SML2NJE4 DMT15490
         BM    MSG939              Gone past end of job header SML2NJE4 DMT15500
         XR    R0,R0               Clear R0 for ICM            SML2NJE4 DMT15510
         ICM   R0,B'0011',NJHGTYPE Get section type & modifier SML2NJE4 DMT15520
         BNZ   PHNOTGEN            Not the hdr general section SML2NJE4 DMT15530
         CH    R1,=AL2(NJHGFORM-NJHGDSEC) Is header too short? SML2NJE4 DMT15540
         BL    PHGENFIN            Not much use - skip it.     SML2NJE4 DMT15550
*        Copy any relevant details present in general section  SML2NJE4 DMT15560
         MVC   TAGID,NJHGJID       Job id / spool file number  SML2NJE4 DMT15570
         MVC   TAGINTOD,NJHGETS    Get file date / time        SML2NJE4 DMT15580
         MVC   TAGINLOC,NJHGORGN   Get origin node             SML2NJE4 DMT15590
         MVC   TAGINVM,NJHGORGR    Get origin userid           SML2NJE4 DMT15600
         MVC   TAGTOLOC,NJHGPUNN   Get PUN destination node    SML2NJE4 DMT15610
         MVC   PCTTOVM,NJHGPUNR    Get PUN destination userid  SML2NJE4 DMT15620
         DROP  R4                  Finished with general sect. SML2NJE4 DMT15630
PHGENFIN EQU   *                                               SML2NJE4 DMT15640
PHNOTGEN EQU   *                                               SML2NJE4 DMT15650
         AR    R4,R1               Move on to next hdr section SML2NJE4 DMT15660
         B     PHLOOP              Go around again             SML2NJE4 DMT15670
*                                                              SML2NJE4 DMT15680
PNOTJHDR EQU   *                                               SML2NJE4 DMT15690
         CLI   TANKSRCB,X'E0'      Is this a dataset header?   SML2NJE4 DMT15700
         BNE   PNOTDHDR            Not a dataset header        SML2NJE4 DMT15710
*                                                              SML2NJE4 DMT15720
         MVI   PNSEGTYP,X'01'      Expect actual data next     SML2NJE4 DMT15730
         ST    R4,APNJETRL         Save address of job trailer SML2NJE4 DMT15740
         L     R4,APNJEDTA         Get addr. of ds hdr prefix  SML2NJE4 DMT15750
         USING NJEPDSEC,R4         Use R4 for NJEP* locations  SML2NJE4 DMT15760
         SR    R2,R4               Get length of ds header     SML2NJE4 DMT15770
         STH   R2,NJEPLEN          Save ds hdr len in prefix   SML2NJE4 DMT15780
         DROP  R4                  Finished with ds hdr prefix SML2NJE4 DMT15790
         LA    R4,NJEPSIZE(,R4)    Get address of 1st section  SML2NJE4 DMT15800
         USING NDHGDSEC,R4         Assume general section      SML2NJE4 DMT15810
PDLOOP   EQU   *                                               SML2NJE4 DMT15820
         LTR   R2,R2               Reached end of ds header?   SML2NJE4 DMT15830
         BZ    PFREE               Finished with ds header     SML2NJE4 DMT15840
         LA    R0,10               Error code                  SML2NJE4 DMT15850
         CH    R2,=H'4'            Ensure 4 bytes or more left SML2NJE4 DMT15860
         BNH   MSG939              Declare protocol error      SML2NJE4 DMT15870
         XR    R1,R1               Clear R1 for ICM            SML2NJE4 DMT15880
         ICM   R1,B'0011',NDHGLEN  Get section length          SML2NJE4 DMT15890
         LA    R0,11               Error code                  SML2NJE4 DMT15900
         CH    R1,=H'4'            Minimum section length is 4 SML2NJE4 DMT15910
         BNH   MSG939              Declare protocol error      SML2NJE4 DMT15920
         LA    R0,12               Error code                  SML2NJE4 DMT15930
         SR    R2,R1               Subtract from header len    SML2NJE4 DMT15940
         BM    MSG939              Gone past end of ds header  SML2NJE4 DMT15950
         XR    R0,R0               Clear R0 for ICM            SML2NJE4 DMT15960
         ICM   R0,B'0011',NDHGTYPE Get section type & modifier SML2NJE4 DMT15970
         BNZ   PDNOTGEN            Not the ds general section  SML2NJE4 DMT15980
         CH    R1,=AL2(NDHGFCBI-NDHGDSEC) Is header too short? SML2NJE4 DMT15990
         BL    PDGENFIN            Not much use - ignore it.   SML2NJE4 DMT16000
*        Copy any relevant details present in general section  SML2NJE4 DMT16010
         MVC   TAGNAME(8),NDHGPROC 1st 8 characters of filenameSML2NJE4 DMT16020
         MVC   TAGNAME+8(4),BLANK  Blank last four characters  SML2NJE4 DMT16030
         MVC   TAGTYPE(8),NDHGSTEP 1st 8 characters of filetypeSML2NJE4 DMT16040
         MVC   TAGTYPE+8(4),BLANK  Blank last four characters  SML2NJE4 DMT16050
         MVC   TAGTOLOC,NDHGNODE   Destination node            SML2NJE4 DMT16060
         MVC   PCTTOVM,NDHGRMT     Destination userid          SML2NJE4 DMT16070
         MVC   TAGCLASS,NDHGCLAS   Spool file class            SML2NJE4 DMT16080
         MVC   TAGRECLN,NDHGLREC   Record length               SML2NJE4 DMT16090
         MVI   TAGCOPY,X'00'       Top byte of copy count      SML2NJE4 DMT16100
         MVC   TAGCOPY+1,NDHGDSCT  Dataset count (copy count)  SML2NJE4 DMT16110
PDGENFIN EQU   *                                               SML2NJE4 DMT16120
         DROP  R4                  Finished with general sect. SML2NJE4 DMT16130
         AR    R4,R1               Move on to next ds section  SML2NJE4 DMT16140
         B     PDLOOP              Go around again             SML2NJE4 DMT16150
*                                                                       DMT16160
PDNOTGEN EQU   *                                               SML2NJE4 DMT16170
         C     R0,=X'00008700'     Is this an RSCS section?    SML2NJE4 DMT16180
         BNE   PDNOTRSC            Not RSCS section            SML2NJE4 DMT16190
*                                                              SML2NJE4 DMT16200
         USING NDHVDSEC,R4         Use to address RSCS section SML2NJE4 DMT16210
         CH    R1,=AL2(NDHVVRSN-NDHVLEN) Is header too short?  SML2NJE4 DMT16220
         BL    PDRSCFIN            Not much use - skip over it SML2NJE4 DMT16230
*        Copy any relevant details present in RSCS section     SML2NJE4 DMT16240
*        Override anything already copied from general section SML2NJE4 DMT16250
         MVC   TAGCLASS,NDHVCLAS   Spool file class            SML2NJE4 DMT16260
         MVC   TAGINDEV,NDHVIDEV   CP device type code         SML2NJE4 DMT16270
         MVC   TAGDIST,NDHVDIST    Distribution code           SML2NJE4 DMT16280
         MVC   TAGNAME,NDHVFNAM    Spool filename              SML2NJE4 DMT16290
         MVC   TAGTYPE,NDHVFTYP    Spool filetype              SML2NJE4 DMT16300
         MVC   TAGPRIOR,NDHVPRIO   Priority                    SML2NJE4 DMT16310
         DROP  R4                  Finished with RSCS section  SML2NJE4 DMT16320
PDRSCFIN EQU   *                                               SML2NJE4 DMT16330
PDNOTRSC EQU   *                                               SML2NJE4 DMT16340
         AR    R4,R1               Move on to next section     SML2NJE4 DMT16350
         B     PDLOOP              Go around again             SML2NJE4 DMT16360
*                                                              SML2NJE4 DMT16370
PNOTDHDR EQU   *                                               SML2NJE4 DMT16380
         LA    R0,13               Error code                  SML2NJE4 DMT16390
         CLI   TANKSRCB,X'D0'      Is this a job trailer?      SML2NJE4 DMT16400
         BNE   MSG939              Declare protocol error      SML2NJE4 DMT16410
*                                                              SML2NJE4 DMT16420
         MVI   PNSEGTYP,X'00'      Expect EOF next             SML2NJE4 DMT16430
         L     R4,APNJETRL         Get addr. of job trl prefix SML2NJE4 DMT16440
         USING NJEPDSEC,R4         Use R4 for NJEP* locations  SML2NJE4 DMT16450
         SR    R2,R4               Get length of job trailer   SML2NJE4 DMT16460
         STH   R2,NJEPLEN          Save job trlr len in prefix SML2NJE4 DMT16470
*        Nothing of interest in job trailer.  Just keep going. SML2NJE4 DMT16480
         B     PFREE               Free tank.  Get next tank.  SML2NJE4 DMT16490
*                                                              SML2NJE4 DMT16500
COPYSEGM MVC   NJEPSIZE(*-*,R2),TANKDATA+NJEPSIZE Executed abv SML2NJE4 DMT16510
*                                                              SML2NJE4 DMT16520
PNDISCRD EQU   *                                               SML2NJE4 DMT16530
         ICM   R1,B'0011',TANKCNT  Check for end of job        SML2NJE4 DMT16540
         BNZ   PFREE               Discard tank. Get next one. SML2NJE4 DMT16550
         B     PCLOSEF             Skip EOF hdrs. Just close.  SML2NJE4 DMT16560
PCLOSE   EQU   *                                                        DMT16570
EOFREC   EQU   X'40'               Received EOF from network   SML2NJE4 DMT16580
         OI    PSW1,EOFREC         Flag EOF received           SML2NJE4 DMT16590
         LA    R0,14               Error code                  SML2NJE4 DMT16600
         CLI   PNSEGTYP,X'00'      Are we expecting EOF?       SML2NJE4 DMT16610
         BNE   MSG939              Declare protocol error      SML2NJE4 DMT16620
         MVI   PNSEGTYP,X'70'      Not expecting anything now  SML2NJE4 DMT16630
         LA    R0,15               Error code                  SML2NJE4 DMT16640
         CLI   PNSEGNUM,X'00'      Are all segments received?  SML2NJE4 DMT16650
         BNE   MSG939              Declare protocol error      SML2NJE4 DMT16660
         MVI   PNSEGNUM,X'FF'      Not expecting segments now  SML2NJE4 DMT16670
         L     R4,APNJETRL         Get address of job trailer  SML2NJE4 DMT16680
         LA    R5,X'D0'            Specify NJE job trailer     SML2NJE4 DMT16690
         BAL   R14,WRITNJEH        Write NJE header to ur dev  SML2NJE4 DMT16700
PCLOSEF  EQU   *                                               SML2NJE4 DMT16710
         TM    MASTERSW,SYSOUT     Was device actually opened? SML2NJE4 DMT16720
         BZ    PFREE               Didn't happen. Give up.     SML2NJE4 DMT16730
         L     R1,PDEVFIOA         Get IOTABLE address         SML2NJE4 DMT16740
         USING IOTABLE,R1          Get IOTABLE addressability  SML2NJE4 DMT16750
         UNPK  TAGCMD+7(5),DEVCUU(3) Unpack the device address SML2NJE4 DMT16760
         DROP  R1                  Finished with IOTABLE now   SML2NJE4 DMT16770
         MVI   TAGCMD+7,C' '       Restore the clobbered blank SML2NJE4 DMT16780
         MVI   TAGCMD+11,C' '      Restore the clobbered blank SML2NJE4 DMT16790
         TR    TAGCMD+8(3),AXSTRTAB-240 Make into legal EBCDIC SML2NJE4 DMT16800
         LA    R1,TAGCMD           Get the TAG command address SML2NJE4 DMT16810
         LA    R2,TAGCMDL          Get the TAG command length  SML2NJE4 DMT16820
*********DIAG  R1,R2,X'08'         Issue the TAG DEV command   SML2NJE4 DMT16830
         MVI   TAGDATA,C' '        Clear first byte of field   SML2NJE4 DMT16840
         MVC   TAGDATA+1(69),TAGDATA Clear rest of field       SML2NJE4 DMT16850
         LA    R1,PDEVSYNC         Get PRT / PUN device block  SML2NJE4 DMT16860
         LA    R0,X'12'            INDICATE CLOSE FUNCTION              DMT16870
         BAL   R14,AXS             GO CLOSE THE FILE                    DMT16880
         NI    MASTERSW,255-SYSOUT Clear UR device open flag   SML2NJE4 DMT16890
         OI    PACON,ECBSKIP       INDICATE SKIP ECB                    DMT16900
         TM    PSW1,DISCARD        Is job being discarded?     SML2NJE4 DMT16910
         BO    PFREE               No ACK and no MSG 145       SML2NJE4 DMT16920
RETRYACK EQU   *                                               SML2NJE4 DMT16930
         BAL   R14,$TPACKTC        Ack transmission complete   SML2NJE4 DMT16940
         BNZ   TPACKOK             No problems sending ACK     SML2NJE4 DMT16950
         MVI   PCTWFB,X'FF'        Show waiting for buffer     SML2NJE4 DMT16960
         MVC   PCTENTY(2),PACN1    Set up to retry send of ACK SML2NJE4 DMT16970
         L     R6,PCTCOM           Get commutator entry        SML2NJE4 DMT16980
         MVI   1(R6),CLOSE         Close gate                  SML2NJE4 DMT16990
         B     PCTRTN              Go wait for buffer          SML2NJE4 DMT17000
PLOC1    EQU   *                   Return here with buffer     SML2NJE4 DMT17010
         MVI   PCTWFB,X'00'        Show not waiting for buffer SML2NJE4 DMT17020
         B     RETRYACK            Retry sending file ACK      SML2NJE4 DMT17030
PACN1    DC    S(PLOC1)                                        SML2NJE4 DMT17040
TPACKOK  EQU   *                                                        DMT17050
         LH    R1,TAGID            Get file id assigned           *XJE
         CVD   R1,XJESAVE+16       Convert into work area         *XJE
         UNPK  XJESAVE+12(4),XJESAVE+16(8)  Make display          *XJE
         OI    XJESAVE+15,X'F0'    Fix sign                       *XJE
         MVI   XJESAVE+16,C' '     Ensure padded with blanks      *XJE
         MVC   XJESAVE+17(3),XJESAVE+16  out to eight bytes       *XJE
         MSGX  145,(XJESAVE+12,TAGINLOC,TAGINVM,TAGTOLOC,PCTTOVM) *XJE  DMT17060
         B     PFREE               FREE THE TANK IF END OF JOB          DMT17070
         SPACE 1                                                        DMT17080
PCONT    EQU   *                                                        DMT17090
PDATAREC EQU   *                                                        DMT17100
         XR    R1,R1               Clear R1 for ICM            SML2NJE4 DMT17110
         ICM   R1,B'0011',TANKCNT  Get number of bytes in tank SML2NJE4 DMT17120
         BZ    PCLOSE              Empty tank => end of file   SML2NJE4 DMT17130
         LA    R0,16               Error code                  SML2NJE4 DMT17140
         TM    PNSEGTYP,X'03'      Are we expecting data now?  SML2NJE4 DMT17150
         BNM   MSG939              Declare protocol error      SML2NJE4 DMT17160
         MVI   PNSEGTYP,X'02'      Specify data has been found SML2NJE4 DMT17170
         BCTR  R1,0                Don't count length byte     SML2NJE4 DMT17180
         MVI   PCTCCWCT,X'00'      Clear CCW count high byte   SML2NJE4 DMT17190
         MVC   PCTCCWCT+1(1),TANKDATA  Record length into CCW  SML2NJE4 DMT17200
         CH    R1,PCTCCWCT         Tank length < record length?SML2NJE4 DMT17210
         BNL   PCOUNTOK            All record within tank      SML2NJE4 DMT17220
         STH   R1,PCTCCWCT         Truncate to length of tank  SML2NJE4 DMT17230
PCOUNTOK EQU   *                                               SML2NJE4 DMT17240
         TM    MASTERSW,SYSOUT     Is UR output device open?   SML2NJE4 DMT17250
         BO    PCONT2              OPEN..OKAY CONTINUE                  DMT17260
         CLI   TAGINDEV,0          Have we got a device type?  SML2NJE4 DMT17270
         BNE   PGOTDEV             Already know what device    SML2NJE4 DMT17280
         MVI   TAGINDEV,TYPPUN     Assume PUN device suitable  SML2NJE4 DMT17290
         MVI   PNRECLEN+1,80       Punch reclen. Top byte is 0.SML2NJE4 DMT17300
         CLC   TAGRECLN,=H'81'     Is record length too large? SML2NJE4 DMT17310
         BNH   PGOTDEV             Record length ought to fit  SML2NJE4 DMT17320
         MVI   TAGINDEV,TYPPRT     Use PRT device instead      SML2NJE4 DMT17330
         MVI   PNRECLEN+1,132      Print reclen. Top byte is 0.SML2NJE4 DMT17340
PGOTDEV  EQU   *                                               SML2NJE4 DMT17350
         CLC   TAGTOLOC,LOCATION   Is the file for this node?  SML2NJE4 DMT17360
*NJE38   BNE   PNOTLOCL            No.  Not for anyone here.   SML2NJE4 DMT17370
         MVC   TAGTOVM,PCTTOVM     Spool file to local user    SML2NJE4 DMT17380
         MVC   TAGDATA(HDRSGLEN),HDRLINE Format header in tag  SML2NJE4 DMT17390
         MVC   TAGDATA+0(8),TAGINLOC Fill in originating node  SML2NJE4 DMT17400
         MVC   TAGDATA+12(8),TAGINVM Fill in originating user  SML2NJE4 DMT17410
         LA    R2,TAGDATA+22       Get address of time in tag  SML2NJE4 DMT17430
         MVC   TAGDATA+22(MASKLEN),TODMASK Get TOD edit mask   SML2NJE4 DMT17440
         LA    R0,XJE2TOD          Code 0C=TODEBCD                *XJE  DMT17450
         LA    R1,TAGINTOD         -> TOD clock data              *XJE
         L     R15,=A(DMTXJE2)     -> external routines csect     *XJE  DMT17460
         BALR  R14,R15             Convert TOD to EBCDIC          *XJE  DMT17470
         B     PISLOCAL            Skip over non-local stuff   SML2NJE4 DMT17480
*                                                              SML2NJE4 DMT17490
PNOTLOCL EQU   *                                               SML2NJE4 DMT17500
         MVC   TAGTOVM,=CL8'*'     Spool to self to requeue    SML2NJE4 DMT17510
         MVC   TAGDATA+0(8),TAGTOLOC Set tag node for next hop SML2NJE4 DMT17520
         MVC   TAGDATA+9(8),=CL8'<S&&F>' Indicate store + fwd  SML2NJE4 DMT17530
*                                                              SML2NJE4 DMT17540
PISLOCAL EQU   *                                               SML2NJE4 DMT17550
         LA    R1,PDEVSYNC         GET PRINTER DEVICE BLOCK             DMT17560
         LA    R0,X'11'            INDICATE GET SPOOL DEVICE            DMT17570
         BAL   R14,AXS             GO INTERFACE TO FILE ACCESS          DMT17580
         L     R1,PDEVFIOA         GET FILE I/O AREA ADDRESS            DMT17590
         ST    R1,PACON            AND STORE IN ECB LIST                DMT17600
         XC    0(4,R1),0(R1)       INITIALLY CLEAR SYNCH LOCK           DMT17610
         OI    MASTERSW,SYSOUT     Indicate UR output dev open SML2NJE4 DMT17620
         MSGX  144,(TAGINLOC,TAGINVM,TAGTOLOC,PCTTOVM) Rec'ing SML2NJE4 DMT17630
         L     R4,APNJEHDR         Get address of job header   SML2NJE4 DMT17640
         LA    R5,X'C0'            Specify NJE job header      SML2NJE4 DMT17650
         BAL   R14,WRITNJEH        Write NJE header to ur dev  SML2NJE4 DMT17660
         L     R4,APNJEDTA         Get address of data set hdr.SML2NJE4 DMT17670
         LA    R5,X'E0'            Specify NJE data set header SML2NJE4 DMT17680
         BAL   R14,WRITNJEH        Write NJE header to ur dev  SML2NJE4 DMT17690
PCONT2   EQU   *                                                        DMT17700
         EJECT                                                          DMT17710
*                                                                       DMT17720
*        SET UP CARRIAGE CONTROL                                        DMT17730
*                                                                       DMT17740
         LA    R6,TANKDATA+1       Skip record length byte     SML2NJE4 DMT17750
         ST    R6,PCTCCW           STORE IN CCW                         DMT17760
         LA    R0,X'41'            Default opcode for PUN      SML2NJE4 DMT17770
         CLI   TAGINDEV,TYP3210    Is this spooled cons o/p?   SML2NJE4 DMT17780
         BE    PRTCC               Treat it like a print file  SML2NJE4 DMT17790
         TM    TAGINDEV,TYPPRT     Is this a print file?       SML2NJE4 DMT17800
         BNO   PRCCDONE            Skip print carriage control SML2NJE4 DMT17810
PRTCC    EQU   *                                               SML2NJE4 DMT17820
         DROP  R3                  Finished with TAG for now   SML2NJE4 DMT17830
         LA    R0,X'09'            Assume no carriage control  SML2NJE4 DMT17840
         TM    TANKSRCB,B'00110000' Is there carriage control? SML2NJE4 DMT17850
         BZ    PRCCDONE            xx00xxxx => no carriage ctl SML2NJE4 DMT17860
         LA    R6,TANKDATA+2       Skip length and CC byte too SML2NJE4 DMT17870
         ST    R6,PCTCCW           Update CCW data location    SML2NJE4 DMT17880
         LH    R6,PCTCCWCT         Get CCW count               SML2NJE4 DMT17890
         BCTR  R6,0                Reduce by one               SML2NJE4 DMT17900
         STH   R6,PCTCCWCT         Store back CCW count        SML2NJE4 DMT17910
         TM    TANKSRCB,B'00100000' Is this machine CC?        SML2NJE4 DMT17920
         BO    PRNOTMCC            Not machine CC              SML2NJE4 DMT17930
         IC    R0,TANKDATA+1       Get opcode from data stream SML2NJE4 DMT17940
         B     PRCCDONE            Carriage control done       SML2NJE4 DMT17950
PRNOTMCC EQU   *                                               SML2NJE4 DMT17960
         TM    TANKSRCB,B'00010000' Is this ASA CC?            SML2NJE4 DMT17970
         BO    PRCCDONE            Not ASA CC, ignore it       SML2NJE4 DMT17980
         LA    R0,X'13'            Space 2 lines immediate     SML2NJE4 DMT17990
         CLI   TANKDATA+1,C'0'     Is CC character '0'?        SML2NJE4 DMT18000
         BE    PRASACC             ASA carriage control found  SML2NJE4 DMT18010
         LA    R0,X'8B'            Skip to channel 1 immediate SML2NJE4 DMT18020
         CLI   TANKDATA+1,C'1'     Is CC character '1'?        SML2NJE4 DMT18030
         BE    PRASACC             ASA carriage control found  SML2NJE4 DMT18040
         LA    R0,X'1B'            Space 3 lines immediate     SML2NJE4 DMT18050
         CLI   TANKDATA+1,C'-'     Is CC character '-'?        SML2NJE4 DMT18060
         BE    PRASACC             ASA carriage control found  SML2NJE4 DMT18070
         LA    R0,X'01'            Write, no space             SML2NJE4 DMT18080
         CLI   TANKDATA+1,C'+'     Is CC character '+'?        SML2NJE4 DMT18090
         BE    PRASACC             ASA carriage control found  SML2NJE4 DMT18100
         LA    R0,X'0B'            Default: space 1 immediate  SML2NJE4 DMT18110
PRASACC  STC   R0,PCTCCW           Store opcode in ccw         SML2NJE4 DMT18120
         DROP  R8                  Finished with TANKDSEC now  SML2NJE4 DMT18130
         BAL   R14,PWRITDEV        Write record to PRT         SML2NJE4 DMT18140
         LA    R0,X'01'            Write actual record 0 space SML2NJE4 DMT18150
PRCCDONE EQU   *                                               SML2NJE4 DMT18160
         STC   R0,PCTCCW           Store opcode in ccw         SML2NJE4 DMT18170
         BAL   R14,PWRITDEV        Write record to PRT or PUN  SML2NJE4 DMT18180
PFREE    EQU   *                                                        DMT18190
         MVC   0(4,R8),$TANKPOL    GET FIRST FREE OFF QUEUE             DMT18200
         ST    R8,$TANKPOL         MAKE THIS ONE THE FIRST              DMT18210
         MVI   $TPGETCM+1,OPEN     OPEN TPGET GATE                      DMT18220
         B     PNEXT               Process next record         SML2NJE4 DMT18230
         SPACE 1                                                        DMT18240
         EJECT                                                 SML2NJE4 DMT18250
*        Subroutine to write a record to PRT or PUN device     SML2NJE4 DMT18260
*        On entry, opcode, address of data and count in PCTCCW SML2NJE4 DMT18270
PWRITDEV DS    0H                                              SML2NJE4 DMT18280
         STM   R14,R8,COMSAVE+8    Save callers registers      SML2NJE4 DMT18290
         MVI   PCTECB,X'10'        Show PRT or PUN device busy SML2NJE4 DMT18300
         L     R1,PDEVFIOA         Get file I/O area address   SML2NJE4 DMT18310
         USING IOTABLE,R1          Get IOTABLE addressability  SML2NJE4 DMT18320
         LA    R6,PCTCCW           Get CCW address             SML2NJE4 DMT18330
         ST    R6,PROGADDR         Set CAW in device block     SML2NJE4 DMT18340
         DROP  R1                  Finished with IOTABLE       SML2NJE4 DMT18350
         L     R15,IOREQ           System I/O processor        SML2NJE4 DMT18360
         BALR  R14,R15             Go execute the I/O          SML2NJE4 DMT18370
         BAL   R14,$IOCK           Wait for ECB to be posted   SML2NJE4 DMT18380
         LM    R14,R8,COMSAVE+8    Retrieve callers registers  SML2NJE4 DMT18390
         BR    R14                 Return to caller            SML2NJE4 DMT18400
*                                                              SML2NJE4 DMT18410
*        Subroutine to write an NJE header to a unit record    SML2NJE4 DMT18420
*        device.  The header is split into segments which can  SML2NJE4 DMT18430
*        be accomodated by the device.  On entry, the address  SML2NJE4 DMT18440
*        of the header is in R4 and the header type is in R5.  SML2NJE4 DMT18450
*                                                              SML2NJE4 DMT18460
WRITNJEH EQU   *                                               SML2NJE4 DMT18470
         LH    R0,PCTCCWCT         Save data record length     SML2NJE4 DMT18480
         LR    R6,R14              Save callers address        SML2NJE4 DMT18490
         USING NJEPDSEC,R4         Use R4 for NJEP* addresses  SML2NJE4 DMT18500
         XR    R2,R2               Start at segment zero       SML2NJE4 DMT18510
         XR    R1,R1               Clear R1 for ICM            SML2NJE4 DMT18520
         ICM   R1,B'0011',NJEPLEN  Get total header length     SML2NJE4 DMT18530
WNJELOOP EQU   *                                               SML2NJE4 DMT18540
         LA    R1,NJEPSIZE(,R1)    Add len. of segment prefix  SML2NJE4 DMT18550
         STH   R1,NJEPLEN          Size of rest of header      SML2NJE4 DMT18560
         STC   R5,NJEPFLGS         Set header type             SML2NJE4 DMT18570
         STC   R2,NJEPSEQ          Set segment number          SML2NJE4 DMT18580
         CH    R1,PNRECLEN         More than record len left?  SML2NJE4 DMT18590
         BNH   WNJELNOK            Length is ok for device     SML2NJE4 DMT18600
         MVC   NJEPLEN,PNRECLEN    Reduce segment to 132 or 80 SML2NJE4 DMT18610
         OI    NJEPSEQ,X'80'       Flag segment as not last    SML2NJE4 DMT18620
WNJELNOK EQU   *                                               SML2NJE4 DMT18630
         MVC   PCTCCWCT,NJEPLEN    Set CCW count for write     SML2NJE4 DMT18640
         MVI   PCTCCW,X'03'        Use NOP opcode for headers  SML2NJE4 DMT18650
         STCM  R4,B'0111',PCTCCW+1 Address of buffer to write  SML2NJE4 DMT18660
         BAL   R14,PWRITDEV        Write the header segment    SML2NJE4 DMT18670
         LA    R2,1(,R2)           Increment segment number    SML2NJE4 DMT18680
         AH    R4,PCTCCWCT         Push past this segment      SML2NJE4 DMT18690
         SH    R4,=AL2(NJEPSIZE)   Leave space for seg. prefix SML2NJE4 DMT18700
         SH    R1,PCTCCWCT         Reduce total by this segmnt SML2NJE4 DMT18710
         BNZ   WNJELOOP            Go around again if any left SML2NJE4 DMT18720
         DROP  R4                  Finished with NJE headers   SML2NJE4 DMT18730
         STH   R0,PCTCCWCT         Restore data record length  SML2NJE4 DMT18740
         LR    R14,R6              Restore callers address     SML2NJE4 DMT18750
         BR    R14                 Return to caller            SML2NJE4 DMT18760
*                                                              SML2NJE4 DMT18770
         USING TAG,R3              Ensure tag addresability    SML2NJE4 DMT18780
MSG938   EQU   *                                               SML2NJE4 DMT18790
         LH    R0,TAGID            Get spool file number       SML2NJE4 DMT18800
         CVD   R0,AXSCVD           Convert spool id to BCD     SML2NJE4 DMT18810
         UNPK  AXSFILE,AXSCVD      Make number printable       SML2NJE4 DMT18820
         OI    AXSFILE+3,X'F0'     Ensure last digit is too    SML2NJE4 DMT18830
         MSGX  938,(AXSFILE,AXSLINK) Resources n/a error       SML2NJE4 DMT18840
         B     PFLGDISC            Flag job to be discarded    SML2NJE4 DMT18850
*                                                              SML2NJE4 DMT18860
MSG939   EQU   *                                               SML2NJE4 DMT18870
         MVC   AXSRECS,BLANK       Clear unused characters     SML2NJE4 DMT18880
         CVD   R0,AXSCVD           Convert error code to BCD   SML2NJE4 DMT18890
         UNPK  AXSRECS(2),AXSCVD   Make number printable       SML2NJE4 DMT18900
         OI    AXSRECS+1,X'F0'     Ensure last digit is too    SML2NJE4 DMT18910
         LH    R0,TAGID            Get spool file number       SML2NJE4 DMT18920
         CVD   R0,AXSCVD           Convert spool id to BCD     SML2NJE4 DMT18930
         UNPK  AXSFILE,AXSCVD      Make number printable       SML2NJE4 DMT18940
         OI    AXSFILE+3,X'F0'     Ensure last digit is too    SML2NJE4 DMT18950
         MSGX  939,(AXSFILE,AXSLINK,AXSRECS) Protocol error    SML2NJE4 DMT18960
         TM    PSW1,EOFREC         Already received EOF?       SML2NJE4 DMT18970
         BO    PCLOSEF             No point in waiting for it  SML2NJE4 DMT18980
*                                                              SML2NJE4 DMT18990
PFLGDISC EQU   *                                               SML2NJE4 DMT19000
DISCARD  EQU   X'80'               Flag in PSW1 to discard job SML2NJE4 DMT19010
         OI    PSW1,DISCARD        Set flag to discard job     SML2NJE4 DMT19020
         MVI   PNSEGTYP,X'70'      Not expecting valid seg typ SML2NJE4 DMT19030
         MVI   PNSEGNUM,X'FF'      Not expecting valid seg num SML2NJE4 DMT19040
         B     PFREE               Free tank. Discard rest.    SML2NJE4 DMT19050
         DROP  R3                  Finished with tag for now   SML2NJE4 DMT19060
*                                                              SML2NJE4 DMT19070
         EJECT                                                          DMT19080
*.                                                                      DMT19090
*                                                                       DMT19100
* ENTRY NAME -                                                          DMT19110
*                                                                       DMT19120
*        $JRTN1                                                         DMT19130
*                                                                       DMT19140
* FUNCTION -                                                            DMT19150
*                                                                       DMT19160
*        THIS ROUTINE DEQUEUES TANKS FROM ITS TANK QUEUE, OBTAINS       DMT19170
*        A NEW OUTPUT SPOOL DEVICE IF NEEDED FROM DMTAXS, AND           DMT19180
*        OUTPUTS THE TANK TO A VIRTUAL PUNCH.                           DMT19190
*                                                                       DMT19200
* CALLS TO OTHER ROUTINES -                                             DMT19210
*                                                                       DMT19220
*        DMTIOMRQ - TO INITIATE AN I/O OPERATION                        DMT19230
*                                                                       DMT19240
* OPERATION -                                                           DMT19250
*                                                                       DMT19260
*        1. OBTAIN A TANK FROM $GETTNK                                  DMT19270
*                                                                       DMT19280
*        2. IF OBTAINED CHECK TO SEE IF OUTPUT FILE IS OPENED,          DMT19290
*           IF NOT OBTAIN A OUTPUT DEVICE BY A CALL TO AXS.             DMT19300
*                                                                       DMT19310
*        3. VIA A CALL TO $USREXIT VALIDATE THE INFORMATION ON          DMT19320
*           THE ID CARD.                                                DMT19330
*                                                                       DMT19340
*        4. WRITE THE RECORD TO THE VM/370 SPOOL FILE SYSTEM.           DMT19350
*                                                                       DMT19360
*        5. WHEH EOF IS OBTAINED CLOSE THE FILE VIA ANOTHER CALL        DMT19370
*           TO AXS.                                                     DMT19380
*                                                                       DMT19390
*        6. EXIT TO COMMUTATOR                                          DMT19400
*                                                                       DMT19410
* RESPONSES -                                                           DMT19420
*                                                                       DMT19430
*        DMTXJE144I  RECEIVING: FILE FROM 'LOCID1' ('USERID1') HRC000DT DMT19440
*                    FOR 'LOCID2' ('USERID2')                  HRC000DT DMT19450
*        DMTXJE145I  RECEIVED: FILE FROM 'LOCID1' ('USERID1')  HRC000DT DMT19460
*                    FOR 'LOCID2' ('USERID2')                  HRC000DT DMT19470
*                                                                       DMT19480
* ERROR MESSAGES -                                                      DMT19490
*                                                                       DMT19500
*        NONE                                                           DMT19510
*                                                                       DMT19520
*.                                                                      DMT19530
         SPACE 1                                                        DMT19540
         USING TANKDSEC,R8                                              DMT19550
         USING TCTDSECT,TCTR                                            DMT19560
         USING TAG,R1              GET TAG ADDRESSABILITY               DMT19570
$JRTN1   DS    0H                  INITIAL ENTRY AT IPL TIME            DMT19580
JSTART   DS    0H                  LOOP ENTRY TO CONTINUE PUNCHING      DMT19590
         BAL   R14,$GETTNK         WAIT FOR THE NEXT TANK               DMT19600
         CLI   TANKCNT+1,0         TEST FOR END OF JOB                  DMT19610
         BNE   JOUTPUT             NO CONTINUE                          DMT19620
JCLOSE   EQU   *                                                        DMT19630
         XC    $USRCMDC(2),$USRCMDC CLEAR INPUT CMD COUNT      @VA04612 DMT19640
         TM    MASTERSW,JOB        WAS A FILE EVER OPENED?              DMT19650
         BO    JCLOSE1             YES CONTINUE                         DMT19660
         NI    JSW2,255-JNOID RESET ID CARD MISSING FLAG       @VA04612 DMT19670
         B     JFREE               AND EXIT                             DMT19680
         SPACE 1                                                        DMT19690
JCLOSE1  EQU   *                                                        DMT19700
         L     R15,JDEVFIOA        GET IOTABLE ADDRESS                  DMT19710
         UNPK  TAGCMD+7(5),DEVCUU-IOTABLE(3,R15) UNPK THE DEV ADDR      DMT19720
         MVI   TAGCMD+7,C' '       RESTORE THE CLOBBERED BLANK          DMT19730
         MVI   TAGCMD+11,C' '      RESTORE THE CLOBBERED BLANK          DMT19740
         TR    TAGCMD+8(3),AXSTRTAB-240 TRANSLATE TO LEGAL EBCDIC       DMT19750
         LA    R1,TAGCMD           GET TAG COMMAND ADDR                 DMT19760
         LA    R2,TAGCMDL          AND THE LENGTH                       DMT19770
*********DIAG  R1,R2,X'08'         AND ISSUE THE COMMAND                DMT19780
         MVI   TAGDATA,C' '        CLEAR FIRST BYTE OF FIELD            DMT19790
         MVC   TAGDATA+1(69),TAGDATA AND THE REST OF FIELD              DMT19800
         LA    R1,JDEVSYNC         GET DEVICE BLOCK ADDRESS             DMT19810
         LA    R0,X'12'            INDICATE CLOSE                       DMT19820
         BAL   R14,AXS             GO CLOSE THE FILE                    DMT19830
         BAL   R14,$TPACKTC        Ack transmission complete   SML2NJE4 DMT19840
         MSGX  145,(AXSLINK,SYSTYPE,LOCATION,JCTTOVM) WRITE CLO@VM01105 DMT19850
         NI    MASTERSW,255-JOB    TURN OFF OPEN FLAG                   DMT19860
         NI    JSW1,255-JSPOVM     RESET FLAG                           DMT19870
         OI    JACON,ECBSKIP       INDICATE ECB SKIP                    DMT19880
         L     R1,AJDEVTAG         GET ADDRESS OF JOB TAG      SML2NJE4 DMT19890
         MVC   TAGTOVM(8),BLANK    BLANK OUT TAG                        DMT19900
         MVC   JCTTOVM(8),BLANK    BLANK OUT DESTINATION                DMT19910
         B     JFREE               IF SO FREE TANK                      DMT19920
         EJECT                                                          DMT19930
JOUTPUT  DS    0H                  JOB THE CARD                         DMT19940
         TM    MASTERSW,JOB        SEE IF FILE ACTIVE                   DMT19950
         BO    JOUT1               YES CONTINUE                         DMT19960
         BAL   R14,$USREXIT        SEE CARD MUST BE MODIFIED            DMT19970
         BP    JFREE               NON 0 DONT PROCESS RECORD            DMT19980
         TM    JSW1,JSPOVM         ARE WE SPOOLING YET                  DMT19990
         BNO   JFREE               NO..SKIP IT                          DMT20000
         L     R1,AJDEVTAG         GET ADDRESS OF JOB TAG      SML2NJE4 DMT20010
         MVC   TAGTOVM(8),JCTTOVM  MOVE IN DESTINATION                  DMT20020
         LA    R1,JDEVSYNC         GET DEVICE BLOCK                     DMT20030
         LA    R0,X'11'            INDICATE OPEN                        DMT20040
         BAL   R14,AXS             GO GET A DEVICE                      DMT20050
         L     R1,JDEVFIOA         GET FIOA ADDRESS                     DMT20060
         XC    0(4,R1),0(R1)       INITIALIALLY CLEAR SYNCH LOCK        DMT20070
         ST    R1,JACON            STORE IN ECB LIST                    DMT20080
         OI    MASTERSW,JOB        INDICATE FILE OPEN                   DMT20090
         MSGX  144,(AXSLINK,SYSTYPE,LOCATION,JCTTOVM) WRITE REC@VM01105 DMT20100
         B     JFREE               FREE THE TANK                        DMT20110
         SPACE 1                                                        DMT20120
JOUT1    EQU   *                                                        DMT20130
         MVC   JCTCCWCT+1(1),TANKCNT+1 SET COUNT IN CCW                 DMT20140
         LA    R8,TANKDATA         GET DATA ADDR                        DMT20150
         ST    R8,JCTCCW           STORE IN CCW                         DMT20160
         MVI   JCTECB,X'10'        SHOW PUNCH BUSY                      DMT20170
         OC    JCTCCW(1),JCTOPCOD  SET OPCODE                           DMT20180
         L     R1,JDEVFIOA         GET DEVICE BLOCK                     DMT20190
         LA    R6,JCTCCW           GET CCW ADDR                         DMT20200
         ST    R6,PROGADDR-IOTABLE(R1) SET IN CAW                       DMT20210
         L     R15,IOREQ           SYSTEM I/O REWUEST PROCESSOR         DMT20220
         BALR  R14,R15             GO EXECUTE THE I/O                   DMT20230
         BAL   R14,$IOCK           CHECK FOR I/O COMPLETE               DMT20240
         L     R8,JCTCCW           PICK UP TANK ADDRESS                 DMT20250
         S     R8,=A(TANKDATA-TANKDSEC) RESET TO BEGINNING OF TANK      DMT20260
JFREE    EQU   *                                                        DMT20270
         MVC   0(4,R8),$TANKPOL    GET FIRST FREE OFF QUEUE             DMT20280
         ST    R8,$TANKPOL         MAKE THIS ONE THE FIRST              DMT20290
         MVI   $TPGETCM+1,OPEN     OPEN TPGET GATE                      DMT20300
         B     JSTART              GO BACK TO START OF PROCESSOR        DMT20310
         DROP  R1                  DROP ADDRESSABILITY                  DMT20320
         SPACE 1                                                        DMT20330
JSPOVM   EQU   X'40'               SPO TO VM FLAG                       DMT20340
         EJECT                                                          DMT20350
*.                                                                      DMT20360
*                                                                       DMT20370
* ENTRY NAME -                                                          DMT20380
*                                                                       DMT20390
*        $USREXIT                                                       DMT20400
*                                                                       DMT20410
* FUNCTION -                                                            DMT20420
*                                                                       DMT20430
*        TO VALIDATE THE 'ID' CARD ON THE FRONT OF DECKS INPUTTED       DMT20440
*        FROM A REMOTE CARD READER.                                     DMT20450
*                                                                       DMT20460
* CALLS TO OTHER ROUTINES -                                             DMT20470
*                                                                       DMT20480
*        NONE                                                           DMT20490
*                                                                       DMT20500
* OPERATION -                                                           DMT20510
*                                                                       DMT20520
*        1. SEE IF THE TANK CONTAINS AN ID CARD.                        DMT20530
*           IT NOT EXIT.                                                DMT20540
*                                                                       DMT20550
*        2. IF ID CARD IS FOUND VALIDATE LENGTH OF USERID AND           DMT20560
*           MOVE TO THE JCTTOVM FIELD IN THE TCT.                       DMT20570
*                                                                       DMT20580
*        3. ANY OTHER TEXT ON THE ID CARD IS SAVED FOR USE AS THE       DMT20590
*           TAG COMMAND TEXT.                                           DMT20600
*                                                                       DMT20610
*        4. SET RETURN CODE AND RETURN TO CALLER.                       DMT20620
*                                                                       DMT20630
*                                                                       DMT20640
* RESPONSES -                                                           DMT20650
*                                                                       DMT20660
*                                                                       DMT20670
* ERROR MESSAGES -                                                      DMT20680
*                                                                       DMT20690
*                                                                       DMT20700
*.                                                                      DMT20710
         SPACE 3                                                        DMT20720
         USING TANKDSEC,R8                                              DMT20730
         SPACE 1                                                        DMT20740
$USREXIT DS    0H                                                       DMT20750
         LTR   R15,R15             SET CONDITION CODE                   DMT20760
         BR    R14                 RETURN                               DMT20770
         SPACE                                                          DMT20780
JNOID    EQU   X'80'          ID CARD MISSING FLAG             @VA04612 DMT20790
         SPACE                                                          DMT20800
         SPACE 1                                                        DMT20810
         EJECT                                                          DMT20820
*---------------------------------------------------------------------* DMT20830
*                                                                     * DMT20840
*           UNIT RECORD WAIT ROUTINE                                  * DMT20850
*                                                                     * DMT20860
*---------------------------------------------------------------------* DMT20870
         SPACE 1                                                        DMT20880
         USING TANKDSEC,R8         GET TANK ADDRESSABILITY              DMT20890
         USING TCTDSECT,TCTR       GET TCT ADDRESSABILITY               DMT20900
         SPACE 3                                                        DMT20910
         DS    0H                                                       DMT20920
YOCLOSE  EQU   *                                                        DMT20930
         L     R14,TCTCOM          CLOSE COMMUTATOR                     DMT20940
         MVI   1(R14),CLOSE        CHANGE BR TO NOP                     DMT20950
*              IF DEVICE BUSY DEVICE END INTERRUPT WILL CLEAR           DMT20960
*              IF DEVICE NOT  READY DEVICE END WILL CLEAR               DMT20970
         BR    R14                 RETURN TO CALLER                     DMT20980
         SPACE 1                                                        DMT20990
*        $IOCK                     ENTRY POINT TO PASS TO USER CODES    DMT21000
*                                                                       DMT21010
$IOCK    EQU   *                                                        DMT21020
         ST    R14,TCTSAV1         SAVE USER RETURN ADDRESS             DMT21030
         MVC   TCTENTY(2),YACN1    GET READY FOR DELAY                  DMT21040
         B     YOCLOSE             AND CONTINUE                         DMT21050
         SPACE 1                                                        DMT21060
YOCKRET  EQU   *                                                        DMT21070
         TM    TCTECB,X'10'        IS THE DEVICE FREE???                DMT21080
         BO    YOCLOSE             ALL DONE                             DMT21090
         L     R14,TCTSAV1         RESTORE REG                          DMT21100
         BR    R14                 RETURN TO CALLER                     DMT21110
         SPACE 1                                                        DMT21120
YACN1    DC    S(YOCKRET)          RETURN ENTRY POINT                   DMT21130
         EJECT                                                          DMT21140
*.                                                                      DMT21150
*                                                                       DMT21160
* ENTRY NAME -                                                          DMT21170
*                                                                       DMT21180
*        $RRTN1                                                         DMT21190
*                                                                       DMT21200
* FUNCTION -                                                            DMT21210
*                                                                       DMT21220
*        THIS ROUTINE INPUTS FILES FROM THE VM/370 SPOOL FILE           DMT21230
*        SYSTEM, DEBLOKS THEM INTO 132 BYTE RECORDS AND ISSUES A        DMT21240
*        CALL TO $PUT TO BLOCK THE RECORD INTO A TRANSMISSION           DMT21250
*        BUFFER.                                                        DMT21260
*                                                                       DMT21270
* CALLS TO OTHER ROUTINES -                                             DMT21280
*                                                                       DMT21290
*        NONE                                                           DMT21300
*                                                                       DMT21310
* OPERATION -                                                           DMT21320
*                                                                       DMT21330
*        1. IF NEEDED OPEN A NEW FILE TO TRANSMIT VIA CALL TO AXSGET.   DMT21340
*                                                                       DMT21350
*        2. TEST FOR READER TYPE AND MODIFY READER RCB TO REFLECT       DMT21360
*           MODE AND FILE TYPE.                                         DMT21370
*                                                                       DMT21380
*        3. SEND AND WAIT FOR A REPLY FOR A PERMISSION TO TRANSMIT      DMT21390
*           RECORD.                                                     DMT21400
*                                                                       DMT21410
*        4. GET A RECORD TO TRANSMIT VIA CALL TO VMDEBLOK               DMT21420
*                                                                       DMT21430
*        5. TEST FOR A READER COMMAND PENDING BY CHECKING RDRCMD        DMT21440
*           BYTE.                                                       DMT21450
*                                                                       DMT21460
*        6. IF EOF PURGE THE FILE, TRANSMIT EOF RECORD AND TRY          DMT21470
*           TO OBTAIN ANOTHER FILE.                                     DMT21480
*                                                                       DMT21490
* RESPONSES -                                                           DMT21500
*                                                                       DMT21510
*        DMTXJE146I  SENDING: FILE 'SPOOLID' ON LINK 'LINKID', HRC000DT DMT21520
*                         REC NNNNNN                           HRC000DT DMT21530
*        DMTXJE147I  SENT: FILE'SPOOLID' ON LINK 'LINKID'      HRC000DT DMT21540
*        DMTXJE580I  FILE 'SPOOLID' PROCESSING TERMINATED      HRC000DT DMT21550
*        DMTXJE611I  LINK 'LINKID' FILE TRANSMISSION SUSPENDED HRC000DT DMT21560
*        DMTXJE510I  FILE 'SPOOLID' BACKSPACED                 HRC000DT DMT21570
*        DMTXJE600I  FILE 'SPOOLID' FORWARD SPACED             HRC000DT DMT21580
*                                                                       DMT21590
* ERROR MESSAGES -                                                      DMT21600
*                                                                       DMT21610
*        DMTXJE581E  FILE 'SPOOLID' NOT ACTIVE                 HRC000DT DMT21620
*                                                                       DMT21630
*.                                                                      DMT21640
         EJECT                                                          DMT21650
*                                                                       DMT21660
*        INPUT SERVICE PROCESSOR                                        DMT21670
*                                                                       DMT21680
         SPACE 1                                                        DMT21690
$RRTN1   DS    0H                  INITIAL ENTRY AT IPL TIME            DMT21700
         USING TCTDSECT,TCTR       GET TCT ADDRESSABILTIY               DMT21710
         USING TAG,R8              GET TAG ADDRESSABILTIY               DMT21720
         USING LINKTABL,R6         Link table addressability   SML2NJE3 DMT21730
READ1    EQU   *                                                        DMT21740
         L     R6,XJELINK     Get link table address           HRC000DT DMT21750
         TM    LFLAG,LHOLD    IS THE LINK HELD                 @VA03110 DMT21760
         BO    READHLD        YES..EXIT                        @VA03110 DMT21770
         DROP  R6                  Finished with link table    SML2NJE3 DMT21780
         TM    RDRCMD,RHLDIPGS     IS A HOLD IN PROGRESS?               DMT21790
         BNO   RDNOHLD             NO CONTINUE                          DMT21800
READHLD  EQU   *                                               @VA03110 DMT21810
         MVC   RCTENTY(2),RACN4    REENTER AT READ1                     DMT21820
         B     RDWAIT              Go and wait                 SML2NJE4 DMT21830
         SPACE 1                                                        DMT21840
RDNOHLD  EQU   *                                                        DMT21850
         MVI   RCTECB,X'10'        SHOW READER BUSY                     DMT21860
         LA    R0,XJE2AXSG         Code 00=AXSGET                 *XJE  DMT21870
         L     R15,=A(DMTXJE2)     -> external routines csect     *XJE  DMT21880
         BALR  R14,R15             Go try to open reader file     *XJE  DMT21890
         LTR   R15,R15             Were files available?          *XJE  DMT21900
         BNZ   RDERR1              NO FILES FOR NOW                     DMT21910
         SPACE 1                                                        DMT21920
         L     R8,RDEVTAG          GET TAG ADDRESS                      DMT21930
         LH    R1,TAGID            GET SPOOL FILE ID                    DMT21940
         CVD   R1,AXSCVD           CONVERT TO DECIMAL                   DMT21950
         UNPK  AXSFILE,AXSCVD      SPREAD THE DIGITS                    DMT21960
         OI    AXSFILE+3,X'F0'     AND MAKE SURE LAST IS PRINTABLE      DMT21970
         L     R1,TAGRECNM         GET NUMBER OF RECS IN FILE           DMT21980
         CVD   R1,AXSCVD           CONVERT TO DECIMAL                   DMT21990
         UNPK  AXSRECS,AXSCVD      SPREAD THE DIGITS                    DMT22000
         OI    AXSRECS+7,X'F0'     MAKE SURE LAST IS PRINTABLE          DMT22010
         MVC   MSGVMID(8),TAGINVM  MOVE VMID INTO MSG                   DMT22020
         CLC   TAGTOVM,=CL8'<S&&F>' Check for store and fwd    SML2NJE4 DMT22030
         BNE   NOTSANDF            Not store and forward       SML2NJE4 DMT22040
         OI    RSW1,SANDF          Indicate store and fwd      SML2NJE4 DMT22050
NOTSANDF EQU   *                                               SML2NJE4 DMT22060
         CLI   TAGINDEV,TYP3210    IS IT SPOOLED CONSOLE OUTPUT         DMT22070
         BE    READCON             YES..TREAT LIKE PRINT FILE           DMT22080
         TM    TAGINDEV,TYPPRT     IS IT A PRINT FILE                   DMT22090
         BNO   READ2               NO CONTINUE                          DMT22100
READCON  EQU   *                                                        DMT22110
         OI    RSW1,PTRANS         INDICATE TRANSMITTING PRT FILE       DMT22120
         B     ROPEN               GO INITIATE THE TRANSMISSION         DMT22130
         SPACE 1                                                        DMT22140
READ2    EQU   *                                                        DMT22150
         SPACE 1                                                        DMT22160
READ3    EQU   *                                                        DMT22170
         OI    RSW1,UTRANS         INDICATE TRANSMITTING PUNCH OUTPUT   DMT22180
         EJECT                                                          DMT22190
ROPEN    EQU   *                                                        DMT22200
         TM    MASTERSW,READER     IS THERE A READER  OPEN              DMT22210
         BO    ROPEN1              READER IS ACTIVE                     DMT22220
         LA    R8,RCTTANK1         LOCATE TANK IN PARAMETER REG         DMT22230
         BAL   R14,$TPOPEN         REQUEST OTHER END TO RECEIVE STREAM  DMT22240
         BZ    RREOPEN             IF NOT SENT WAIT                     DMT22250
         MVC   RCTENTY(2),RACN1    WAIT FOR RESPONSE                    DMT22260
         B     RDWAIT                                          SML2NJE4 DMT22270
         SPACE 1                                                        DMT22280
RLOC1    EQU   *                                                        DMT22290
         OI    MASTERSW,READER     INDICATE THAT THE READER IS OPEN     DMT22300
         MSGX  146,(AXSFILE,AXSLINK,AXSRECS) WRITE MSG                  DMT22310
*                                                              SML2NJE4 DMT22320
*        If NJE headers are already present in file, get them  SML2NJE4 DMT22330
*        and send them out before the file. Otherwise, create  SML2NJE4 DMT22340
*        a set of headers from scratch and send those.         SML2NJE4 DMT22350
*                                                              SML2NJE4 DMT22360
         TM    RSW1,SANDF          Is this a store and fwd fileSML2NJE4 DMT22370
         BO    RNONJEH             Skip creating headers       SML2NJE4 DMT22380
*                                                              SML2NJE4 DMT22390
         L     R8,RDEVTAG          Get address of file tag     SML2NJE4 DMT22400
         LA    R0,XJE3JEJH         Code for routine BLDNJEJH      *XJE  DMT22410
         L     R15,=A(DMTXJE3)     -> NJE functions csect         *XJE  DMT22420
         BALR  R14,R15             Build NJE job header        SML2NJE4 DMT22430
*                                                              SML2NJE4 DMT22440
         LA    R8,RCTTANK1         Get tank address            SML2NJE4 DMT22450
         BAL   R14,$PUT            Write the tank to tp buffer SML2NJE4 DMT22460
*                                                              SML2NJE4 DMT22470
*        Create NJE data set header and send it before file    SML2NJE4 DMT22480
*                                                              SML2NJE4 DMT22490
         L     R8,RDEVTAG          Get address of file tag     SML2NJE4 DMT22500
         LA    R0,XJE3JEDS         Code for routine BLDNJEDS      *XJE  DMT22510
         L     R15,=A(DMTXJE3)     -> NJE functions csect         *XJE  DMT22520
         BALR  R14,R15             Build NJE dataset header    SML2NJE4 DMT22530
*                                                              SML2NJE4 DMT22540
         LA    R8,RCTTANK1         Get tank address            SML2NJE4 DMT22550
         BAL   R14,$PUT            Write the tank to tp buffer SML2NJE4 DMT22560
*                                                              SML2NJE4 DMT22570
RNONJEH  EQU   *                                               SML2NJE4 DMT22580
         EJECT                                                          DMT22590
ROPEN1   EQU   *                                                        DMT22600
RDLOOP   DS    0H                  BASIC READ LOOP                      DMT22610
*        Prepare to receive NJE headers from spool file NOPs   SML2NJE4 DMT22620
         L     R2,ARNJEHDR         Get start of buffer         SML2NJE4 DMT22630
         LA    R2,TANKDATA-TANKDSEC(,R2) Add tank overhead     SML2NJE4 DMT22640
         XR    R5,R5               Running total of hdr size   SML2NJE4 DMT22650
RDLOPA   EQU   *                                               SML2NJE4 DMT22660
         LA    R0,XJE2VMDB         Code 08=VMDEBLOK               *XJE  DMT22670
         L     R15,=A(DMTXJE2)     -> external routines csect     *XJE  DMT22680
         BALR  R14,R15             Go get a line to send          *XJE  DMT22690
         LTR   R15,R15             Was it end-of-file?            *XJE  DMT22700
         BNZ   RDEOF               E-O-F                                DMT22710
RDLOPB   EQU   *                                                        DMT22720
         CLI   RCTOPCOD,X'03'      IS IT A TAG RECORD                   DMT22730
         BNE   RDNOTNOP            Not a NOP record            SML2NJE4 DMT22740
         CLI   RCTTDTA1+1,C' '     Tag etc will be printable   SML2NJE4 DMT22750
         BNL   RDLOOP              Ignore tag NOP record       SML2NJE4 DMT22760
         LA    R4,RCTTDTA1+1       PRT/PUN data from VMDEBLOK  SML2NJE4 DMT22770
         USING NJEPDSEC,R4         Use R4 for NJEP* locations  SML2NJE4 DMT22780
         LA    R8,RCTTANK1+1       For TANKDATA in COPYSEGM    SML2NJE4 DMT22790
         XR    R1,R1               Clear R1 for ICM            SML2NJE4 DMT22800
         ICM   R1,B'0011',NJEPLEN  Get segment length          SML2NJE4 DMT22810
         SH    R1,=AL2(NJEPSIZE)   Reduce by seg. prefix len.  SML2NJE4 DMT22820
         LR    R0,R2               Make temporary copy of ptr  SML2NJE4 DMT22830
         AR    R0,R1               Add length of segment       SML2NJE4 DMT22840
         CL    R0,ARNJEHND         Compare to end of buffer    SML2NJE4 DMT22850
         BNL   MSG928              Segment won't fit in buffer SML2NJE4 DMT22860
         BCTR  R1,0                Reduce by one for EX        SML2NJE4 DMT22870
         EX    R1,COPYSEGM         Copy the segment to buffer  SML2NJE4 DMT22880
         LA    R2,1(R1,R2)         +1. Update buffer pointer   SML2NJE4 DMT22890
         LA    R5,1(R1,R5)         Keep running total as well  SML2NJE4 DMT22900
         TM    NJEPSEQ,X'80'       Is this the last segment?   SML2NJE4 DMT22910
         BO    RDLOPA              No. Go get more segments.   SML2NJE4 DMT22920
         IC    R3,NJEPFLGS         Grab SRCB value to use      SML2NJE4 DMT22930
         ICM   R3,B'0010',RCTRCBT  Also grab RCB value to use  SML2NJE4 DMT22940
         L     R8,ARNJEHDR         Get address of first tank   SML2NJE4 DMT22950
         MVI   RNSEGNUM,0          Start at segment zero       SML2NJE4 DMT22960
RNJELOOP EQU   *                                               SML2NJE4 DMT22970
         LA    R4,TANKDATA-TANKDSEC(,R8) Address of seg prefix SML2NJE4 DMT22980
         LA    R5,NJEPSIZE(,R5)    Add len. of segment prefix  SML2NJE4 DMT22990
         LR    R6,R5               Get new segment size        SML2NJE4 DMT23000
         STH   R3,TANKRCB-TANKDSEC(,R8) Store Tank RCB & SRCB  SML2NJE4 DMT23010
         MVI   NJEPFLGS,0          Set segment flags           SML2NJE4 DMT23020
         MVC   NJEPSEQ,RNSEGNUM    Set segment number          SML2NJE4 DMT23030
         CH    R5,=H'256'          Is segment too long?        SML2NJE4 DMT23040
         BNH   RNJELNOK            Length is allowed           SML2NJE4 DMT23050
         LA    R6,256              Reduce segment len. to 256  SML2NJE4 DMT23060
         OI    NJEPSEQ,X'80'       Flag segment as not last    SML2NJE4 DMT23070
RNJELNOK EQU   *                                               SML2NJE4 DMT23080
         STH   R6,NJEPLEN          Put length in seg. header   SML2NJE4 DMT23090
         STH   R6,TANKCNT-TANKDSEC(,R8) Put length in tank     SML2NJE4 DMT23100
         L     R0,0(R6,R8)         Grab word after segment     SML2NJE4 DMT23110
         ST    R0,RNSAVE           Stash word across $PUT      SML2NJE4 DMT23120
         STM   R5,R6,RNSAVE+4      Stash lengths across $PUT   SML2NJE4 DMT23130
         ST    R8,RNSAVE+12        Stash segment address       SML2NJE4 DMT23140
         BAL   R14,$PUT            Write out segment           SML2NJE4 DMT23150
         L     R8,RNSAVE+12        Retrieve segment address    SML2NJE4 DMT23160
         LM    R5,R6,RNSAVE+4      Retrieve stashed lengths    SML2NJE4 DMT23170
         L     R0,RNSAVE           Retrieve stashed word       SML2NJE4 DMT23180
         ST    R0,0(R6,R8)         Restore word after segment  SML2NJE4 DMT23190
         IC    R1,RNSEGNUM         Get last segment number     SML2NJE4 DMT23200
         LA    R1,1(,R1)           Increment segment number    SML2NJE4 DMT23210
         STC   R1,RNSEGNUM         Store next segment number   SML2NJE4 DMT23220
         AR    R8,R6               Push past this segment      SML2NJE4 DMT23230
         SH    R8,=AL2(NJEPSIZE)   Leave space for next prefix SML2NJE4 DMT23240
         SR    R5,R6               Reduce total by segment len SML2NJE4 DMT23250
         BNZ   RNJELOOP            Go again if any remaining   SML2NJE4 DMT23260
         B     RDLOOP              Get next header or data     SML2NJE4 DMT23270
*                                                              SML2NJE4 DMT23280
MSG928   EQU   *                                               SML2NJE4 DMT23290
         L     R8,RDEVTAG          Get tag addressability      SML2NJE4 DMT23300
         LH    R0,TAGID            Get spool file id           SML2NJE4 DMT23310
         CVD   R0,AXSCVD           Convert spool id to BCD     SML2NJE4 DMT23320
         UNPK  AXSFILE,AXSCVD      Make number printable       SML2NJE4 DMT23330
         OI    AXSFILE+3,X'F0'     Ensure last digit is too    SML2NJE4 DMT23340
         MVC   AXSRECS,BLANK       Clear unused characters     SML2NJE4 DMT23350
         LH    R0,ARNJEHDR+NJEPSIZE+NJHGJID-NJHGDSEC Orig spid SML2NJE4 DMT23360
         CVD   R0,AXSCVD           Convert spool id to BCD     SML2NJE4 DMT23370
         UNPK  AXSRECS(4),AXSCVD   Make number printable       SML2NJE4 DMT23380
         OI    AXSRECS+3,X'F0'     Ensure last digit is too    SML2NJE4 DMT23390
         MSGX  928,(AXSFILE,AXSRECS,AXSLINK) Virtual storage   SML2NJE4 DMT23400
         OI    RDEVSOPT,HOLD+1     Specify hold/keep on close  SML2NJE4 DMT23410
         B     RDCLOSE             Go close file and give up   SML2NJE4 DMT23420
*                                                                       DMT23430
RDNOTNOP EQU   *                                               SML2NJE4 DMT23440
         TM    RSW1,UTRANS         ARE WE SENDING PUNCH OUTPUT?         DMT23450
         BNO   RDLOP0              NO CONTINUE                          DMT23460
         MVI   RCTTSRC1,X'80'      Reset punch SRCB after hdr  SML2NJE4 DMT23470
         MVC   RCTTCT1,=H'81'      Length for punch (+length)  SML2NJE4 DMT23480
         MVI   RCTTDTA1,80         Record length at beginning  SML2NJE4 DMT23490
RDLOP0   EQU   *                                                        DMT23500
         TM    RSW1,PTRANS         ARE WE SENDING PRINT?                DMT23510
         BNO   RDLOP1              NO OKAY TO PUT                       DMT23520
         LH    R8,RCTCCWCT         Get length of PRT data      SML2NJE4 DMT23530
         LA    R8,1(,R8)           Include CC byte in length   SML2NJE4 DMT23540
         STC   R8,RCTTDTA1         Record length byte to tank  SML2NJE4 DMT23550
         LA    R8,1(,R8)           Include record length byte  SML2NJE4 DMT23560
         STH   R8,RCTTCT1          Store tank length           SML2NJE4 DMT23570
         MVC   RCTTDTA1+1(1),RCTOPCOD Put opcode in tank (CC)  SML2NJE4 DMT23580
         MVI   RCTTSRC1,X'90'      SRCB for machine CC         SML2NJE4 DMT23590
         SPACE 1                                                        DMT23600
RDLOP1   EQU   *                                                        DMT23610
         LA    R8,RCTTANK1         GET THE TANK ADDRESS                 DMT23620
         BAL   R14,$PUT            AND WRITE THE TANK                   DMT23630
         CLI   RDRCMD,X'00'        ANY COMMAND PENDING?                 DMT23640
         BE    RDLOOP              NO CONTINUE                          DMT23650
         TM    RDRCMD,RBACKCNT     BACKSPAC COUNT?                      DMT23660
         BO    RBACKUP             YES PROCESS IT                       DMT23670
         TM    RDRCMD,RFWDCNT      FORWARD SPACE COUNT?                 DMT23680
         BO    RGOFWD              YES PROCESS IT                       DMT23690
         TM    RDRCMD,RBACKFIL     BACKSPAC FILE?                       DMT23700
         BO    RDBACKFL            GO DO IT                             DMT23710
         TM    RDRCMD,RFLSHALL     FLUSH ALL?                           DMT23720
         BNO   RDLOP3              NO CONTINUE                          DMT23730
         OI    RDEVSOPT,ALL        INDICATE FLUSH ALL IN RDR            DMT23740
         B     RDFLUSH        GO DO IT                         @VA04039 DMT23750
RDLOP3   EQU   *                                                        DMT23760
         TM    RDRCMD,RFLSHOLD     FLUSH AND HOLD?                      DMT23770
         BNO   RDCKFLSH       MIGHT BE FLUSH COPY              @VA03276 DMT23780
         OI    RDEVSOPT,HOLD       INDICATE FLUSH AND HOLD              DMT23790
         B     RDFLUSH        GO DO IT                         @VA04039 DMT23800
RDCKFLSH EQU   *                                               @VA03276 DMT23810
         TM    RDRCMD,RFLSHCPY FLUSH COPY?                     @VA03276 DMT23820
         BO    RDFLUSH        YES..GO DO IT                    @VA03276 DMT23830
         B     RDLOOP         CONTINUE                         @VA03276 DMT23840
         EJECT                                                          DMT23850
RDFLUSH  EQU   *                                                        DMT23860
         NI    RDRCMD,255-RFLSHALL-RFLSHOLD-RFLSHCPY RESET CMD BYTE     DMT23870
         MVC   MSGLINK(8),RDRCMDLK MOVE RESPONSE ID INTO MSG            DMT23880
         CLC   CMDFID(4),AXSFILE   RIGHT FILE?                          DMT23890
         BNE   RDFLSHER            NO..ERROR                            DMT23900
         MSGX  580,AXSFILE         WRITE THE FLUSH MSG                  DMT23910
         NI    RSW1,255-CLINE      No buffer present           SML2NJE4 DMT23920
         OI    RCTECB,TCTBUSY      Set reader busy for waiting SML2NJE4 DMT23930
         OI    RSW1,RINIT          Initial call has occurred   SML2NJE4 DMT23940
         MVC   RCTTCT1,=F'0'       Set end of file indicator   SML2NJE4 DMT23950
         MVC   RCTENTY(2),RACN6    Return if wait for buffers  SML2NJE4 DMT23960
RLOC6    EQU   *                                               SML2NJE4 DMT23970
         MVI   RCTWFB,X'00'        Reset waiting for buffer sw SML2NJE4 DMT23980
         LA    R8,RCTTANK1         Get tank address            SML2NJE4 DMT23990
         BAL   R14,$TPPUT          Put the tank                SML2NJE4 DMT24000
         BNZ   RDCLOSE             Go close RDR / purge file   SML2NJE4 DMT24010
         B     RDWAITBF            Go wait for buffer          SML2NJE4 DMT24020
         SPACE                                                          DMT24030
RDFLSHER EQU   *                                                        DMT24040
         MSGX  581,CMDFID          WRITE ERROR MSG                      DMT24050
         TM    RSW1,RWAITACK       Are we waiting for file ACK SML2NJE4 DMT24060
         BZ    RDLOOP              Not waiting. Go read more.  SML2NJE4 DMT24070
         NI    RDRCMD,255-RFLSHCPY+RFLSHALL+RFLSHOLD Clear cmd SML2NJE4 DMT24080
         B     RDWAIT              Go back to waiting for ACK  SML2NJE4 DMT24090
         EJECT                                                          DMT24100
RDEOF    EQU   *                                                        DMT24110
*                                                              SML2NJE4 DMT24120
*        Create NJE job trailer and send it after the file     SML2NJE4 DMT24130
*                                                              SML2NJE4 DMT24140
         TM    RSW1,SANDF          Is this store and fwd file? SML2NJE4 DMT24150
         BO    RNONJET             Skip sending NJE job trailerSML2NJE4 DMT24160
         L     R8,RDEVTAG          Get address of tag          SML2NJE4 DMT24170
         LA    R0,XJE3JEJT         Code for routine BLDNJEJT      *XJE  DMT24180
         L     R15,=A(DMTXJE3)     -> NJE functions csect         *XJE  DMT24190
         BALR  R14,R15             Build NJE job trailer       SML2NJE4 DMT24200
*                                                              SML2NJE4 DMT24210
         LA    R8,RCTTANK1         Get tank address            SML2NJE4 DMT24220
         BAL   R14,$PUT            Write the tank to tp buffer SML2NJE4 DMT24230
RNONJET  EQU   *                                               SML2NJE4 DMT24240
*                                                              SML2NJE4 DMT24250
         MVI   RCTTSRC1,X'80'      Reset SRCB for EOF record   SML2NJE4 DMT24260
RDEOF0   EQU   *                                                        DMT24270
         NI    RSW1,255-CLINE      NO BUFFER PRESENT                    DMT24280
         OI    RCTECB,TCTBUSY      SET READER BUSY FOR WAITING          DMT24290
         MVI   RCTWFB,X'00'        RESET WAITING FOR BUFFER SW          DMT24300
         OI    RSW1,RINIT          INITIAL CALL HAS OCCURED             DMT24310
         MVC   RCTTCT1,=F'0'       SET END OF FILE INDICATOR            DMT24320
         MVC   RCTENTY(2),RACN2                                         DMT24330
RLOC2    EQU   *                                                        DMT24340
         MVI   RCTWFB,X'00'   RESET WAITING FOR BUFFERS SW     @VA03306 DMT24350
         LA    R8,RCTTANK1         GET TANK ADDRESS                     DMT24360
         BAL   R14,$TPPUT          PUT THE TANK                         DMT24370
         BNZ   RDWFACK             Go wait for ACK             SML2NJE4 DMT24380
RDWAITBF MVI   RCTWFB,X'FF'        Show waiting for a buffer   SML2NJE4 DMT24390
RDWAIT   EQU   *                   Go wait in general          SML2NJE4 DMT24400
         L     R8,RCTCOM           GET COMMUTATOR ENTRY                 DMT24410
         MVI   1(R8),CLOSE         AND CLOSE THE GATE                   DMT24420
         B     RCTRTN              GO WAIT FOR A BUFFER                 DMT24430
         EJECT                                                          DMT24440
RDBACKFL EQU   *                                                        DMT24450
         USING SPLINK,R1           GET SPLINK ADDRESSABILITY            DMT24460
         L     R1,RDEVFIOA         GET FILE I/O AREA ADDRESS            DMT24470
         L     R8,RDEVTAG          GET TAG ADDRESS                      DMT24480
         LH    R2,TAGDEV           GET READER ADDRESS                   DMT24490
         LA    R3,X'14'            INDICATE BACKSPACE FILE              DMT24500
*********DIAG  R1,R2,X'14'         COMMAND SPOOL READER                 DMT24510
RDBKFIL1 EQU   *                                                        DMT24520
         NI    RSW1,255-CLINE      INDICATE BLOCK NOT PRESENT           DMT24530
RDBKFIL2 EQU   *                                                        DMT24540
         LA    R8,RDLOOP           INDICATE RETURN POINT                DMT24550
RDBKMSG  EQU   *                                                        DMT24560
         MVC   MSGLINK(8),RDRCMDLK MOVE IN RESPONSE LINKID              DMT24570
         MSGX  510,AXSFILE         WRITE BACKSPAC MSG                   DMT24580
         NI    RDRCMD,255-RBACKFIL-RBACKCNT RESET CMD FLAGS             DMT24590
         BR    R8                  AND CONTINUE                         DMT24600
         EJECT                                                          DMT24610
RBACKUP  EQU   *                                                        DMT24620
         L     R1,RDEVFIOA         GET FIOA ADDR                        DMT24630
         L     R8,RDEVTAG          GET READER TAG ADDRESS               DMT24640
         L     R3,SPRECNUM         AND NUMBER OF RECORDS                DMT24650
         S     R3,VMSPNUM          SUBSTRACT WHATS LEFT                 DMT24660
         BZ    RDBKPAGA            ALL DONE WITH THIS PAGE              DMT24670
         LA    R4,SPRECNUM+4       GET DATA ADDR                        DMT24680
         ST    R4,VMSPANCH         STORE ANCHOR FOR UNPACK              DMT24690
         ST    R4,VMSPNEXT         AND THE NEXT DATA STRING             DMT24700
         ST    R3,VMSPNUM          STORE THE NEW COUNT                  DMT24710
         OI    RSW1,CLINE         FILE ALREADY HERE           @VA10237  DMT24720
         TM    TAGINDEV,TYPPUN     IS IT A PUNCH FILE?                  DMT24730
         BNO   RBACKCN2            NO..MUST BE PRINT                    DMT24740
         L     R3,VMSPNUM          GET THE CURRENT COUNT                DMT24750
         B     RBACKCN3            AND CONTINUE                         DMT24760
         SPACE 1                                                        DMT24770
RBACKCN1 EQU   *                                                        DMT24780
         LPR   R3,R3               MAKE POSITIVE                        DMT24790
         ST    R3,RDRCMDCT         UPDATE NUMBER OF BACKS               DMT24800
RDBKPAGA EQU   *                                                        DMT24810
         BAL   R14,RDBKPAGE        GO BACKPAGE                          DMT24820
RBACKCN2 EQU   *                                                        DMT24830
         TM    TAGINDEV,TYPPRT     IS IT A PRINT FILE?                  DMT24840
         BO    RCNTSKP             YES..MUST SKIP PAGES NOT RECS        DMT24850
         L     R3,SPRECNUM         GET THE NEW NUM OF RECORDS           DMT24860
RBACKCN3 EQU   *                                                        DMT24870
         S     R3,RDRCMDCT         SUBSTRACT NEW NUM                    DMT24880
         LTR   R3,R3               ARE WE DONE?                         DMT24890
         BNP   RBACKCN1            NO CONTINUE                          DMT24900
         BAL   R14,RDBKPCON        RESET TO BEGINNING OF PAGE           DMT24910
RBACKSK  EQU   *                                                        DMT24920
         LA    R0,XJE2VMDB         Code 08=VMDEBLOK               *XJE  DMT24930
         L     R15,=A(DMTXJE2)     -> external routines csect     *XJE  DMT24940
         BALR  R14,R15             Go get a record                *XJE  DMT24950
         TM    TAGINDEV,TYPPUN     IS IT A PUNCH FILE?                  DMT24960
         BO    RBACKDWN            YES COUNT ALL                        DMT24970
         CLI   RCTOPCOD,X'89'      PRINT AND SKIP TO CHAN 1?            DMT24980
         BE    RBACKDWN            YES COUNT IT                         DMT24990
         CLI   RCTOPCOD,X'8B'      IMMED SKIP TO CHAN 1?                DMT25000
         BNE   RBACKSK             NO TRY ANOTHER                       DMT25010
RBACKDWN EQU   *                                                        DMT25020
         BCT   R3,RBACKSK          DOWN BY ONE                          DMT25030
         LA    R8,RDLOPB           INDICATE RETURN POINT                DMT25040
         CLI   RCTOPCOD,X'8B'      IS IT A SKIP IMMED?                  DMT25050
         BE    RDBKMSG             YES..CONTINUE                        DMT25060
         MVI   RCTOPCOD,X'8B'      MAKE IT A SKIP IMMED..               DMT25070
         MVI   RCTTDTA1,C' '       AND ONE CHAR OF DATA                 DMT25080
         LA    R1,1                ONE BYTE OF DATA                     DMT25090
         STH   R1,RCTCCWCT         AND STORE IN CCW                     DMT25100
         B     RDBKMSG             ALL DONE                             DMT25110
         EJECT                                                          DMT25120
RCNTSKP  EQU   *                                                        DMT25130
         SR    R3,R3               ZERO OUT ACCUMLATOR                  DMT25140
RCNTSKP1 EQU   *                                                        DMT25150
         LA    R0,XJE2VMDB         Code 08=VMDEBLOK               *XJE  DMT25160
         L     R15,=A(DMTXJE2)     -> external routines csect     *XJE  DMT25170
         BALR  R14,R15             Go get a record                *XJE  DMT25180
         CLI   RCTOPCOD,X'89'      PRINT AND SKIP TO CHANNEL 1?         DMT25190
         BE    RCNTSKPC            YES COUNT IT                         DMT25200
         CLI   RCTOPCOD,X'8B'      IMMED SKIP TO CHANNEL 1?             DMT25210
         BE    RCNTSKPC            YES COUNT IT                         DMT25220
RCNTSKPX EQU   *                                                        DMT25230
         ICM   R0,B'1111',VMSPNUM  ALL DONE WITH PAGE?                  DMT25240
         BNZ   RCNTSKP1            NO CONTINUE                          DMT25250
         B     RBACKCN3            BR BACK TO MAIN CODE                 DMT25260
         SPACE 1                                                        DMT25270
RCNTSKPC EQU   *                                                        DMT25280
         LA    R3,1(,R3)           UP SKIP COUNT BY 1                   DMT25290
         B     RCNTSKPX            AND JOIN COMMON CODE                 DMT25300
         SPACE 1                                                        DMT25310
RDBKPAGE EQU   *                   BACK UP A PAGE SUBROUTINE            DMT25320
         STM   R0,R15,VMDESAVE     MIGHT AS WELL SAVE THEM ALL          DMT25330
         L     R1,RDEVFIOA         GET FILE I/O AREA ADDRESS            DMT25340
         L     R8,RDEVTAG          GET TAG ADDRESS                      DMT25350
         LH    R2,TAGDEV           GET READER ADDRESS                   DMT25360
         LA    R3,X'18'            INDICATE BACKSPACE PAGE              DMT25370
*********DIAG  R1,R2,X'14'         COMMAND SPOOL READER                 DMT25380
         BC    4,RDBKPAG2          ALL DONE BEGINNING OF FILE           DMT25390
RDBKPAG1 EQU   *                                                        DMT25400
         L     R8,SPRECNUM         PICKUP SPRECNUM FROM NEW BLOCK       DMT25410
         ST    R8,VMSPNUM          PICKUP COUNT OF REMAINING CCWS       DMT25420
         LA    R8,SPRECNUM+4       SETP OVER POINTERS IN SPOOL BLOCK    DMT25430
         ST    R8,VMSPANCH         TO PICKUP CURRENT CCW ANCHOR         DMT25440
         ST    R8,VMSPNEXT         CCW POINTER AND NEXT                 DMT25450
         OI    RSW1,CLINE          TO INDICATE BLOCK PRESENT            DMT25460
         LM    R0,R15,VMDESAVE     RESTORE REGS                         DMT25470
         BR    R14                 AND RETURN                           DMT25480
         SPACE 1                                                        DMT25490
RDBKPAG2 EQU   *                                                        DMT25500
         LA    R14,RDBKFIL2        SET RETURN POINT                     DMT25510
         SPACE 1                                                        DMT25520
RDBKPCON EQU   *                                                        DMT25530
         STM   R0,R15,VMDESAVE     SAVE REGISTERS                       DMT25540
         B     RDBKPAG1            AND SIMULATE A PAGE BACK             DMT25550
         EJECT                                                          DMT25560
RGOFWD   EQU   *                                                        DMT25570
         L     R1,RDRCMDCT         GET FWD COUNT                        DMT25580
         L     R8,RDEVTAG          AND THE TAG ADDR                     DMT25590
RGOFWDLP EQU   *                                                        DMT25600
         LA    R0,XJE2VMDB         Code 08=VMDEBLOK               *XJE  DMT25610
         L     R15,=A(DMTXJE2)     -> external routines csect     *XJE  DMT25620
         BALR  R14,R15             Go get a record                *XJE  DMT25630
         LTR   R15,R15             Was it end-of-file?            *XJE  DMT25640
         BNZ   RDGODNE             ALL DONE EOF                         DMT25650
         TM    TAGINDEV,TYPPUN     IS IT A PUNCH FILE?                  DMT25660
         BO    RGOCNT              COUNT ALL RECORDS                    DMT25670
         CLI   RCTOPCOD,X'89'      PRINT AND SKIP TO CHANNEL 1?         DMT25680
         BE    RGOCNT              YES COUNT IT                         DMT25690
         CLI   RCTOPCOD,X'8B'      IMMED SKIP TO CHANNEL 1?             DMT25700
         BNE   RGOFWDLP            NO..CONTINUE                         DMT25710
RGOCNT   EQU   *                                                        DMT25720
         BCT   R1,RGOFWDLP         REDUCE REC CNT BY 1 AND CONT         DMT25730
RDGODNE  EQU   *                                                        DMT25740
         CLI   RCTOPCOD,X'8B'      IS IT A SKIP IMMED?                  DMT25750
         BE    RDFWMSG             YES..CONTINUE                        DMT25760
         MVI   RCTOPCOD,X'8B'      MAKE IT A SKIP IMMED..               DMT25770
         MVI   RCTTDTA1,C' '       AND ONE CHAR OF DATA                 DMT25780
         LA    R1,1                ONE BYTE OF DATA                     DMT25790
         STH   R1,RCTCCWCT         AND STORE IN CCW                     DMT25800
RDFWMSG  EQU   *                                                        DMT25810
         MVC   MSGLINK(8),RDRCMDLK MOVE IN RESPONSE LINKID              DMT25820
         MSGX  600,AXSFILE         WRITE FWD SPAC MSG                   DMT25830
         NI    RDRCMD,255-RFWDCNT  RESET CMD BYTE                       DMT25840
         CLI   RCTOPCOD,X'8B'      IS IT A SKIP IMMED?                  DMT25850
         BE    RDLOPB              YES..CONTINUE                        DMT25860
         MVI   RCTOPCOD,X'8B'      MAKE IT A SKIP IMMED..               DMT25870
         MVI   RCTTDTA1,C' '       AND ONE CHAR OF DATA                 DMT25880
         LA    R1,1                ONE BYTE OF DATA                     DMT25890
         STH   R1,RCTCCWCT         AND STORE IN CCW                     DMT25900
         B     RDLOPB              AND CONTINUE                         DMT25910
         DROP  R1                                                       DMT25920
         EJECT                                                          DMT25930
RDERR1   EQU   *                                                        DMT25940
         NI    RCTECB,X'FF'-TCTBUSY  TURN OFF RDR ECB BUSY    @VA10416  DMT25950
         TM    RSW1,RACTIV         WAS A FILE EVER OPENED?              DMT25960
         BNO   RDERR2              NO..EXIT AGAIN                       DMT25970
         TM    RSW1,RINIT          HAS READER BEEN CALLED ONCE?         DMT25980
         BNO   RDERR2              NOPE                                 DMT25990
         MVC   RCTTCT1,=F'0'       SET END OF FILE INDICATOR            DMT26000
         MVC   RCTENTY(2),RACN3    PREPARE FOR REJECT ON SENDING        DMT26010
RLOC3    EQU   *                                                        DMT26020
         LA    R8,RCTTANK1         PUT TANK ADDR IN PARAMETER REG       DMT26030
         BAL   R14,$TPPUT          SEND EOF SIGNAL                      DMT26040
         BNZ   RDERR2              OPEN WENT OK...CONTINUE              DMT26050
         B     RDWAITBF            Go wait for buffer          SML2NJE4 DMT26060
         SPACE 1                                                        DMT26070
RDERR2   EQU   *                                                        DMT26080
         MVI   RCTWFB,X'00'   RESET WAITING FOR BUFFERS SW     @VA03306 DMT26090
         OI    RSW1,RINIT          INITIAL CALL OVER                    DMT26100
         MVC   RCTENTY(2),RACN4    SETUP FOR DELAY                      DMT26110
         NI    MASTERSW,255-READER INDICATE READER CLOSED               DMT26120
         NI    RSW1,255-RACTIV     INDICATE NO READER ACTIVE            DMT26130
         B     RDWAIT              Go wait                     SML2NJE4 DMT26140
         EJECT                                                          DMT26150
RREOPEN  EQU   *                                                        DMT26160
         MVC   RCTENTY(2),RACN5    SETUP FOR DELAY                      DMT26170
         B     RDWAITBF            Go wait for buffer          SML2NJE4 DMT26180
         SPACE 1                                                        DMT26190
RLOC5    EQU   *                                                        DMT26200
         MVI   RCTWFB,X'00'        RESET WAITING FOR BUFFER             DMT26210
         B     ROPEN               GO TRY REOPEN                        DMT26220
RDWFACK  EQU   *                                               SML2NJE4 DMT26230
         MVC   RCTENTY(2),RACN7    Set up for re-entry         SML2NJE4 DMT26240
         OI    RSW1,RWAITACK       Flag waiting for ACK        SML2NJE4 DMT26250
         B     RDWAIT              Go wait for ACK             SML2NJE4 DMT26260
RLOC7    EQU   *                                               SML2NJE4 DMT26270
         CLI   RDRCMD,RFLSHCPY+RFLSHALL+RFLSHOLD We flushing?  SML2NJE4 DMT26280
         BNE   RDNOFLSH            Not flushing                SML2NJE4 DMT26290
         MVC   MSGLINK(8),RDRCMDLK Move response dest into msg SML2NJE4 DMT26300
         CLC   CMDFID(4),AXSFILE   Right file? (wrong var!)    SML2NJE4 DMT26310
         BNE   RDFLSHER            Wrong file too.             SML2NJE4 DMT26320
         TM    RDRCMD,RFLSHALL     Flushing all files?         SML2NJE4 DMT26330
         BZ    RDNFLALL            Not flushing all files      SML2NJE4 DMT26340
         OI    RDEVSOPT,ALL        Specify flush all files     SML2NJE4 DMT26350
RDNFLALL EQU   *                                               SML2NJE4 DMT26360
         TM    RDRCMD,RFLSHOLD     Flush file and hold?        SML2NJE4 DMT26370
         BZ    RDNFLHLD            Not flush and hold          SML2NJE4 DMT26380
         OI    RDEVSOPT,HOLD       Specify flush and hold      SML2NJE4 DMT26390
RDNFLHLD EQU   *                                               SML2NJE4 DMT26400
         NI    RDRCMD,255-RFLSHALL-RFLSHOLD-RFLSHCPY Reset cmd SML2NJE4 DMT26410
         NI    RSW1,255-RWAITACK   Clear waiting for ACK flag  SML2NJE4 DMT26420
         MSGX  580,AXSFILE         File $ processing terminatedSML2NJE4 DMT26430
         B     RDCLOSE             Go close RDR / spool file   SML2NJE4 DMT26440
RDNOFLSH EQU   *                                               SML2NJE4 DMT26450
         TM    RSW1,RWAITACK       Still waiting for ACK?      SML2NJE4 DMT26460
         BO    RDWAIT              Go and wait some more       SML2NJE4 DMT26470
         MSGX  147,(AXSFILE,AXSLINK) Write sent message        SML2NJE4 DMT26480
RDCLOSE  EQU   *                                               SML2NJE4 DMT26490
         LA    R0,XJE2AXSP         Code 00=AXSPURGE               *XJE  DMT26500
         L     R15,=A(DMTXJE2)     -> external routines csect     *XJE  DMT26510
         BALR  R14,R15             Purge spool file               *XJE  DMT26520
         NI    RSW1,255-RINIT-PTRANS-UTRANS-SANDF Ditch flags  SML2NJE4 DMT26530
         NI    MASTERSW,255-READER Turn off reader active      SML2NJE4 DMT26540
         B     READ1               Go get another file         SML2NJE4 DMT26550
         SPACE 1                                                        DMT26560
CLINE    EQU   X'80'               BLOCK PRESENT IN DEBLOCK BUFFER      DMT26570
RINIT    EQU   X'40'               INITIAL CALL HAS BEEN MADE           DMT26580
RACTIV   EQU   X'20'               READER ACTIVE                        DMT26590
PTRANS   EQU   X'10'               TRANSMITTING PRINT FILE              DMT26600
UTRANS   EQU   X'08'               TRANSMITTING PUNCH FILE              DMT26610
HEADFLAG EQU   X'04'               TRANSMITTING HEADER                  DMT26620
SANDF    EQU   X'02'               Store and forward file      SML2NJE4 DMT26630
RWAITACK EQU   X'01'               Waiting for file sent ACK   SML2NJE4 DMT26640
         SPACE 1                                                        DMT26650
RACN1    DC    S(RLOC1)            RETURN ENTRY POINT                   DMT26660
RACN2    DC    S(RLOC2)            RETURN ENTRY POINT                   DMT26670
RACN3    DC    S(RLOC3)            RETURN ENTRY POINT                   DMT26680
RACN4    DC    S(READ1)            RETURN ENTRY POINT                   DMT26690
RACN5    DC    S(RLOC5)            RETURN ENTRY POINT                   DMT26700
RACN6    DC    S(RLOC6)            Return entry point          SML2NJE4 DMT26710
RACN7    DC    S(RLOC7)            Return entry point          SML2NJE4 DMT26720
         EJECT                                                          DMT26730
*.                                                                      DMT26740
*                                                                       DMT26750
* ENTRY NAME -                                                          DMT26760
*                                                                       DMT26770
*        $WRTN1                                                         DMT26780
*                                                                       DMT26790
* FUNCTION -                                                            DMT26800
*                                                                       DMT26810
*        THIS ROUTINE WILL WRITE RECEIVED MSGS TO THE RSCS              DMT26820
*        OPERATOR IF RJE MODE OR PASS COMMANDS TO DMTREX FOR            DMT26830
*        EXECUTION IF OPERATING IN HOST MODE.  THESE COMMANDS OR        DMT26840
*        MESSAGES ARE DEQUEUED FROM THE CONSOLE TCT.                    DMT26850
*                                                                       DMT26860
* CALLS TO OTHER ROUTINES -                                             DMT26870
*                                                                       DMT26880
*        DMTWAT - TO WAIT FOR AN EVENT COMPLETION                       DMT26890
*        DMTGIV - TO INITIATE A GIVE REQUEST                            DMT26900
*                                                                       DMT26910
* OPERATION -                                                           DMT26920
*                                                                       DMT26930
*        1. GET A RECEIVED TANK VIA CALL TO $GETTNK                     DMT26940
*                                                                       DMT26950
*        2. IF HOST MODE TREAT LIKE COMMAND AND PASS TO DMTREX          DMT26960
*           FOR EXECUTION.                                              DMT26970
*                                                                       DMT26980
*        3. IF RJE MODE TREAT LIKE MSG AND WRITE MSG 170.               DMT26990
*                                                                       DMT27000
*        4. FREE THE TANK AND EXIT TO COMMUTATOR.                       DMT27010
*                                                                       DMT27020
* RESPONSES -                                                           DMT27030
*                                                                       DMT27040
*        DMTXJE170I  FROM 'LINKID':  (MSG TEXT)                HRC000DT DMT27050
*                                                                       DMT27060
* ERROR MESSAGES -                                                      DMT27070
*                                                                       DMT27080
*        NONE                                                           DMT27090
*                                                                       DMT27100
*.                                                                      DMT27110
         SPACE 3                                                        DMT27120
         USING TANKDSEC,R8         GET TANK ADDRESSABILITY              DMT27130
$WRTN1   DS    0H                                                       DMT27140
WINIT    DS    0H                  CONSOLE LOOP ENTRY POINT             DMT27150
         MVI   $WCOMM1+1,CLOSE     CLOSE THE GATE                       DMT27160
WTANKTST EQU   *                                                        DMT27170
         CLI   WCTTNKCT,0          TEST FOR TANK                        DMT27180
         BNE   WGETTANK            IF WE HAVE ONE GET IT                DMT27190
         MVC   WCTENTY(2),WACN1    SET UP FOR WAIT                      DMT27200
         B     WCTRTN              AND EXIT                             DMT27210
         EJECT                                                          DMT27220
WGETTANK EQU   *                                                        DMT27230
         BAL   R14,$GETTNK         WAIT FOR THE NEXT TANK               DMT27240
         LH    R6,TANKCNT          GET DATA COUNT                       DMT27250
         CH    R6,=H'30'           Is tank big enough for NMR? SML2NJE4 DMT27260
         BL    WGETRET             No use. Free tank, return   SML2NJE4 DMT27270
         CLC   TANKDATA+4(8),LOCATION Is NMR for this node?    SML2NJE4 DMT27280
         BE    WFORHERE            Message or command for here SML2NJE4 DMT27290
         LA    R1,TANKDATA+4       Get address of destination  SML2NJE4 DMT27300
WGETLINK EQU   *                                               SML2NJE4 DMT27310
*        MSGX  302
         LA    R0,8                Get length of destination   SML2NJE4 DMT27320
         LA    R2,302              Code for link is not definedSML2NJE4 DMT27330
         LR    R3,R1               Stash destination address   SML2NJE4 DMT27340
         LA    R13,COMSAVE         Get common save area        SML2NJE4 DMT27350
*DEL     L     R15,TCOM            GET COMMON ROUTINES LIST       *XJE4 DMT27360
         L     R15,GLINKREQ        Get address of routine      SML2NJE4 DMT27370
         BALR  R14,R15             Call routine to find link   SML2NJE4 DMT27380
         LTR   R15,R15             Link to destination found?  SML2NJE4 DMT27390
         BNZ   WTRYROUT            No direct link. Route maybe?SML2NJE4 DMT27400
         USING LINKTABL,R1                                     SML2NJE4 DMT27410
         TM    LFLAG,LCONNECT      Is link connected?          HRC031DT DMT27420
         BO    WGOTLINK            Link is active              SML2NJE4 DMT27430
         DROP  R1                                              SML2NJE4 DMT27440
*        MSGX  303
         LA    R2,303              Code for link is not active SML2NJE4 DMT27450
         LR    R1,R3               Restore destination address SML2NJE4 DMT27460
WTRYROUT EQU   *                                               SML2NJE4 DMT27470
         LA    R0,8                Get length of destination   SML2NJE4 DMT27480
*DEL     L     R15,TCOM            GET COMMON ROUTINES LIST       *XJE4 DMT27490
         L     R15,GROUTREQ        Get address of routine      SML2NJE4 DMT27500
         BALR  R14,R15             Look up route to destinationSML2NJE4 DMT27510
         LTR   R15,R15             Was route found?            SML2NJE4 DMT27520
         BNZ   WRTERROR            Routing error encountered   SML2NJE4 DMT27530
**DEL    USING RTE,R1                                             *XJE  DMT27540
**DEL    LA    R1,ROUTNEXT         Get address of next node       *XJE  DMT27550
**DEL    DROP  R1                                                 *XJE  DMT27560
* R1 contains selected link on return from GROUTREQ               *XJE
         B     WGETLINK            Got route. Now get link.    SML2NJE4 DMT27570
WRTERROR EQU   *                                               SML2NJE4 DMT27580
         STH   R2,WERRCODE         Save error code             SML2NJE4 DMT27590
         MVC   WERRLINK,0(R1)      Copy link name to error msg SML2NJE4 DMT27600
         LA    R1,WERRCODE         Get address of error block  SML2NJE4 DMT27610
         LA    R0,4+8              Fixed + variable block size SML2NJE4 DMT27620
         BAL   R14,MSG             Issue failure message       SML2NJE4 DMT27630
         B     WGETRET             Free tank and return        SML2NJE4 DMT27640
WGOTLINK EQU   *                                               SML2NJE4 DMT27680
         USING LINKTABL,R1                                     SML2NJE4 DMT27690
         L     R0,LTCBA            Get task id                    *XJE  DMT27700
         DROP  R1                                              SML2NJE4 DMT27710
         LH    R1,TANKCNT          Get size of data in tank    SML2NJE4 DMT27720
         LA    R1,3(,R1)           Plus length, function etc   SML2NJE4 DMT27730
         STC   R1,TANKRCB          Store message element lengthSML2NJE4 DMT27740
         MVI   TANKSRCB,NMR        Code for NMR - HACK!        SML2NJE4 DMT27750
         MVI   TANKCNT+1,NMR       Code for NMR - HACK!        SML2NJE4 DMT27760
         LA    R1,TANKRCB          Get message element address SML2NJE4 DMT27770
         L     R15,ALERTREQ        Get address of routine      SML2NJE4 DMT27780
         BALR  R14,R15             Tell link driver about NMR  SML2NJE4 DMT27790
         B     WGETRET             Free tank and return        SML2NJE4 DMT27800
WFORHERE EQU   *                                               SML2NJE4 DMT27810
         TM    TANKDATA,NMRFLAGC   Is this a msg or a command? SML2NJE4 DMT27820
         BNO   WGET2               It is a message             SML2NJE4 DMT27830
WGET1    EQU   *                                                        DMT27840
         SH    R6,=H'30'           Subtract length of NMR hdr  SML2NJE4 DMT27850
         LTR   R1,R6               SAVE FOR MSG PROCESSOR               DMT27860
         BZ    WGET1A              NULL CMD                             DMT27870
         BCTR  R6,0                REDUCE BY 1 FOR EXECUTE              DMT27880
         EX    R6,WTOMOV           MOVE INTO OUTPUT BUFFER              DMT27890
WGET1A   EQU   *                                                        DMT27900
         LA    R1,4+8+8-1(,R1)     Include length of header    HRC016DT DMT27910
         STC   R1,WTOMBUF          AND STORE IN GIVE REQUEST BUF        DMT27920
         MVC   WTOMNODE,TANKDATA+21 Copy command source node   SML2NJE4 DMT27930
         MVC   WTOMUSER,TANKDATA+13 Copy command source userid SML2NJE4 DMT27940
         XC    WTOMCMD(4),WTOMCMD  CLEAR OUT SYNCH LOCK                 DMT27950
         LA    R1,WTOMCMD          GET BUFFER ADDR                      DMT27960
         L     R15,GIVEREQ         GET GIVE REQUEST PROCESSOR           DMT27970
         BALR  R14,R15             AND EXECUTE IT                       DMT27980
*********L     R15,WAITREQ         SYSTEM WAIT PROCESSOR          *XJE  DMT27990
*********BALR  R14,R15             GO WAIT                        *XJE  DMT28000
         B     WGETRET             AND RETURN                           DMT28010
         SPACE 1                                                        DMT28020
WGET2    EQU   *                                                        DMT28030
         SH    R6,=H'30'           Subtract length of NMR hdr  SML2NJE4 DMT28040
         MVI   MSGBLK+2,X'80'      Send message to console onlySML2NJE4 DMT28050
         TM    TANKDATA,NMRFLAGT   Destination userid present? SML2NJE4 DMT28060
         BZ    WGET3               Skip over copying userid    SML2NJE4 DMT28070
         MVC   MSGVMID,TANKDATA+13 Copy destination userid     SML2NJE4 DMT28080
         MVI   MSGBLK+2,X'A0'      Send to console and userid  SML2NJE4 DMT28090
WGET3    EQU   *                                               SML2NJE4 DMT28100
         MVI   WTORJMSG+1,170      Assume we are using MSG 170 SML2NJE4 DMT28110
         TM    TANKDATA+2,NMRTYPE4 Source userid present?      SML2NJE4 DMT28120
         BNO   WGET3A              Use MSG 170                 SML2NJE4 DMT28130
         MVI   WTORJMSG+1,171      Change MSG number to 171    SML2NJE4 DMT28140
WGET3A   EQU   *                                               SML2NJE4 DMT28150
         CH    R6,=H'104'     MSG LONGER THAN 104?             @VA03305 DMT28160
         BNH   *+8            NO, OK                           @VA03305 DMT28170
         LA    R6,104         MAKE LENGTH A MAX OF 104         @VA03305 DMT28180
         MVC   WTORJMSG+4(8),TANKDATA+21 Copy msg source node  SML2NJE4 DMT28190
         LTR   R1,R6               Save for later              SML2NJE4 DMT28200
         BZ    WGET4               Skip move if zero length    SML2NJE4 DMT28210
         BCTR  R6,0                REDUCE BY ONE FOR MVC                DMT28220
         EX    R6,WTOMOV1          EXECUTE THE MOVE                     DMT28230
WGET4    EQU   *                                               SML2NJE4 DMT28240
         LA    R1,7(R1)            ROUND UP TO EVEN                     DMT28250
         SRL   R1,3                8 BYTE                               DMT28260
         SLL   R1,3                BOUNDARY                             DMT28270
         LA    R1,12(,R1)          Up for header               HRC001DT DMT28280
         LR    R0,R1               MOVE INTO R1                         DMT28290
         LA    R1,WTORJMSG         GET MSG ADDR                         DMT28300
         BAL   R14,MSG             AND WRITE THE MSG                    DMT28310
         MVI   WTORJBUF,C' '       BLANK FIRST BYTE                     DMT28320
         MVC   WTORJBUF+1(119),WTORJBUF AND THE REST                    DMT28330
WGETRET  EQU   *                                                        DMT28340
         MVC   0(4,R8),$TANKPOL    GET FIRST FREE OFF QUEUE             DMT28350
         ST    R8,$TANKPOL         MAKE THIS ONE THE FIRST              DMT28360
         MVI   $TPGETCM+1,OPEN     OPEN TPGET GATE                      DMT28370
         B     WINIT               GET THE NEXT LINE FOR OUTPUT         DMT28380
         EJECT                                                          DMT28390
WTOMOV   MVC   WTOBUF(0),TANKDATA+30  To be executed by above  SML2NJE4 DMT28400
WTOMOV1  MVC   WTORJBUF(0),TANKDATA+30 To be executed by above SML2NJE4 DMT28410
         EJECT                                                          DMT28420
*.                                                                      DMT28430
*                                                                       DMT28440
* ENTRY NAME -                                                          DMT28450
*                                                                       DMT28460
*        CMDPROC                                                        DMT28470
*                                                                       DMT28480
* FUNCTION -                                                            DMT28490
*                                                                       DMT28500
*        THIS ROUTINE EXECUTES COMMANDS PASSED TO IT IN THE             DMT28510
*        CMDRESP BUFFER AFTER AN ALERT FROM DMTREX INDICATING A         DMT28520
*        CMD HAS BEEN ENTERED.                                          DMT28530
*                                                                       DMT28540
* CALLS TO OTHER ROUTINES -                                             DMT28550
*                                                                       DMT28560
*        NONE                                                           DMT28570
*                                                                       DMT28580
* OPERATION -                                                           DMT28590
*                                                                       DMT28600
*        1. SCAN COMMAND TABLE FOR MATCH.                               DMT28610
*                                                                       DMT28620
*        2. IF FOUND BRANCH TO APPROPRIATE SUBROUTINE TO PROCESS        DMT28630
*           COMMAND.                                                    DMT28640
*                                                                       DMT28650
*        3. UPON RETURN RESET COMMAND IN PROGRESS SWITCH AND RETURN.    DMT28660
*                                                                       DMT28670
* RESPONSES -                                                           DMT28680
*                                                                       DMT28690
*        SEE EACH SUBROUTINE                                            DMT28700
*                                                                       DMT28710
* ERROR MESSAGES -                                                      DMT28720
*                                                                       DMT28730
*        SEE EACH SUBROUTINE                                            DMT28740
*                                                                       DMT28750
*.                                                                      DMT28760
         SPACE 3                                                        DMT28770
         DS    0H                                                       DMT28780
CMDPROC  EQU   *                                                        DMT28790
         MVI   $CMDCOM+1,CLOSE     CLOSE GATE                           DMT28800
         LM    R3,R5,CMDSETUP      PREPARE FOR COMMAND SCAN             DMT28810
CMDSCAN  EQU   *                                                        DMT28820
         CLC   0(1,R3),CMDRESP+1   IS IT THIS ONE                       DMT28830
         BE    CMDCALL             YES                                  DMT28840
         BXLE  R3,R4,CMDSCAN       PREPARE FOR NEXT COMPARE             DMT28850
         B     CMDRET              IGNORE IF NOT FOUND                  DMT28860
         SPACE                                                          DMT28870
CMDCALL  EQU   *                                                        DMT28880
         L     R6,XJELINK          Get link table address      HRC000DT DMT28890
         USING LINKTABL,R6         Link table addressability   SML2NJE3 DMT28900
         MVC   MSGLINK(8),CMDRESP+4 MOVE IN RESPONSE LINKID             DMT28910
         MVC   MSGVMID(8),CMDRESP+12 Origin userid of command  HRC017DT DMT28920
         L     R15,0(R3)           GET ROUTINE TO CALL                  DMT28930
         BALR  R14,R15             GO EXECUTE THE COMMAND               DMT28940
CMDRET   EQU   *                                                        DMT28950
         MVI   CMDINPGS,X'00'      RESET COMMAND IN PROGRESS SWITCH     DMT28960
         B     $CMDCOM+4           AND EXIT                             DMT28970
         EJECT                                                          DMT28980
*---------------------------------------------------------------------* DMT28990
*                          START COMMAND                              * DMT29000
*---------------------------------------------------------------------* DMT29010
*.                                                                      DMT29020
* RESPONSES -                                                           DMT29030
*                                                                       DMT29040
*        DMTXJE752I  LINK 'LINKID' STILL ACTIVE -- DRAIN       HRC000DT DMT29050
*                  STATUS RESET                                HRC000DT DMT29060
*                                                                       DMT29070
* ERROR MESSAGES -                                                      DMT29080
*                                                                       DMT29090
*        DMTXJE750E  LINK 'LINKID' ALREADY ACTIVE -- NO ACTION HRC000DT DMT29100
*                                                                       DMT29110
*.                                                                      DMT29120
         SPACE 1                                                        DMT29130
SETSTART EQU   *                                                        DMT29140
         ST    R14,CMDCMDSV        SAVE RETURN REG                      DMT29150
         TM    LFLAG,LDRAIN        ARE WE DRAINING?                     DMT29160
         BNO   SETSTRT1            NO                                   DMT29170
         NI    LFLAG,255-LDRAIN    RESET DRAIN FLAG                     DMT29180
         MSGX  752,AXSLINK         AND WRITE MSG                        DMT29190
         B     SETSTRTE            AND EXIT                             DMT29200
         SPACE 1                                                        DMT29210
SETSTRT1 EQU   *                                                        DMT29220
         CLI   CMDRESP+3,STACLASS  CLASS RESET?                         DMT29230
         BE    SETSTRTE            YES..NO MSG                          DMT29240
         MSGX  750,AXSLINK         WRITE MSG                            DMT29250
SETSTRTE EQU   *                                                        DMT29260
         TM    XJESYS,SGNONREC     Is link already signed on?  SML2NJE4 DMT29270
         BZ    SETSTAE2            No. Don't start reader now  SML2NJE4 DMT29280
         TM    LFLAG,LHOLD         Are files held on link?     SML2NJE4 DMT29290
         BO    SETSTAE2            Yes. Don't start reader now SML2NJE4 DMT29300
         TM    MASTERSW,READER     READER ALREADY ACTIVE?               DMT29310
         BO    SETSTAE2            YES..CONTINUE                        DMT29320
         OI    $RCOMM1+1,OPEN      OPEN READER GATE                     DMT29330
SETSTAE2 EQU   *                                                        DMT29340
         L     R14,CMDCMDSV        RESTORE RETURN REG                   DMT29350
         BR    R14                 AND RETURN                           DMT29360
         EJECT                                                          DMT29370
*---------------------------------------------------------------------* DMT29380
*                          DRAIN COMMAND                              * DMT29390
*---------------------------------------------------------------------* DMT29400
*.                                                                      DMT29410
* RESPONSES -                                                           DMT29420
*                                                                       DMT29430
*        DMTXJE570I  LINK 'LINKID' NOW SET TO DEACTIVATE       HRC000DT DMT29440
*                                                                       DMT29450
* ERROR MESSAGES -                                                      DMT29460
*                                                                       DMT29470
*        DMTXJE571E  LINK 'LINKID' ALREADY SET TO DEACTIVATE   HRC000DT DMT29480
*                                                                       DMT29490
*.                                                                      DMT29500
         SPACE 1                                                        DMT29510
SETDRAIN EQU   *                                                        DMT29520
         ST    R14,CMDCMDSV        SAVE RETURN                          DMT29530
         TM    LFLAG,LDRAIN        ALREADY DRAINING?                    DMT29540
         BO    SETDRER1            YES ..ERROR                          DMT29550
         OI    LFLAG,LDRAIN        SHOW WE ARE DRAINING                 DMT29560
         MSGX  570,AXSLINK         WRITE MSG                            DMT29570
         CLI   MASTERSW,X'00'      COULD WE ALREADY BE DRAINED?         DMT29580
         BE    SIGNOFF             Go and send signoff record  SML2NJE4 DMT29590
         B     SETDRXIT            IF NOT EXIT                          DMT29600
         SPACE                                                          DMT29610
SETDRER1 EQU   *                                                        DMT29620
         MSGX  571,AXSLINK         WRITE ERROR MSG                      DMT29630
SETDRXIT EQU   *                                                        DMT29640
         L     R14,CMDCMDSV        RESTORE RETURN REG                   DMT29650
         BR    R14                 AND RETURN                           DMT29660
         EJECT                                                          DMT29670
*---------------------------------------------------------------------* DMT29680
*                          FREE COMMAND                               * DMT29690
*---------------------------------------------------------------------* DMT29700
*.                                                                      DMT29710
* RESPONSES -                                                           DMT29720
*                                                                       DMT29730
*        DMTXJE590I  LINK 'LINKID' RESUMING FILE TRANSFER      HRC000DT DMT29740
*                                                                       DMT29750
* ERROR MESSAGES -                                                      DMT29760
*                                                                       DMT29770
*        DMTXJE591E  LINK 'LINKID' NOT IN HOLD STATUS          HRC000DT DMT29780
*                                                                       DMT29790
*.                                                                      DMT29800
         SPACE 1                                                        DMT29810
SETFREE  EQU   *                                                        DMT29820
         ST    R14,CMDCMDSV        SAVE RETURN                          DMT29830
         TM    LFLAG,LHOLD         ARE WE HELD?                         DMT29840
         BNO   SETFRER1            NO ERROR                             DMT29850
         MSGX  590,AXSLINK         WRITE FREE MSG                       DMT29860
         NI    LFLAG,255-LHOLD     TURN OFF HOLD FLAG                   DMT29870
         TM    RDRCMD,RHLDIPGS     WAS THE HOLD IMMED?                  DMT29880
         BO    SETFRXIT            YES..ALL DONE                        DMT29890
         TM    XJESYS,SGNONREC     Only open rdr if signed on  SML2NJE4 DMT29900
         BZ    SETFRXIT       NO - EXIT                        @VA03110 DMT29910
         OI    $RCOMM1+1,OPEN      MUST TRY TO GET FILE                 DMT29920
         B     SETFRXIT            AND ENTER COMMON EXIT                DMT29930
         SPACE 1                                                        DMT29940
SETFRER1 EQU   *                                                        DMT29950
         MSGX  591,AXSLINK         NOT IN HOLD MSG                      DMT29960
SETFRXIT EQU   *                                                        DMT29970
         NI    RDRCMD,255-RHLDIPGS TURN OFF FLAG                        DMT29980
         L     R14,CMDCMDSV        RESTORE RETURN                       DMT29990
         BR    R14                 AND RETURN                           DMT30000
         EJECT                                                          DMT30010
*---------------------------------------------------------------------* DMT30020
*                          HOLD COMMAND                               * DMT30030
*---------------------------------------------------------------------* DMT30040
*.                                                                      DMT30050
* RESPONSES -                                                           DMT30060
*                                                                       DMT30070
*        DMTXJE610I  LINK 'LINKID' TO SUSPEND FILE TRANSMISSIONHRC000DT DMT30080
*        DMTXJE611I  LINK 'LINKID' FILE TRANSMISSION SUSPENDED HRC000DT DMT30090
*                                                                       DMT30100
* ERROR MESSAGES -                                                      DMT30110
*                                                                       DMT30120
*        DMTXJE612E  LINK 'LINKID' ALREADY IN HOLD STATUS      HRC000DT DMT30130
*                                                                       DMT30140
*.                                                                      DMT30150
         SPACE 1                                                        DMT30160
SETHOLD  EQU   *                                                        DMT30170
         ST    R14,CMDCMDSV        SAVE RETURN                          DMT30180
         TM    LFLAG,LHOLD         ALREADY IN HOLD?                     DMT30190
         BO    SETHLDE1            YES ERROR                            DMT30200
         TM    CMDRESP+3,HOLDIMM   HOLD IMMEDIATE?                      DMT30210
         BO    SETHLDIM            YES PROCESS IT                       DMT30220
         OI    RDRCMD,RHLDIPGS     MARK HOLD IN PROGRESS                DMT30230
         MSGX  610,AXSLINK         WRITE SET TO HOLD MSG                DMT30240
         B     SETHLDXT            AND ENTER COMMON EXIT                DMT30250
         SPACE 1                                                        DMT30260
SETHLDIM EQU   *                                                        DMT30270
         OI    LFLAG,LHOLD         HOLD IT REGARDLESS                   DMT30280
         MSGX  611,AXSLINK         WRITE HELD MSG                       DMT30290
         B     SETHLDXT            AND ENTER COMMON EXIT                DMT30300
         EJECT                                                          DMT30310
SETHLDE1 EQU   *                                                        DMT30320
         MSGX  612,AXSLINK         WRITE ALREADY HELD MSG               DMT30330
SETHLDXT EQU   *                                                        DMT30340
         MVC   HLDCMDLK(8),CMDRESP+4 SAVE RESPONSE LINK FOR LATER       DMT30350
         L     R14,CMDCMDSV        RESTORE RETURN                       DMT30360
         BR    R14                 AND RETURN                           DMT30370
         EJECT                                                          DMT30380
*---------------------------------------------------------------------* DMT30390
*                          TRACE COMMAND                              * DMT30400
*---------------------------------------------------------------------* DMT30410
*.                                                                      DMT30420
* RESPONSES -                                                           DMT30430
*                                                                       DMT30440
*        DMTXJE801I  LINK 'LINKID' ERROR TRACE STARTED         HRC000DT DMT30450
*        DMTXJE802I  LINK 'LINKID' TRACE STARTED               HRC000DT DMT30460
*        DMTXJE803I  LINK 'LINKID' TRACE ENDED                 HRC000DT DMT30470
*                                                                       DMT30480
* ERROR MESSAGES -                                                      DMT30490
*                                                                       DMT30500
*        DMTXJE810E  LINK 'LINKID' TRACE ALREADY ACTIVE        HRC000DT DMT30510
*        DMTXJE811E  LINK 'LINKID' TRACE NOT ACTIVE            HRC000DT DMT30520
*                                                                       DMT30530
*.                                                                      DMT30540
         SPACE 1                                                        DMT30550
SETTRACE EQU   *                                                        DMT30560
         ST    R14,CMDCMDSV        SAVE RETURN REGISTER                 DMT30570
         CLI   CMDRESP+3,TRACEOFF  TRACE OFF?                           DMT30580
         BNE   SETTR1              NO CONTINUE                          DMT30590
         TM    LFLAG,LTRALL+LTRERR ARE WE TRACING AT ALL?               DMT30600
         BZ    SETTRE2             NO ERROR                             DMT30610
         NI    LFLAG,255-LTRALL-LTRERR TURN OFF TR BITS                 DMT30620
         MSGX  803,AXSLINK         WRITE THE MSG                        DMT30630
         B     SETTRXIT            AND EXIT                             DMT30640
         SPACE                                                          DMT30650
SETTR1   EQU   *                                                        DMT30660
         TM    LFLAG,LTRALL+LTRERR ARE WE TRACING ALREADY?              DMT30670
         BM    SETTRE1             YES ERROR                            DMT30680
         CLI   CMDRESP+3,TRACERR   ERROR TRACING?                       DMT30690
         BNE   SETTR2              NO ERROR                             DMT30700
         OI    LFLAG,LTRERR        SET ERROR TRACE ON                   DMT30710
         MSGX  801,AXSLINK         WRITE MSG                            DMT30720
         B     SETTRXIT            AND EXIT                             DMT30730
         EJECT                                                          DMT30740
SETTR2   EQU   *                                                        DMT30750
         OI    LFLAG,LTRALL        SET TRACE ALL                        DMT30760
         MSGX  802,AXSLINK         AND WRITE MSG                        DMT30770
         B     SETTRXIT            AND EXIT                             DMT30780
         SPACE                                                          DMT30790
SETTRE1  EQU   *                                                        DMT30800
         MSGX  810,AXSLINK         AND WRITE THE MSG                    DMT30810
         B     SETTRXIT            AND EXIT                             DMT30820
         SPACE                                                          DMT30830
SETTRE2  EQU   *                                                        DMT30840
         MSGX  811,AXSLINK         AND WRITE MSG                        DMT30850
SETTRXIT EQU   *                                                        DMT30860
         L     R14,CMDCMDSV        RESTORE RETURN REG                   DMT30870
         BR    R14                 AND RETURN                           DMT30880
         EJECT                                                          DMT30890
*---------------------------------------------------------------------* DMT30900
*                  BACKSPAC AND FWDSPACE COMMANDS                     * DMT30910
*---------------------------------------------------------------------* DMT30920
*.                                                                      DMT30930
* RESPONSES -                                                           DMT30940
*                                                                       DMT30950
*        NONE                                                           DMT30960
*                                                                       DMT30970
* ERROR MESSAGES -                                                      DMT30980
*                                                                       DMT30990
*        DMTXJE511E  NO FILE ACTIVE ON LINK 'LINKID'           HRC000DT DMT31000
*                                                                       DMT31010
*.                                                                      DMT31020
         SPACE 1                                                        DMT31030
SETBACK  EQU   *                                                        DMT31040
         ST    R14,CMDCMDSV        SAVE RETURN REG                      DMT31050
         TM    MASTERSW,READER     IS THERE A READER ACTIVE?            DMT31060
         BNO   SBKFWDN             NO ERROR                             DMT31070
         CLI   CMDRESP+3,BACKFILE  BACKSPAC FILE?                       DMT31080
         BNE   SETBACK1            NO CONTINUE                          DMT31090
         OI    RDRCMD,RBACKFIL     INDICATE CMD FOR RDR PROCESSING      DMT31100
         B     SBKFWDE             AND EXIT                             DMT31110
SETSTOP  EQU   *                                               HRC007DT DMT31120
         OI    LFLAG,LDRAIN        Stop any opens from now on  HRC007DT DMT31130
         B     SIGNOFF             Signoff, Close URs & exit   HRC007DT DMT31140
*                                                              HRC007DT DMT31150
SETFORCE EQU   *                                               HRC007DT DMT31160
         OI    LFLAG,LHALT         Give a clue what happened   HRC007DT DMT31170
         BAL   R14,CLOSEURS        Attempt to close URs        HRC007DT DMT31180
         DC    X'0000'             Cause program check         HRC007DT DMT31190
         SPACE                                                          DMT31200
SETBACK1 EQU   *                                                        DMT31210
         OI    RDRCMD,RBACKCNT     MUST BE BACKSPAC COUNT               DMT31220
         MVC   RDRCMDCT(4),CMDRESP+12+16 SAVE COUNT FOR RDR    HRC016DT DMT31230
         B     SBKFWDE             AND EXIT                             DMT31240
         SPACE                                                          DMT31250
SETFWD   EQU   *                                                        DMT31260
         ST    R14,CMDCMDSV        SAVE RETURN REGISTER                 DMT31270
         TM    MASTERSW,READER     IS THERE A READER ACTIVE             DMT31280
         BNO   SBKFWDN             NO ERROR                             DMT31290
         MVC   RDRCMDCT(4),CMDRESP+12+16 SAVE COUNT FOR READER HRC016DT DMT31300
         OI    RDRCMD,RFWDCNT      INDICATE COMMAND FOR READER          DMT31310
         B     SBKFWDE             AND EXIT                             DMT31320
         SPACE                                                          DMT31330
SBKFWDN  EQU   *                                                        DMT31340
         MSGX  511,AXSLINK         WRITE NO FILE ACTIVE MSG             DMT31350
SBKFWDE  EQU   *                                                        DMT31360
         MVC   RDRCMDLK(8),CMDRESP+4 MOVE IN RESPONSE LINKID            DMT31370
         L     R14,CMDCMDSV        RESTORE RETURN REG                   DMT31380
         BR    R14                 AND RETURN                           DMT31390
         EJECT                                                          DMT31400
*---------------------------------------------------------------------* DMT31410
*                          FLUSH COMMAND                              * DMT31420
*---------------------------------------------------------------------* DMT31430
*.                                                                      DMT31440
* RESPONSES -                                                           DMT31450
*                                                                       DMT31460
*        NONE                                                           DMT31470
*                                                                       DMT31480
* ERROR MESSAGES -                                                      DMT31490
*                                                                       DMT31500
*        DMTXJE511E  NO FILE ACTIVE ON LINK 'LINKID'           HRC000DT DMT31510
*                                                                       DMT31520
*.                                                                      DMT31530
         SPACE 1                                                        DMT31540
SETFLUSH EQU   *                                                        DMT31550
         ST    R14,CMDCMDSV        SAVE RETURN REG                      DMT31560
         MVC   RDRCMDID(2),CMDRESP+12+16 SAVE FOR LATER COMPAREHRC016DT DMT31570
         LH    R1,CMDRESP+12+16     GET SPOOLID                HRC016DT DMT31580
         CVD   R1,CMDCVD           CONVERT TO DECIMAL                   DMT31590
         UNPK  CMDFID,CMDCVD       SPREAD THE DIGITS                    DMT31600
         OI    CMDFID+3,X'F0'      MAKE LAST PRINTABLE                  DMT31610
         TM    MASTERSW,READER     ARE WE SENDING A FILE?               DMT31620
         BO    SETFLSH1            YEP.. CONTINUE                       DMT31630
         MSGX  511,AXSLINK         No file active on link $    HRC003DT DMT31640
         B     SETFLSHE            AND EXIT                             DMT31650
         SPACE                                                          DMT31660
SETFLSH1 EQU   *                                                        DMT31670
         TM    RSW1,RWAITACK       Are we waiting for file ACK?SML2NJE4 DMT31680
         BZ    NOWAITAK            Not waiting right now       SML2NJE4 DMT31690
         MVI   RCTCOM+1,OPEN       Open commutator entry       SML2NJE4 DMT31700
NOWAITAK EQU   *                                               SML2NJE4 DMT31710
         CLI   CMDRESP+3,FLUSHALL  FLUSH ALL                            DMT31720
         BNE   SETFLSH2            NO CONTINUE                          DMT31730
         OI    RDRCMD,RFLSHALL     SET RDRCMD BYTE                      DMT31740
         B     SETFLSHE            AND EXIT                             DMT31750
         SPACE                                                          DMT31760
SETFLSH2 EQU   *                                                        DMT31770
         CLI   CMDRESP+3,FLUSHOLD  FLUSH AND HOLD?                      DMT31780
         BNE   SETFLSH3            NO MUST BE FLUSH COPY                DMT31790
         OI    RDRCMD,RFLSHOLD     INDICATE CMD IN RDR CMD BYTE         DMT31800
         B     SETFLSHE            AND EXIT                             DMT31810
         SPACE                                                          DMT31820
SETFLSH3 EQU   *                                                        DMT31830
         OI    RDRCMD,RFLSHCPY     INDICATE CMD IN RDR CMD BYTE         DMT31840
SETFLSHE EQU   *                                                        DMT31850
         MVC   RDRCMDLK(8),CMDRESP+4 MOVE IN RESPONSE LINKID            DMT31860
         L     R14,CMDCMDSV        RESTORE RETURN REG                   DMT31870
         BR    R14                 AND RETURN                           DMT31880
         EJECT                                                          DMT31890
*---------------------------------------------------------------------* DMT31900
*                            CMD COMMAND                              * DMT31910
*---------------------------------------------------------------------* DMT31920
*.                                                                      DMT31930
* RESPONSES -                                                           DMT31940
*                                                                       DMT31950
*        DMTXJE530I  COMMAND FORWARDED ON LINK 'LINKID'        HRC000DT DMT31960
*                                                                       DMT31970
* ERROR MESSAGES -                                                      DMT31980
*                                                                       DMT31990
*        NONE                                                           DMT32000
*                                                                       DMT32010
*.                                                                      DMT32020
         SPACE 1                                                        DMT32030
         DS    0H                                                       DMT32040
SETCMD   EQU   *                                                        DMT32050
         ST    R14,CMDCMDSV        SAVE RETURN                          DMT32060
         LA    R7,WTCT             SET TCTR                             DMT32070
         SPACE 1                                                        DMT32080
         MVC   WCTTCT1(2),=X'0050' ???                                  DMT32090
         OC    CMDRESP+12+16(8),BLANK TO UPPR CASE             HRC016DT DMT32100
         CLC   CMDRESP+12+16(3),=C'LOG' LOGING REQUESTED?      HRC016DT DMT32110
         BNE   CMD2A               NOPE                                 DMT32120
         OI    $LOGSW,LOGON        SET LOGING REQUESTED                 DMT32130
         L     R14,CMDCMDSV        RESTORE RETURN                       DMT32140
         BR    R14                 AND RETURN                           DMT32150
         SPACE 1                                                        DMT32160
CMD2A    EQU   *                                                        DMT32170
         CLC   CMDRESP+12+16(5),=C'NOLOG' TURN OFF LOGING?     HRC016DT DMT32180
         BE    LOGCLOSE            YES                                  DMT32190
         TM    LFLAG,LCONNECT      Is link connected?          HRC031DT DMT32200
         BO    CMD12               Link is connected.          HRC031DT DMT32210
         MSGX  303,AXSLINK         Link is not active message  HRC031DT DMT32220
         B     CMDNRET             Return to command processor HRC031DT DMT32230
CMD12    EQU   *                                                        DMT32240
*****    MSGX  530,AXSLINK         WRITE COMMAND FORD MSG         *XJE  DMT32250
         LH    R8,=AL2(4096+NMROTANK-DMTXJEB) NMR tank offset     *XJE  DMT32260
         AR    R8,R9               -> NMROTANK                    *XJE  DMT32270
         USING TANKDSEC,R8         Get NMR tank addressability SML2NJE4 DMT32280
         EJECT                                                          DMT32290
         SR    R1,R1               CLEAR OUT R1 OF IC                   DMT32300
         IC    R1,CMDRESP          GET LENGTH OF RESPONSE               DMT32310
         SH    R1,=H'28'           Correct for header          HRC016DT DMT32320
         LTR   R1,R1               IS THE RESULT NEGATIVE?              DMT32330
         BM    CMD2               YES, ZERO LENGTH REPLY       @VA03860 DMT32340
         EX    R1,MSGMVC           AND MOVE INTO MSG BUFFER             DMT32350
         LA    R1,1(,R1)           Length was 1 short for EX   SML2NJE4 DMT32360
         LA    R0,XJE3NMRC         Code for routine BLDNMRC       *XJE  DMT32370
         L     R15,=A(DMTXJE3)     -> NJE functions csect         *XJE  DMT32380
         BALR  R14,R15             Build NMR command header    SML2NJE4 DMT32390
         STH   R1,TANKCNT          Store length of command NMR SML2NJE4 DMT32400
*        LR    R0,R4               R4 gets clobbered by $PUT   SML2NJE4 DMT32410
         BAL   R14,$PUT            AND WRITE THE TANK                   DMT32420
*        LR    R4,R0               Restore R4 after $PUT       SML2NJE4 DMT32430
CMD2     EQU   *                                                        DMT32440
         MVI   TANKDATA,C' '       Prepare for buffer clear    SML2NJE4 DMT32450
         MVC   TANKDATA+1(NMRSIZE-1),TANKDATA Clear NMR buffer SML2NJE4 DMT32460
CMDNRET  EQU   *                                                        DMT32470
         L     R14,CMDCMDSV        RESTORE RETURN                       DMT32480
         BR    R14                 AND RETURN                           DMT32490
         SPACE 1                                                        DMT32500
         DROP  R6                  Finished with link table    SML2NJE3 DMT32510
MSGMVC   MVC   TANKDATA+NMRHSIZE(*-*),CMDRESP+12+16 Executed   SML2NJE4 DMT32520
         DROP  R8                  Finished with tank for now  SML2NJE4 DMT32530
         EJECT                                                          DMT32540
*---------------------------------------------------------------------* DMT32550
*                                                                     * DMT32560
*                  COMMAND DATA AREA                                  * DMT32570
*                                                                     * DMT32580
*---------------------------------------------------------------------* DMT32590
         SPACE                                                          DMT32600
STRTCMD  EQU   X'80'               START COMMAND                        DMT32610
DRCMD    EQU   X'81'               DRAIN COMMAND                        DMT32620
FREECMD  EQU   X'82'               FREE COMMAND                         DMT32630
HOLDCMD  EQU   X'83'               HOLD COMMAND                         DMT32640
TRACECMD EQU   X'84'               TRACE COMMAND                        DMT32650
STOPCMD  EQU   X'85'               Stop link immediately       HRC007DT DMT32660
FORCECMD EQU   X'86'               Cause link to program check HRC007DT DMT32670
BACKCMD  EQU   X'90'               BACKSPAC COMMAND                     DMT32680
FWDCMD   EQU   X'91'               FORWARD SPACE COMMAND                DMT32690
FLUSHCMD EQU   X'A0'               FLUSH COMMAND                        DMT32700
CMDCMD   EQU   X'B0'               COMMAND COMMAND                      DMT32710
MSGCMD   EQU   X'B1'               MESSAGE COMMAND                      DMT32720
NMR      EQU   X'B2'               NMR 'command'               SML2NJE4 DMT32730
         SPACE                                                          DMT32740
*        COMMAND MODIFIERS                                              DMT32750
TRACEOFF EQU   X'C0'               TRACE OFF                            DMT32760
TRACERR  EQU   X'80'               ERROR TRACE ON                       DMT32770
TRACEALL EQU   X'00'               TRACE ALL ON                         DMT32780
BACKCNT  EQU   X'80'               BACKSPAC COUNT                       DMT32790
BACKFILE EQU   X'00'               BACKSPAC FILE                        DMT32800
FLUSHCPY EQU   X'00'               FLUSH COPY                           DMT32810
FLUSHALL EQU   X'80'               FLUSH ALL                            DMT32820
FLUSHOLD EQU   X'40'               FLUSH HOLD                           DMT32830
HOLDIMM  EQU   X'80'               HOLD IMMEDIATE                       DMT32840
STACLASS EQU   X'80'               START RESET CLASS                    DMT32850
         SPACE                                                          DMT32860
CMDSETUP DC    A(CMDTABLE)         COMMAND TABLE ADDRESS                DMT32870
         DC    A(CMDINC)                                                DMT32880
         DC    A(CMDEND-CMDINC)    LAST ENTRY                           DMT32890
         SPACE 1                                                        DMT32900
CMDINC   EQU   4                   LENGTH OF COMMAND TABLE ENTRY        DMT32910
         SPACE                                                          DMT32920
CMDTABLE DC    0F'0'                                                    DMT32930
         DC    AL1(STRTCMD),AL3(SETSTART)                               DMT32940
         DC    AL1(DRCMD),AL3(SETDRAIN)                                 DMT32950
         DC    AL1(FREECMD),AL3(SETFREE)                                DMT32960
         DC    AL1(HOLDCMD),AL3(SETHOLD)                                DMT32970
         DC    AL1(TRACECMD),AL3(SETTRACE)                              DMT32980
         DC    AL1(STOPCMD),AL3(SETSTOP)                       HRC007DT DMT32990
         DC    AL1(FORCECMD),AL3(SETFORCE)                     HRC007DT DMT33000
         DC    AL1(BACKCMD),AL3(SETBACK)                                DMT33010
         DC    AL1(FWDCMD),AL3(SETFWD)                                  DMT33020
         DC    AL1(FLUSHCMD),AL3(SETFLUSH)                              DMT33030
         DC    AL1(CMDCMD),AL3(SETCMD)                                  DMT33040
CMDEND   EQU   *                                                        DMT33050
         SPACE                                                          DMT33060
         EJECT                                                          DMT33070
*.                                                                      DMT33080
*                                                                       DMT33090
* ENTRY NAME -                                                          DMT33100
*                                                                       DMT33110
*        MSGPROC                                                        DMT33120
*                                                                       DMT33130
* FUNCTION -                                                            DMT33140
*                                                                       DMT33150
*        THIS ROUTINE IS ENTERED WHEN THE MSGECB IS POSTED BY           DMT33160
*        THIS TASK'S ASYNCHRONOUS EXIT, INDICATING MSGS ARE IN          DMT33170
*        THE MSG QUEUE FOR THIS TASK.  THIS MESSAGES ARE                DMT33180
*        UNSTACKED FROM THE MSG QUEUE BY REPEATED CALLS TO              DMT33190
*        GMSGREQ AND QUEUED FOR TRANSMISSION.                           DMT33200
*                                                                       DMT33210
* CALLS TO OTHER ROUTINES -                                             DMT33220
*                                                                       DMT33230
*        DMTCOM - TO UNSTACK THE MESSAGE                                DMT33240
*                                                                       DMT33250
* OPERATION -                                                           DMT33260
*                                                                       DMT33270
*        1. DEQUEUE MESSAGES FROM MESSAGE STACK VIA CALL TO GMSGREQ.    DMT33280
*                                                                       DMT33290
*        2. IF MESSAGE DEQUEUED SEND THE RECORD VIA CALL TO $PUT        DMT33300
*                                                                       DMT33310
*        3. EXIT TO COMMUTATOR.                                         DMT33320
*                                                                       DMT33330
* RESPONSES -                                                           DMT33340
*                                                                       DMT33350
*        NONE                                                           DMT33360
*                                                                       DMT33370
* ERROR MESSAGES -                                                      DMT33380
*                                                                       DMT33390
*        NONE                                                           DMT33400
*                                                                       DMT33410
*.                                                                      DMT33420
         SPACE 3                                                        DMT33430
MSGPROC  EQU   *                                                        DMT33440
         LA    R7,WTCT             ANOTHER CONSOLE USER                 DMT33450
         MVI   $MSGCOM+1,CLOSE     CLOSE THE GATE                       DMT33460
         TM    WCTSTAT,TCTREL      IS THE INTERLOCK ON?                 DMT33470
         BO    MSGPROC2            YES..ALREADY PACKED..CONTINUE        DMT33480
         LH    R8,=AL2(4096+NMROTANK-DMTXJEB) NMR tank offset     *XJE  DMT33490
         AR    R8,R9               -> NMROTANK                    *XJE  DMT33500
         USING TANKDSEC,R8         Get tank addressability     SML2NJE4 DMT33510
MSGPROC1 EQU   *                                                        DMT33520
         LA    R1,TANKDATA-2       Load stacked message here   SML2NJE4 DMT33530
         L     R2,XJELINK          Get link table address      SML2NJE4 DMT33540
*DEL     L     R15,TCOM            GET COMMON ROUTINES LIST       *XJE  DMT33550
         L     R15,GMSGREQ         INDICATE WE WANT A MSG               DMT33560
         BALR  R14,R15             GO GET ONE                           DMT33570
         LTR   R15,R15             ANY AVAILABLE?                       DMT33580
         BNZ   MSGPREOF       SEND PSUEDO EOF                  @VA03480 DMT33590
         XR    R1,R1               Clear R1 for IC             SML2NJE4 DMT33600
         IC    R1,TANKDATA-2       Get the length of message   SML2NJE4 DMT33610
   LTR R1,R1
   BP VALMSG
   STM R0,R1,XJE3SAVE  save before ABEND macro
   ABEND 888,DUMP      abend U888 if msg len < 1
VALMSG EQU *
         CLI   TANKDATA-2+1,NMR    Is this already an NMR?     SML2NJE4 DMT33620
         BE    MSGISNMR            Skip building NMR header    SML2NJE4 DMT33630
         LA    R0,XJE3NMRM         Code for routine BLDNMRM       *XJE  DMT33640
         L     R15,=A(DMTXJE3)     -> NJE functions csect         *XJE  DMT33650
         BALR  R14,R15             Build NMR message header    SML2NJE4 DMT33660
MSGISNMR EQU   *                                               SML2NJE4 DMT33670
         LH    R8,=AL2(4096+NMROTANK-DMTXJEB) NMR tank offset     *XJE  DMT33680
         AR    R8,R9               -> NMROTANK                    *XJE  DMT33690
         STH   R1,TANKCNT          Store length of NMR message SML2NJE4 DMT33700
         EJECT                                                          DMT33710
MSGPROC2 EQU   *                                                        DMT33720
         BAL   R14,$PUT            AND WRITE THE BUFFER                 DMT33730
         MVI   TANKDATA,C' '       Get ready to clear buffer   SML2NJE4 DMT33740
         MVC   TANKDATA+1(NMRSIZE-1),TANKDATA Clear NMR buffer SML2NJE4 DMT33750
         B     MSGPROC1            AND GO GET ANOTHER                   DMT33760
         SPACE 1                                                        DMT33770
MSGPREOF EQU   *                                               @VA03480 DMT33780
         CLC   OBUFPTR(4),=F'0'    Is there an active buffer?  SML2NJE4 DMT33790
         BE    $MSGCOM+4      NO, JUST RETURN                  @VA03863 DMT33800
         MVC   TANKCNT,=F'0'       Count = 0 => EOF            SML2NJE4 DMT33810
         DROP  R8                                              SML2NJE4 DMT33820
         BAL   R14,$PUT       SEND THE RECORD                  @VA03480 DMT33830
         B     $MSGCOM+4      AND RETURN                       @VA03480 DMT33840
         EJECT                                                          DMT33850
*.                                                                      DMT33860
*                                                                       DMT33870
* ENTRY NAME -                                                          DMT33880
*                                                                       DMT33890
*        MSG                                                            DMT33900
*                                                                       DMT33910
* FUNCTION -                                                            DMT33920
*                                                                       DMT33930
*        THIS ROUTINE PREPARES AND SENDS REQUESTS TO THE                DMT33940
*        SPECIALIZED TASK REX, IN ORDER TO WRITE MESSAGES               DMT33950
*        ON THE OPERATOR'S CONSOLE.                                     DMT33960
*                                                                       DMT33970
* CALLS TO OTHER ROUTINES -                                             DMT33980
*                                                                       DMT33990
*        DMTREX - TO EXECUTE THE MSG WRITE                              DMT34000
*                                                                       DMT34010
* OPERATION -                                                           DMT34020
*                                                                       DMT34030
*        1. MOVE VARIABLE PART OF MSG TO GIVE REQUEST BUFFER            DMT34040
*                                                                       DMT34050
*        2. INITIATE GIVE REQUEST TO DMTREX WITH MSG BUFFER.            DMT34060
*                                                                       DMT34070
*        3. WAIT FOR COMPLETION                                         DMT34080
*                                                                       DMT34090
*        4. RETURN TO CALLER                                            DMT34100
*                                                                       DMT34110
* ENTRY CONDITIONS:                                                     DMT34120
*                                                                       DMT34130
*        IN REG. 14 THE RETURN ADDRESS                                  DMT34140
*        IN REG. 15 THE ROUTING CODE                                    DMT34150
*        IN REG. 1 THE POINTER TO THE VARIABLE PORTION OF               DMT34160
*              THE MESSAGE STRING                                       DMT34170
*        IN REG. 0 THE LENGTH OF THE VARIABLE PORTION OF THE MSG        DMT34180
*                                                                       DMT34190
* EXIT CONDITIONS:                                                      DMT34200
*                                                                       DMT34210
*        NONE                                                           DMT34220
*                                                                       DMT34230
* NOTE:                                                                 DMT34240
*        NONE                                                           DMT34250
*                                                                       DMT34260
* RESPONSES -                                                           DMT34270
*                                                                       DMT34280
*        NONE                                                           DMT34290
*                                                                       DMT34300
* ERROR MESSAGES -                                                      DMT34310
*                                                                       DMT34320
*        NONE                                                           DMT34330
*                                                                       DMT34340
*.                                                                      DMT34350
         EJECT                                                          DMT34360
MSG      DC    0H'0'                                                    DMT34370
         STM   R14,R2,MSGSAVE      SAVE REGISTERS                       DMT34380
         LR    R2,R0               MOVE R0 INTO WORK REG                DMT34400
         BCTR  R2,0                REDUCE BY ONE FOR MVC                DMT34410
         EX    R2,MSGMVC1          AND MOVE TO MSG REQ BUFFER           DMT34420
         AH    R2,=H'24'           UP FOR HEADER                        DMT34430
         STC   R2,MSGBLK           AND STORE IN MSG REQ BUFFER          DMT34440
         CLI   MSGLINK,X'00'       NEED ROUTING?                        DMT34450
         BNE   MSG1                NO CONTINUE                          DMT34460
         MVC   MSGLINK(8),AXSLINK  MOVE IN OUR LINKID                   DMT34470
MSG1     EQU   *                                                        DMT34480
         LA    R1,MSGREQ           GET READY FOR GIVE                   DMT34490
         XC    MSGREQ(4),MSGREQ    CLEAR OUT SYNCH LOCK                 DMT34500
         L     R15,GIVEREQ         SYSTEM GIVE REQUEST EXECUTATOR       DMT34510
         BALR  R14,R15             GO GIVE THE BUFFER TO REX            DMT34520
*********L     R15,WAITREQ         WAIT FOR THE COMPLETION OF           DMT34530
*********BALR  R14,R15             CONSOLE OPERATION                    DMT34540
         MVI   MSGLINK,X'00'       SHOW NO RESPONSE                     DMT34550
         MVI   MSGBLK+2,X'00'      INDICATE NO ROUTING                  DMT34560
         LM    R14,R2,MSGSAVE      RESTORE REGS                         DMT34570
         BR    R14                 AND RETURN                           DMT34580
         SPACE                                                          DMT34590
MSGMVC1  MVC   MSGBUF(0),0(R1)     TO BE EXECUTED FROM ABOVE            DMT34600
         SPACE                                                          DMT34610
         EJECT                                                          DMT34620
         EJECT                                                          DMT34630
*---------------------------------------------------------------------* DMT34640
*                                                                     * DMT34650
*                        FILE ACCESS INTERFACE                        * DMT34660
*                                                                     * DMT34670
*---------------------------------------------------------------------* DMT34680
         SPACE 1                                                        DMT34690
*                                                                       DMT34700
*        ON ENTRY:            R1 --> DEVICE REQUEST BLOCK               DMT34710
*                             R0  =  AXS REQUEST CODE                   DMT34720
*                                                                       DMT34730
*        ON EXIT:                                                       DMT34740
*                             R15 =  AXS RETURN CODE                    DMT34750
*                                                                       DMT34760
AXS      DS    0H                                                       DMT34770
         ST    R14,AXSAVE          SAVE RETURN REGISTER                 DMT34780
         STC   R0,17(R1)           SET REQUESTED FUNCTION               DMT34790
         XC    0(4,R1),0(R1)       CLEAR REQUEST SYNCH LOCK             DMT34800
         L     R15,GIVEREQ         GIVE REQUEST ADDRESS                 DMT34810
         BALR  R14,R15             GIVE THE REQUEST TO SUPERVISOR       DMT34820
         L     R15,WAITREQ         WAIT REQUEST                         DMT34830
         BALR  R14,R15             WAIT FOR OPERATION TO COMPLETE       DMT34840
         XC    0(4,R1),0(R1)       CLEAR OUT SYNC LOCK                  DMT34850
         L     R14,AXSAVE          RESTORE RETURN ADDRESS               DMT34860
         BR    R14                 RETURN TO CALLER                     DMT34870
         SPACE 1                                                        DMT34880
         EJECT                                                          DMT34890
*.                                                                      DMT34900
*                                                                       DMT34910
* ENTRY NAME -                                                          DMT34920
*                                                                       DMT34930
*        $TPPUT                                                         DMT34940
*                                                                       DMT34950
* FUNCTION -                                                            DMT34960
*                                                                       DMT34970
*        THIS ROUTINE TAKES A LINE AND PACKS IT INTO A TELE-            DMT34980
*        PROCESSING BUFFER.  WHEN A BUFFER IS FILLED IT IS QUEUED       DMT34990
*        ONTO $OUTBUF FOR PROCESSING BY COMSUP.                         DMT35000
*                                                                       DMT35010
* CALLS TO OTHER ROUTINES -                                             DMT35020
*                                                                       DMT35030
*        NONE                                                           DMT35040
*                                                                       DMT35050
* OPERATION -                                                           DMT35060
*                                                                       DMT35070
*        1. FIND THE CURRENT TP BUFFER FOR THE CALLING                  DMT35080
*           PROCESSOR.                                                  DMT35090
*                                                                       DMT35100
*        2. COMPRESS THE RECORD IN THE SUPPLIED TANK.                   DMT35110
*                                                                       DMT35120
*        3. TRY TO FIT IN THE EXISTING TP BUFFER.                       DMT35130
*                                                                       DMT35140
*        4. IF RECORD WILL NOT FIT, QUEUE CURRENT                       DMT35150
*           RECORD FOR TRANSMISSION, OBTAIN A NEW BUFFER                DMT35160
*           AND ADD RECORD TO IT.                                       DMT35170
*                                                                       DMT35180
*        5. FOR OPERATOR MESSAGES, PROCESS ONLY ONE RECORD              DMT35190
*           PER BUFFER.                                                 DMT35200
*                                                                       DMT35210
*        6. RETURN TO CALLER                                            DMT35220
*                                                                       DMT35230
* RESPONSES -                                                           DMT35240
*                                                                       DMT35250
*        NONE                                                           DMT35260
*                                                                       DMT35270
* ERROR MESSAGES -                                                      DMT35280
*                                                                       DMT35290
*        NONE                                                           DMT35300
*                                                                       DMT35310
*.                                                                      DMT35320
         EJECT                                                          DMT35330
*                                                                       DMT35340
*        $PUT  ROUTINE             INTERFACE WITH $TPPUT                DMT35350
*                                                                       DMT35360
*        R8 POINTS TO TANK, R14 POINTS TO RETURN, TCTR POINTS TO TCT    DMT35370
*                                                                       DMT35380
         USING TANKDSEC,R8                                              DMT35390
         USING TCTDSECT,TCTR                                            DMT35400
         SPACE 1                                                        DMT35410
$PUT     DS    0H                                                       DMT35420
         ST    R14,TCTSAV1         SAVE RETURN ADDRESS                  DMT35430
         ST    R8,TCTCCW           SAVE TANK ADDRESS                    DMT35440
OXLOOP   EQU   *                                                        DMT35450
         TM    TCTSTAT,TCTREL      IS INTERLOCK RELEASE ON              DMT35460
         BZ    OXPUT               IF NOT DO NORMAL $TPPUT              DMT35470
         LH    R8,=AL2(4096+NMROTANK-DMTXJEB) NMR tank offset     *XJE  DMT35480
         AR    R8,R9               -> NMROTANK                    *XJE  DMT35490
         BAL   R14,$TPREPUT        ATTEMPT TO SEND                      DMT35500
         L     R14,TCTSAV1         PICK UP RETURN ADDR                  DMT35510
         BNE   OXFINTST            IF TANK OK TEST FOR MORE WORK        DMT35520
         MVI   CMDINPGS,X'00'      RESET FLAG                  @VM01164 DMT35530
         MVI   $MSGCOM+1,CLOSE CLOSE THIS PROCESSOR            @VA03480 DMT35540
         B     $START         RETURN TO TOP OF COMMUTATOR      @VA03480 DMT35550
         SPACE 1                                                        DMT35560
OXFINTST EQU   *                                                        DMT35570
         NI    WCTSTAT,255-TCTREL  RESET INTERLOCK RELEASE              DMT35580
         BR    R14                 AND RETURN                           DMT35590
         SPACE 1                                                        DMT35600
OXPUT    EQU   *                                                        DMT35610
         BAL   R14,$TPPUT          SUBMIT TANK FOR TRANSMISSION         DMT35620
         L     R14,TCTSAV1         RESTORE RETURN POINTER               DMT35630
         BNER  R14                 IF TANK WENT OK THEN RETURN          DMT35640
         TM    TCTSTAT,TCT1052     IF NOT TEST FOR CONSOLE              DMT35650
         BZ    OXWAIT              IF NOT CONSOLE WAIT                  DMT35660
         OI    WCTSTAT,TCTREL      SET INTERLOCK RELEASE INDICATOR      DMT35670
         MVI   CMDINPGS,X'00'      RESET FLAG                  @VM01164 DMT35680
         MVI   $MSGCOM+1,CLOSE CLOSE THIS PROCESSOR            @VA03480 DMT35690
         B     $START         RETURN TO TOP OF COMMUTATOR      @VA03480 DMT35700
         SPACE 1                                                        DMT35710
OXWAIT   EQU   *                                                        DMT35720
         DS    0H                  WAIT TO RESUBMIT TANK                DMT35730
         MVC   TCTENTY(2),OBUFNOW  SET UP FOR REENTRY                   DMT35740
         L     R6,TCTCOM           GET COMMUTATOR ENTRY                 DMT35750
         MVI   1(R6),CLOSE         AND CLOSE GATE                       DMT35760
         MVI   TCTWFB,X'FF'        SET READER-WAITING-FOR-BUFFER        DMT35770
         B     TCTRTN              AND RETURN                           DMT35780
         EJECT                                                          DMT35790
BUFNOW   EQU   *                                                        DMT35800
         MVI   TCTWFB,X'00'        RESET WAIT SWITCH                    DMT35810
         L     R6,TCTCOM           GET COMMUTATOR ENTRY                 DMT35820
         MVI   1(R6),CLOSE         AND CLOSE GATE                       DMT35830
         L     R8,TCTCCW           PICK UP TANK ADDRESS                 DMT35840
         BAL   R14,$TPREPUT        RESUBMIT TANK FOR TRANSMISSION       DMT35850
         L     R14,TCTSAV1         PICK UP USER RETURN POINT            DMT35860
         BE    OXWAIT              WAIT                                 DMT35870
         BR    R14                 RETURN                               DMT35880
         DROP  R8                                                       DMT35890
         SPACE 1                                                        DMT35900
OBUFNOW  DC    S(BUFNOW)           RENTRY POINT                         DMT35910
         EJECT                                                          DMT35920
*---------------------------------------------------------------------* DMT35930
*                                                                     * DMT35940
*  ENTRY - $TPPUT                                                     * DMT35950
*                 REGISTERS - R8=RECORD TANK 2(R8)=RCB,3(R8)=SRCB     * DMT35960
*                            R14=RETURN ADDR ,CC=0 - RECORD NOT TAKEN * DMT35970
*                                             CC.NE.0-RECORD ACCEPTED * DMT35980
*                            R15 IS CONSIDERED VOLITILE               * DMT35990
*                                                                     * DMT36000
*                                                                     * DMT36010
*---------------------------------------------------------------------* DMT36020
         SPACE 1                                                        DMT36030
$TPPUT   DS    0H                                                       DMT36040
         ST    R14,OSAVR14         SAVE RETURN                          DMT36050
         ST    R5,OSAVR5           SAVE REGISTERS                       DMT36060
         ST    R6,OSAVR6           SAVE REGISTERS                       DMT36070
         ST    R8,OINADD           SAVE INPUT TANK ADDR                 DMT36080
         LA    R15,1               Get counter                 HRC001DT DMT36090
         L     R5,OINADD           COMPRESSION WORK AREA                DMT36100
         LA    R5,TANKRCB-TANKDSEC(,R5) Get RCB address        HRC001DT DMT36110
         USING TANKDSEC,R8         *                                    DMT36120
         XR    R6,R6               Clear R6 for ICM            HRC001DT DMT36130
         ICM   R6,B'0011',TANKCNT  Tank data count             HRC001DT DMT36140
         BE    OEOINCHK       BR IF YES TO CHECK EOF           @VA03480 DMT36150
         AR    R6,R8               INCLUDE TANK ADDR                    DMT36160
         ST    R6,OINEND           TO SAFE STORAGE                      DMT36170
         CLI   OTS(R8),2           IS THIS A TEXT CARD                  DMT36180
         BNE   OGOA                BR IF NO                             DMT36190
         SPACE 1                                                        DMT36200
*                   SKIP ATTEMPTING TO COMPRESS A TEXT CARD             DMT36210
         LH    R6,TANKCNT          INPUT COUNT                          DMT36220
         LTR   R4,R8               INPUT ADDR                           DMT36230
         AR    R8,R6               END OF RECORD                        DMT36240
         B     OSQUEEZE            GO PROCESS RECORD                    DMT36250
         SPACE 1                                                        DMT36260
OGOA     DS    0H                                                       DMT36270
         MVI   OTS(R6),0           SETUP ENDING CHARACTER               DMT36280
         CLI   OTS-1(R6),0         DOES ENDING MATCH LAST DATA CHAR     DMT36290
         BNE   OGOB                BR IF NOT                            DMT36300
         MVI   OTS(R6),255         YES...USE ANOTHER                    DMT36310
OGOB     EQU   *                                                        DMT36320
         MVC   OTS+1(3,R6),OTS(R6) PROPAGATE FOR DUPLICATION            DMT36330
OGO      DS    0H                                                       DMT36340
         LA    R14,OGO1            LOAD FOR SPEED                       DMT36350
         LA    R13,OSQUEEZE        LOAD FOR SPEED                       DMT36360
         SR    R6,R6               INITIAL COUNTER FOR MVC              DMT36370
         LTR   R4,R8               INPUT AREA TO R4                     DMT36380
OGO1     DS    0H                                                       DMT36390
         CLC   OTS(3,R8),OTS+1(R8) CHECK FOR COMPRESSABILITY            DMT36400
         BCR   8,R13               BR IF COMPRESSABLE (TO OSQUEEZE)     DMT36410
         AR    R8,R15              UP DATA PTR                          DMT36420
         AR    R6,R15              AND CHAR COUNT                       DMT36430
         BR    R14                 CONTINUE (TO OGO1)                   DMT36440
         EJECT                                                          DMT36450
*---------------------------------------------------------------------* DMT36460
*                                                                     * DMT36470
*             OSQUEEZE -  IDENTICAL CHARACTERS FOUND                  * DMT36480
*                                                                     * DMT36490
*---------------------------------------------------------------------* DMT36500
         SPACE 2                                                        DMT36510
OSQUEEZE DS    0H                  *                                    DMT36520
         LTR   R6,R6               Is a character string activeHRC001DT DMT36530
         BE    OCOMPTST            BR IF NO TO COMPRESS                 DMT36540
         CH    R6,=H'63'           DOES STRING EXCEED SCB               DMT36550
         BH    OBIGMOVE            BR IF YES                            DMT36560
         EX    R6,OMVC1A      MOVE TO TEMP BUFF THEN TO TANK   @VA04175 DMT36570
         EX    R6,OMVC1B      -TO AVOID CHARACTER PROPAGATION  @VA04175 DMT36580
         STC   R6,2(R5)            SET SCB COUNT                        DMT36590
         OI    2(R5),X'C0'         SET SCB ID BITS                      DMT36600
         AR    R5,R6               FIX OUTPUT POINTER                   DMT36610
         AR    R5,R15              COUNT SCB                            DMT36620
OCOMPTST DS    0H                                                       DMT36630
         C     R8,OINEND           TEST FOR EOI                         DMT36640
         BNL   OEOINPUT            BR IF YES                            DMT36650
OCOMP    DS    0H                                                       DMT36660
         LA    R14,OCOMP1          FOR LOOP SPEED                       DMT36670
         LA    R13,OCMPSTOP        FOR LOOP SPEED                       DMT36680
         LA    R6,4                Start compression counter   HRC001DT DMT36690
OCOMP1   DS    0H                  CONTINUE COMPRESSION TESTING         DMT36700
         CLC   OTS+3(1,R8),OTS+4(R8) DOES MATCH CONTINUE                DMT36710
         BCR   7,R13               BR IF NO (TO CMPSTOP)                DMT36720
         AR    R6,R15              ANOTHER MATCH... COUNT IT            DMT36730
         AR    R8,R15              UP TO NEXT CHAR                      DMT36740
         BR    R14                 CONTINUE (TO OCOMP1)                 DMT36750
         SPACE 1                                                        DMT36760
OMVC1A   MVC   OTEMP(*-*),OTS(R4) EXECUTED BY ABOVE CODE       @VA04175 DMT36770
OMVC1B   MVC   3(*-*,R5),OTEMP EXECUTED BY ABOVE CODE          @VA04175 DMT36780
         SPACE 1                                                        DMT36790
OCMPSTOP DS    0H                  IDENTICAL STRING ENDED               DMT36800
         CH    R6,=H'31'           DOES IT EXCEED SCB...                DMT36810
         BH    OBIGPROP            BR IF YES                            DMT36820
         STH   R6,$TEMP            TO TEMPORARY STORAGE                 DMT36830
         OI    $TEMP+1,X'80'       SET SCB ALWAYS BIT                   DMT36840
         MVC   2(1,R5),$TEMP+1     SET SCB                              DMT36850
         CLI   OTS+3(R8),C' '      ARE WE SQUEEZING BLANKS              DMT36860
         BE    OBLANK              BR IF YES                            DMT36870
         MVC   3(1,R5),OTS+3(R8)   SET DUPLICATION CHAR                 DMT36880
         OI    2(R5),X'20'         SHOW NON-BLANK DUPLICATION           DMT36890
         AR    R5,R15              SKIP SAMPLE CHAR                     DMT36900
OBLANK   DS    0H                                                       DMT36910
         AR    R5,R15              COUNT SCB                            DMT36920
         LA    R8,4(,R8)           Up to next                  HRC001DT DMT36930
         B     OGO                 AND CONTINUE RECORD                  DMT36940
         EJECT                                                          DMT36950
OBIGPROP DS    0H                  DUPLICATION COUNT EXCEEDS SCB        DMT36960
         MVI   2(R5),X'9F'         SHOW MAX SCB                         DMT36970
         CLI   OTS+3(R8),C' '      IS THIS BLANKS                       DMT36980
         BE    OBIGBLNK            BR IF YES                            DMT36990
         MVC   3(1,R5),OTS+3(R8)   SET SAMPLE CHAR                      DMT37000
         OI    2(R5),X'20'         SHOW NON-BLANK                       DMT37010
         AR    R5,R15              COUNT SAMPLE                         DMT37020
OBIGBLNK DS    0H                  EXCESSIVE COUNT BLANKS               DMT37030
         AR    R5,R15              COUNT SCB                            DMT37040
         SH    R6,=H'31'           ADJUST COUNT                         DMT37050
         B     OCMPSTOP            AND TRY AGAIN                        DMT37060
         SPACE 1                                                        DMT37070
OBIGMOVE DS    0H                  STRING COUNT EXCEEDS SCB MAXIMUM     DMT37080
         MVC   3(63,R5),OTS(R4)    MOVE MAX                             DMT37090
         MVI   2(R5),X'FF'         SET MAX SCB                          DMT37100
         LA    R5,64(,R5)          Add in count                HRC001DT DMT37110
         LA    R4,63(,R4)          Add in count                HRC001DT DMT37120
         SH    R6,=H'63'           REDUCE COUNT                         DMT37130
         B     OSQUEEZE            AND TRY AGAIN                        DMT37140
         SPACE 1                                                        DMT37150
OEOINCHK EQU   *                                               @VA03480 DMT37160
         CLC   TANKRCB(1),WCTRCBR  Messages?                   SML2NJE4 DMT37170
         BE    OFLUSH         JUST FLUSH THE BUFFER AS IS      @VA03480 DMT37180
         EJECT                                                          DMT37190
*---------------------------------------------------------------------* DMT37200
*                                                                     * DMT37210
*              END OF INPUT RECORD - TERMINATE AND ADD TO BUFFER      * DMT37220
*                                                                     * DMT37230
*---------------------------------------------------------------------* DMT37240
         SPACE 1                                                        DMT37250
OEOINPUT EQU   *                                                        DMT37260
         MVI   2(R5),0             END-OF-RECORD SCB                    DMT37270
         AR    R5,R15              COUNT IT                             DMT37280
         L     R8,OINADD           STARTING ADDR OF COMPRESSED REC      DMT37290
         SR    R5,R8               REDUCE TO ACTUAL COUNT               DMT37300
         SH    R5,=AL2(L'TANKCHN-2) COMPENSATE FOR FULL CHAIN WORD      DMT37310
         STH   R5,TANKCHN          SAVE COUNT IN TANK FOR $TPREPUT      DMT37320
OREENT   DS    0H                  RE-ENTRY POINT FROM $TPREPUT         DMT37330
         L     R6,OBUFPTR          GET ADDR OF ACTIVE BUFFER            DMT37340
         LTR   R6,R6               End?                        HRC001DT DMT37350
         BE    OGETBUF             BR IF NO                             DMT37360
OBUFOK   DS    0H                  VALID BUFFER                         DMT37370
         CH    R5,OBUFCNT          WILL THIS RECORD FIT...              DMT37380
         BH    OBUFFULL            BR IF NO                             DMT37390
         EX    R5,OMVC2            MOVE RECORD                          DMT37400
         AR    R6,R5               UPDATE CURRENT PTR                   DMT37410
         ST    R6,OBUFPTR          AND RESET                            DMT37420
         LH    R6,OBUFCNT          REMAINING COUNT                      DMT37430
         SR    R6,R5               REDUCE BY THIS RECORD                DMT37440
         STH   R6,OBUFCNT          AND RESET                            DMT37450
         CH    R5,=H'3'            WAS THIS A NULL RECORD               DMT37460
         BE    OFLUSH              BR IF YES TO WRITE BUFFER            DMT37470
         CLC   TANKRCB(1),WCTRCBR  Is this operator command?   SML2NJE4 DMT37480
         BE    OFLUSH              BR IF YES TO SEND BUFFER             DMT37490
ORETOK   DS    0H                  POSITIVE RETURN ENTRY                DMT37500
         OI    BUFSYNSW,OFLSW      OPEN NORMAL GATE AND SET COND CODE   DMT37510
ORETURN  DS    0H                  RETURN--COND. CODE ALREADY SET       DMT37520
         L     R8,OINADD           RESTORE TANK ADDR                    DMT37530
         L     R6,OSAVR6           RESTORE REG                          DMT37540
         L     R5,OSAVR5           RESTORE REG                          DMT37550
         L     R14,OSAVR14         GET RETURN                           DMT37560
         BR    R14                 AND DO IT                            DMT37570
         SPACE 1                                                        DMT37580
OMVC2    MVC   0(0,R6),L'TANKCHN(R8) TO BE EXECUTED FROM ABOVE          DMT37590
         EJECT                                                          DMT37600
OGETBUF  DS    0H                                                       DMT37610
         TM    BUFSYNSW,$TPPNONE   SHOULD WE STOP BUFFERING?            DMT37620
         BO    OGETBUF1       BUFFERING STOP                   @VA03306 DMT37630
         CLC   $BUFPOOL,=F'0'      ARE WE EMPTY?                        DMT37640
         BE    ORETURN             BR IF NONE (NOTE COND. CODE SET)     DMT37650
         L     R6,$BUFPOOL         GET FIRST BUFFER ADDR                DMT37660
         CLC   0(4,R6),=F'0'  ONLY ONE LEFT????                @VA03301 DMT37670
         BE    ORETURN        YEP...BETTER NOT USE IT          @VA03301 DMT37680
         MVC   $BUFPOOL(4),0(R6)   REMOVE THIS ONE FROM CHAIN           DMT37690
         ST    R6,OACTBUF          SET BUFFER ADDR                      DMT37700
         LA    R6,BUFDATA-BUFDSECT(,R6)                        HRC001DT DMT37710
         ST    R6,OBUFPTR          SET CURRENT POINTER                  DMT37720
         L     R14,TPBUFSIZ        GET TP BUFFER SIZE                   DMT37730
         SH    R14,=Y(BUFDATA+2-BUFSTART+2) ALLOW FOR HDR,ETB  @VA03348 DMT37740
         STH   R14,OBUFCNT         AND SAVE                             DMT37750
         B     OBUFOK              AND GO FIT RECORD                    DMT37760
         SPACE 1                                                        DMT37770
OGETBUF1 EQU   *                                               @VA03306 DMT37780
         SR    R6,R6          SET CONDITION CODE FIRST         @VA03306 DMT37790
         B     ORETURN        AND RETURN                       @VA03306 DMT37800
         EJECT                                                          DMT37810
*---------------------------------------------------------------------* DMT37820
*                                                                     * DMT37830
*              BUFFER IS FULL--SEND IT                                * DMT37840
*                                                                     * DMT37850
*---------------------------------------------------------------------* DMT37860
         SPACE 1                                                        DMT37870
OFLUSH   DS    0H                  ENTRY TO WRITE A PARTIAL BUFFER      DMT37880
         NI    BUFSYNSW,255-OFLSW  SET FLUSH SWITCH                     DMT37890
OBUFFULL DS    0H                                                       DMT37900
         L     R6,OBUFPTR          GET CURRENT BUFFER POINTER           DMT37910
         L     R13,OACTBUF         FOR $EXTP                            DMT37920
         USING BUFDSECT,R13        GET TP BUFFER ADDRESSABILITY         DMT37930
         MVI   0(R6),0             SET EOB                              DMT37940
         SR    R6,R13              SUBTRACT SOB                         DMT37950
         SH    R6,=Y(BUFSTART-BUFDSECT-1) MAKE COUNT ACTUAL             DMT37960
         STH   R6,BUFCOUNT         SET COUNT                            DMT37970
         SR    R6,R6               ZERO                                 DMT37980
         ST    R6,OBUFPTR          AND SHOW NO BUFFER                   DMT37990
         SPACE 1                                                        DMT38000
         USING BUFDSECT,R13        BUFFER ADDR IS IN R13                DMT38010
         LA    R6,$OUTBUF          QUEUE CONTROL WORD                   DMT38020
OBUFLOP  EQU   *                                                        DMT38030
         CLC   0(4,R6),=F'0'       IS IT THE LAST.QUEUE FOR TRANS       DMT38040
         BE    OBUFLOP1            YES                                  DMT38050
         L     R6,0(0,R6)          GET THE NEXT ONE                     DMT38060
         B     OBUFLOP             AND COMPARE                          DMT38070
         SPACE 1                                                        DMT38080
OBUFLOP1 EQU   *                                                        DMT38090
         ST    R13,0(0,R6)         CHAIN THIS ONE TO IT                 DMT38100
         MVC   0(4,R13),=F'0'      SET NEW FORWARD ZERO                 DMT38110
         SPACE 1                                                        DMT38120
         TM    BUFSYNSW,OFLSW      SHOULD WE FLUSH THE BUFFER?          DMT38130
         BO    OGETBUF             NO                                   DMT38140
         B     ORETOK              JUST RETURN IF FLUSH                 DMT38150
         DROP  R13                                                      DMT38160
         EJECT                                                          DMT38170
*---------------------------------------------------------------------* DMT38180
*                                                                     * DMT38190
*              RE-ENTRY POINT IF ORIGINAL $TPPUT NOT ACCEPTED         * DMT38200
*                R8=ORIGINAL TANK , R14= RETURN                       * DMT38210
*                                                                     * DMT38220
*---------------------------------------------------------------------* DMT38230
         SPACE 1                                                        DMT38240
$TPREPUT DS    0H                                                       DMT38250
         ST    R8,OINADD           SET FOR RESTORE                      DMT38260
         ST    R14,OSAVR14         RESET RETURN                         DMT38270
         ST    R5,OSAVR5           SAVE REG                             DMT38280
         ST    R6,OSAVR6           SAVE REG                             DMT38290
         LA    R15,1               Constant                    HRC001DT DMT38300
         LH    R5,TANKCHN          COMPRESSED COUNT                     DMT38310
         B     OREENT              ENTER FLOW                           DMT38320
         DROP  R8                                                       DMT38330
OTS      EQU   8                                                        DMT38340
         EJECT                                                          DMT38350
*.                                                                      DMT38360
*                                                                       DMT38370
* ENTRY NAME -                                                          DMT38380
*                                                                       DMT38390
*        $TPGET                                                         DMT38400
*                                                                       DMT38410
* FUNCTION -                                                            DMT38420
*                                                                       DMT38430
*        THIS ROUTINE DEBLOCKS RECEIVED TELECOMMUNICATIONS              DMT38440
*        BUFFERS INTO TANKS AND QUEUES THE TANK ONTO THE                DMT38450
*        APPROPRIATE PROCESSORS TCTTANK QUEUE.                          DMT38460
*                                                                       DMT38470
* CALLS TO OTHER ROUTINES -                                             DMT38480
*                                                                       DMT38490
*        NONE                                                           DMT38500
*                                                                       DMT38510
* OPERATION -                                                           DMT38520
*                                                                       DMT38530
*        1. GET A BUFFER FROM $INPUF QUEUE AND LOOK FOR                 DMT38540
*           A MATCHING TCT TO ATTACH THE BUFFER TO BY COMPARING         DMT38550
*           RCBS.                                                       DMT38560
*                                                                       DMT38570
*        2. GET A TANK TO DECOMPRESS A BUFFER INTO.                     DMT38580
*                                                                       DMT38590
*        3. DECOMPRESS THE BUFFER INTO THE TANK                         DMT38600
*                                                                       DMT38610
*        4. CHAIN THE TANK TO THE TCT TANK QUEUE FOR THE                DMT38620
*           PROCESSOR BEING SERVICED AND OPEN THE COMMUTATOR            DMT38630
*           GATE FOR THAT PROCESSOR.                                    DMT38640
*                                                                       DMT38650
* RESPONSES -                                                           DMT38660
*                                                                       DMT38670
*        NONE                                                           DMT38680
*                                                                       DMT38690
* ERROR MESSAGES -                                                      DMT38700
*                                                                       DMT38710
*        NONE                                                           DMT38720
*                                                                       DMT38730
*.                                                                      DMT38740
         SPACE 3                                                        DMT38750
*                                                                       DMT38760
*                                                                       DMT38770
$TPGET   DS    0H                  ENTERED FROM COMUTATOR               DMT38780
         MVI   $TPGETCM+1,CLOSE    CLOSE COMMUTATOR                     DMT38790
GDQ      EQU   *                                                        DMT38800
         TM    BUFSYNSW,GDQBUFS    STOP ALL BUFFERING?                  DMT38810
         BO    GWAIT               YES                                  DMT38820
GDQBUFS1 DS    0H                  BEGIN DEQUEUING CYCLE                DMT38830
         CLC   $INBUF,=F'0'        ARE WE EMPTY?                        DMT38840
         BE    GCONTTCT            YES                                  DMT38850
         L     R6,$INBUF           GET FIRST BUFFER ADDR                DMT38860
         MVC   $INBUF(4),0(R6)     REMOVE THIS ONE FROM CHAIN           DMT38870
         SPACE 1                                                        DMT38880
GDQBUFS2 EQU   *                                                        DMT38890
         LA    R8,BUFDATA-BUFDSECT DATA DISPLACEMENT                    DMT38900
         AR    R8,R6               R8=ACTUAL DATA ADDRESS               DMT38910
         BAL   R14,GASSIGN         GO ATTACH BUFFER TO TCT              DMT38920
         B     GDQBUFS1            AND CHECK AGAIN                      DMT38930
         SPACE 1                                                        DMT38940
GCONTTCT DS    0H                  SERVICE TCT'S                        DMT38950
         OI    BUFSYNSW,GDQBUFS    CLOSE DEQUE SW                       DMT38960
         SPACE 1                                                        DMT38970
         LA    R13,$TCT1           BEGINNING OF TCT'S                   DMT38980
         USING TCTDSECT,R13        **                                   DMT38990
GTEST    DS    0H                  *                                    DMT39000
         TM    TCTSTAT,TCTACT      IS ACTION REQUESTED                  DMT39010
         BO    GSERVICE            BR IF YES                            DMT39020
GNEXTTCT DS    0H                                                       DMT39030
         ICM   R13,B'1111',TCTNEXT TO NEXT TCT AND CHECK FOR END        DMT39040
         BNZ   GTEST               BR IF NO                             DMT39050
*                                                                       DMT39060
*              ALL TCT'S HAVE BEEN SERVICED...                          DMT39070
*                                                                       DMT39080
         B     GDQ                 GO TEST FOR MORE BUFFERS             DMT39090
         EJECT                                                          DMT39100
*                                                                       DMT39110
*              SERVICE TCT WITH ACTION BIT ON                           DMT39120
*                                                                       DMT39130
GSERVICE DS    0H                                                       DMT39140
         CLI   TCTBUFCT,0          ARE ANY BUFFERS AVAILABLE            DMT39150
         BNE   GTTANK              BR IF YES                            DMT39160
GNOACT   EQU   *                                                        DMT39170
         NI    TCTSTAT,255-TCTACT  NO... TURN OFF ACTION                DMT39180
         B     GNEXTTCT            AND CONTINUE                         DMT39190
         SPACE 1                                                        DMT39200
GTTANK   DS    0H                  A BUFFER IS PRESENT                  DMT39210
         CLC   TCTTNKCT,TCTTNKLM   ARE SUFFICIENT TANKS QUEUED          DMT39220
         BNL   GNOACT              BR IF YES                            DMT39230
         SPACE 1                                                        DMT39240
*                   A DECOMPRESSION IS REQUIRED                         DMT39250
         CLC   $TANKPOL,=F'0'      ARE WE EMPTY                         DMT39260
         BE    GWAIT                                                    DMT39270
         L     R5,$TANKPOL         GET FIRST BUFFER ADDR                DMT39280
         MVC   $TANKPOL(4),0(R5)   REMOVE THIS ONE FROM CHAIN           DMT39290
         USING TANKDSEC,R5         *                                    DMT39300
         MVI   TANKDATA,C' '  SET TO CLEAR TANK                @VA06381 DMT39310
         MVC   TANKDATA+1(L'TANKDATA-1),TANKDATA Clear tank    SML2NJE4 DMT39320
         L     R8,TCTBUFER         CURRENT BUFFER                       DMT39330
         LH    R15,(BUFCOUNT-BUFDSECT)(0,R8) GET COUNT                  DMT39340
         AR    R8,R15              ADD TO CURRENT COUNT                 DMT39350
         ST    R5,GTANK            SAVE TANK ADDR.                      DMT39360
         MVC   TANKRCB(2),0(R8)    MOVE RCB AND SRCB                    DMT39370
         LA    R15,1               Constant for speed          HRC001DT DMT39380
         CLI   0(R8),X'F0'    IS IT A GENERAL CONTROL RCB?     @VA03347 DMT39390
         BNE   GDECOMP        NO, GO & DECOMPRESS THE BUFFER   @VA03347 DMT39400
         MVC   TANKDATA(78),2(R8) YES, MOVE 78 BYTES INTO TANK @VA03347 DMT39410
         LA    R8,78(R8)      UPDATE POINTER IN BUFFER         @VA03347 DMT39420
         LA    R5,78(R5)      UPDATE POINTER IN TANK           @VA03347 DMT39430
         MVI   2(R8),X'00'    PUT ENDING SCB INTO BUFFER       @VA03347 DMT39440
         MVI   3(R8),X'00'    PUT ENDING RCB INTO BUFFER       @VA03347 DMT39450
         MVI   4(R8),XETB     PUT ETB INTO BUFFER              @VA03347 DMT39460
         B     GENDREC        GO TO PROCESS END OF RECORD      @VA03347 DMT39470
         EJECT                                                          DMT39480
*---------------------------------------------------------------------* DMT39490
*                                                                     * DMT39500
*                      DECOMPRESS A TP BUFFER                         * DMT39510
*                                                                     * DMT39520
*---------------------------------------------------------------------* DMT39530
         SPACE 1                                                        DMT39540
GDECOMP  DS    0H                  PROCESS AN SCB                       DMT39550
         MVC   GSCB(1),2(R8)       SET SCB                              DMT39560
         NI    GSCB,X'7F'          TURN OFF HIGH-BIT                    DMT39570
         BZ    GENDREC             END-OF-RECORD                        DMT39580
         MVC   GSCBCK(1),GSCB GET SCB TO TEST                  @VA06382 DMT39590
         TM    GSCBCK,X'40'   IS IT CHAR STRING                @VA06382 DMT39600
         BO    SCBCK          YES CHANGE STRIP COUNT           @VA06382 DMT39610
         NI    GSCBCK,X'1F'   STRIP THE INDICATOR BITS         @VA06382 DMT39620
SCCK2    SR    R6,R6          CLEAR R6                         @VA06382 DMT39630
         IC    R6,GSCBCK      GET STRING CONTROL BYTE          @VA06382 DMT39640
         AR    R6,R5          ADD TANK COUNT                   @VA06382 DMT39650
         S     R6,GTANK       SUBTRACT START ADDRESS           @VA06382 DMT39660
         CH    R6,TNKEND      WILL IT GO OVER TANK END         @VA06382 DMT39670
         BH    COMPERR        YES ERROR DONT DO IT             @VA06382 DMT39680
         TM    GSCB,X'40'          IS THIS A CHAR STRING...             DMT39690
         BZ    GPROP               BR IF NOT                            DMT39700
         NI    GSCB,X'3F'          TURN OFF STRING BIT                  DMT39710
         SR    R6,R6               CLEAR OUT R6 FOR IC                  DMT39720
         IC    R6,GSCB             GET STRING CONTROL BYTE              DMT39730
         EX    R6,GMVC1            MOVE BUFFER                          DMT39740
         AR    R8,R6               COUNT INPUT STRING                   DMT39750
GCONT    EQU   *                                                        DMT39760
         AR    R5,R6               COUNT OUTPUT STRING                  DMT39770
         AR    R8,R15              COUNT SCB                            DMT39780
         B     GDECOMP             CONTINUE WITH RECORD                 DMT39790
         SPACE 1                                                        DMT39800
GPROP    DS    0H                  PROPGATION REQUIRED                  DMT39810
         TM    GSCB,X'20'          IS THIS BLANKS...                    DMT39820
         BZ    GBLANKS             BR IF YES                            DMT39830
         NI    GSCB,X'1F'          NO .. REMOVE INDICATOR               DMT39840
         MVC   TANKDATA(1),3(R8)   SET SAMPLE CHARACTER                 DMT39850
         SR    R6,R6               CLEAR OUT R6 FOR IC                  DMT39860
         IC    R6,GSCB             GET STRING CONTROL BYTE              DMT39870
         BCTR  R6,0           REDUCE BY ONE FOR TANKDATA       @VA06381 DMT39880
         LTR   R6,R6                   IS MOVE FOR 1 BYTE ONLY @VA07697 DMT39890
         BZ    GDECONE                 YES,DONT DECREMENT MORE @VA07697 DMT39900
         BCTR  R6,0           REDUCE BY ONE FOR MOVE           @VA06381 DMT39910
         EX    R6,GMVC2            PROPAGATE COUNT (+2)                 DMT39920
         AR    R8,R15              COUNT SAMPLE CHAR                    DMT39930
         LA    R6,2(0,R6)     CORRECT CHAR COUNT               @VA06381 DMT39940
         B     GCONT               AND ENTER FLOW                       DMT39950
GDECONE  EQU   *                       EXPAND ONE BYTE ONLY    @VA07697 DMT39960
         AR    R8,R15                  COUNT SAMPLE CHAR       @VA07697 DMT39970
         LA    R6,1(0,R6)              CORRECT CHAR COUNT      @VA07697 DMT39980
         B     GCONT                   CONTINUE PROCESSING     @VA07697 DMT39990
         SPACE 1                                                        DMT40000
GBLANKS  DS    0H                  BLANK PROPAGATION REQUIRED           DMT40010
         MVI   TANKDATA,C' '       SET BLANK SAMPLE                     DMT40020
         SR    R6,R6               CLEAR OUT R6 FOR IC                  DMT40030
         IC    R6,GSCB             GET STRING CONTROL BYTE              DMT40040
         BCTR  R6,0           REDUCE BY ONE FOR MOVE           @VA06381 DMT40050
         EX    R6,GMVC2            PROPAGATE BLANKS                     DMT40060
         AR    R6,R15         CORRECT CHAR COUNT               @VA06381 DMT40070
         B     GCONT               ENTER FLOW                           DMT40080
         SPACE 1                                                        DMT40090
GMVC1    MVC   TANKDATA(0),3(R8)   TO BE EXECUTED BY ABOVE CODE         DMT40100
GMVC2    MVC   TANKDATA+1(0),TANKDATA TO BE EXECUTED BY ABOVE CODE      DMT40110
COMPERR  DS    0H             HERE ON COMPRESSION ERROR        @VA06382 DMT40120
         MSGX  937,AXSLINK    WRITE ERROR MSG                  @VA06382 DMT40130
         B     EOJ            GO TO END THIS                   @VA06382 DMT40140
SCBCK    NI    GSCBCK,X'3F'   USE THIS STRIP COUNT             @VA06382 DMT40150
         B     SCCK2          GO BACK TO TEST LENGTH           @VA06382 DMT40160
TNKEND   DC    AL2(TANKEND-TANKDSEC) Total tank length         SML2NJE4 DMT40170
         EJECT                                                          DMT40180
GENDREC  DS    0H                  END OF LOGICAL RECORD                DMT40190
         L     R6,GTANK            TANK ADDR                            DMT40200
         SR    R5,R6               FROM END PTR                         DMT40210
         DROP  R5                                                       DMT40220
         USING TANKDSEC,R6         GET TANKDSEC ADDRESSABILTIY          DMT40230
         STH   R5,TANKCNT          SET COUNT IN TANK                    DMT40240
         LA    R5,TCTTANK-TCTDSECT TANK CHAIN DISPLACEMENT              DMT40250
         AR    R5,R13              R5 = ABSOLUTE TANK CHAIN PTR         DMT40260
GENDREC1 EQU   *                                                        DMT40270
         CLC   0(4,R5),=F'0'       IS IT THE LAST?                      DMT40280
         BE    GENDREC2            YES                                  DMT40290
         L     R5,0(0,R5)          GET THE NEXT ONE                     DMT40300
         B     GENDREC1            AND COMPARE                          DMT40310
         SPACE 1                                                        DMT40320
GENDREC2 EQU   *                                                        DMT40330
         ST    R6,0(0,R5)          CHAIN THIS ONE TO IT                 DMT40340
         MVC   0(4,R6),=F'0'       SET NEW FORWARD ZERO                 DMT40350
         LA    R8,3(,R8)           Add in three                HRC001DT DMT40360
         LH    R5,TCTTNKLM         LIMIT AND COUNT                      DMT40370
         AR    R5,R15              INCREMENT COUNT                      DMT40380
         STH   R5,TCTTNKLM         AND RESET                            DMT40390
         L     R5,TCTCOM           GET COMMUTATOR ENTRY                 DMT40400
         MVI   1(R5),OPEN          OPEN PROCESSOR GATE                  DMT40410
         L     R6,TCTBUFER         CURRENT BUFFER ADDR                  DMT40420
         CLC   TCTRCBR,0(R8)       IS NEXT RECORD SAME                  DMT40430
         BNE   GSWITCH             BR IF NO                             DMT40440
         SR    R8,R6               REDUCE TO DATA DISPLACEMENT          DMT40450
         STH   R8,BUFCOUNT-BUFDSECT(0,R6)                               DMT40460
         B     GTTANK              AND CONTINUE                         DMT40470
         SPACE 1                                                        DMT40480
GSWITCH  DS    0H                  DIFFERENT RCB ENCOUNTERED            DMT40490
         NI    BUFSYNSW,255-GDQBUFS ALLOW DEQUEUING TRY                 DMT40500
         MVC   TCTBUFER,0(R6)      UPDATE CHAIN                         DMT40510
         BAL   R14,GASSIGN         GO RE-ASSIGN BUFFER                  DMT40520
         LH    R8,TCTBUFLM         BUFFER LIMIT AND COUNT               DMT40530
         BCTR  R8,0                REDUCE COUNT                         DMT40540
         STH   R8,TCTBUFLM         AND RESET                            DMT40550
         CLC   TCTBUFCT,TCTBUFLM   IS ANOTHER BUFFER REQUIRED           DMT40560
         BNL   GSERVICE            BR IF NO TO CONTINUE                 DMT40570
         OC    $FCSOUT,TCTFCS      SHOW NEXT BUFFER PERMITTED           DMT40580
         B     GSERVICE            AND CONTINUE                         DMT40590
         EJECT                                                          DMT40600
*---------------------------------------------------------------------* DMT40610
*                                                                     * DMT40620
*                       ASSIGN A TP BUFFER TO A TCT                   * DMT40630
*                                                                     * DMT40640
*              R6=BUFFER ADDRESS , R8=PTR TO CURRENT RCB IN BUFFER    * DMT40650
*                                                                     * DMT40660
*---------------------------------------------------------------------* DMT40670
         SPACE 1                                                        DMT40680
GASSIGN  DS    0H                  ASSIGN BUFFER TO CORRECT TCT         DMT40690
         ST    R13,GAST            PRESERVE TCT REG                     DMT40700
         LA    R13,$TCT1           START OF TCT'S                       DMT40710
GASNEXT  DS    0H                  *                                    DMT40720
         CLC   TCTRCBR,0(R8)       COMPARE RCB'S                        DMT40730
         BE    GASIT               BR IF FOUND                          DMT40740
         ICM   R13,B'1111',TCTNEXT TO NEXT AND CHECK FOR END            DMT40750
         BNZ   GASNEXT             BR IF NO TO CONTINUE                 DMT40760
         CLI   0(R8),0             IS THIS A NULL BUFFER                DMT40770
         BNE   GCTLCHK             BR IF NO                             DMT40780
         SPACE 1                                                        DMT40790
GIGNORIT DS    0H                  *                                    DMT40800
         MVC   0(4,R6),$BUFPOOL    GET FIRST FREE OFF QUEUE             DMT40810
         ST    R6,$BUFPOOL         MAKE THIS ONE THE FIRST              DMT40820
         TM    WCTSTAT,TCTREL      ARE MESSAGES QUEUED?                 DMT40830
         BNO   GIGNORT1            NO CONTINUE                          DMT40840
         OI    $MSGCOM+1,OPEN      OPEN THE MSG GATE                    DMT40850
         B     GASRET              DONT CHECK ANYTHING ELSE TILL LATER  DMT40860
         SPACE 1                                                        DMT40870
GIGNORT1 EQU   *                                                        DMT40880
         CLI   PCTWFB,X'FF'        PRT/PUN awaiting ACK buffer?SML2NJE4 DMT40890
         BNE   GIGNORT2                                        SML2NJE4 DMT40900
         OI    $PCOMM1+1,OPEN      Open the PRT/PUN gate       SML2NJE4 DMT40910
         B     GASRET              And return                  SML2NJE4 DMT40920
GIGNORT2 EQU   *                                               SML2NJE4 DMT40930
         CLI   RCTWFB,X'FF'        READER WAITING?                      DMT40940
         BNE   GASRET              NO - RETURN                          DMT40950
         OI    $RCOMM1+1,OPEN      OPEN THE READER GATE                 DMT40960
         B     GASRET              AND RETURN                           DMT40970
         SPACE 1                                                        DMT40980
GCTLCHK  DS    0H                  TEST FOR CONTROL RECORD              DMT40990
         CLI   0(R8),X'F0'         GENERAL CONTROL RECORD?              DMT41000
         BE    GCTLCHK1            YES GO PROCESS IT                    DMT41010
         TM    0(R8),15            IS RECORD TYPE = 0000                DMT41020
         BNZ   GIGNORIT            NO...SKIP RECORD(AND BUFFER)         DMT41030
GCTLCHK1 EQU   *                                                        DMT41040
         LA    R13,$CTLTCT         TYPE IS CTL...LOAD TCT               DMT41050
         EJECT                                                          DMT41060
GASIT    DS    0H                  TCT FOUND                            DMT41070
         SR    R8,R6               R8 = DATA DISPLACEMENT               DMT41080
         STH   R8,BUFCOUNT-BUFDSECT(0,R6) SAVE                          DMT41090
         LA    R8,TCTBUFER-TCTDSECT ACTUAL DISP                         DMT41100
         AR    R8,R13              ACTUAL ADDRESS                       DMT41110
GASIT1   EQU   *                                                        DMT41120
         CLC   0(4,R8),=F'0'       IS IT THE LAST                       DMT41130
         BE    GASIT2              YES                                  DMT41140
         L     R8,0(0,R8)          GET THE NEXT ONE                     DMT41150
         B     GASIT1              AND COMPARE                          DMT41160
         SPACE 1                                                        DMT41170
GASIT2   EQU   *                                                        DMT41180
         ST    R6,0(0,R8)          CHAIN THIS ONE TO IT                 DMT41190
         MVC   0(4,R6),=F'0'       SET NEW FORWARD ZERO                 DMT41200
         LH    R8,TCTBUFLM         LIMIT AND COUNT                      DMT41210
         LA    R8,1(,R8)           Count this                  HRC001DT DMT41220
         STH   R8,TCTBUFLM         AND RESET                            DMT41230
         OI    TCTSTAT,TCTACT      START ACTION                         DMT41240
         CLC   TCTBUFCT,TCTBUFLM   ARE ENOUGH BUFFERS HERE              DMT41250
         BL    GASRET              BR IF MORE BUFFERS NEEDED            DMT41260
         OC    $FCSOUT,TCTFCS      MODIFY FCS                           DMT41270
         XC    $FCSOUT,TCTFCS      TO STOP THIS STREAM                  DMT41280
GASRET   DS    0H                  RETURN ENTRY                         DMT41290
         L     R13,GAST            AND RETURN                           DMT41300
         BR    R14                 TO CALLER                            DMT41310
         SPACE 1                                                        DMT41320
GWAIT    DS    0H                  PREPARE FOR EXIT                     DMT41330
         NI    BUFSYNSW,255-GDQBUFS OPEN DEQUEUE GATE                   DMT41340
         B     $TPGETCM+4          EXIT                                 DMT41350
         SPACE 1                                                        DMT41360
         DROP  R6,R13              DISCONTINUE TANK REG                 DMT41370
         EJECT                                                          DMT41380
*---------------------------------------------------------------------* DMT41390
*                                                                     * DMT41400
*        $GETTNK           ROUTINE TO GET A TANK FOR PROCESSOR        * DMT41410
*                                                                     * DMT41420
*---------------------------------------------------------------------* DMT41430
         SPACE 1                                                        DMT41440
         USING TCTDSECT,TCTR       GET TCT ADDRESSABILITY               DMT41450
$GETTNK  DS    0H                                                       DMT41460
         ST    R14,TCTSAV1         SAVE USER REG FOR POSSIBLE WAIT      DMT41470
         MVC   TCTENTY(2),OACN2    SET REENTRY FOR POSSIBLE WAIT        DMT41480
OLOC2    EQU   *                                                        DMT41490
         CLC   TCTTANK,=F'0'       ARE WE EMPTY?                        DMT41500
         BE    $CLOSTCT            YES                                  DMT41510
         L     R8,TCTTANK          GET FIRST BUFFER ADDR                DMT41520
         MVC   TCTTANK(4),0(R8)    REMOVE THIS ONE FROM CHAIN           DMT41530
         LH    R6,TCTTNKLM         REDUCES COUNT IN TNKCT               DMT41540
         BCTR  R6,0                DOWN BY ONE                          DMT41550
         STH   R6,TCTTNKLM         AND REPLACE COUNT                    DMT41560
         OI    TCTSTAT,TCTACT      SIGNAL WE HAVE RECEIVED TANK         DMT41570
         MVI   $TPGETCM+1,OPEN     OPEN THE GATE TO TPGET ROUTINE       DMT41580
         L     R14,TCTSAV1         PICK UP USER                         DMT41590
         BR    R14                 RETURN TO HIM                        DMT41600
         SPACE 1                                                        DMT41610
*                                                                       DMT41620
*        $CLOSTCT                  ROUTINE TO CLOSE GATE AND RETURN     DMT41630
*                                                                       DMT41640
$CLOSTCT DS    0H                                                       DMT41650
         L     R6,TCTCOM           PICK UP COMMUTATOR                   DMT41660
         MVI   1(R6),CLOSE         CLOSE GATE                           DMT41670
         B     4(R6)               RETURN TO COMMUTATOR                 DMT41680
         SPACE 1                                                        DMT41690
OACN2    DC    S(OLOC2)            RENTRY POINT                         DMT41700
         EJECT                                                          DMT41710
*---------------------------------------------------------------------* DMT41720
*                                                                     * DMT41730
*                  $TPOPEN -- OPEN A STREAM                           * DMT41740
*                                                                     * DMT41750
*---------------------------------------------------------------------* DMT41760
         SPACE 1                                                        DMT41770
$TPOPEN  DS    0H                                                       DMT41780
         MVI   TTANK+TANKRCB-TANKDSEC,X'90' RCB to open stream SML2NJE4 DMT41790
$TPOPACK EQU   *                                               SML2NJE4 DMT41800
         ST    R14,TSAVA           SAVE CALLER'S                        DMT41810
         ST    R8,TSAVB            REGS                                 DMT41820
         MVC   TTANK+TANKSRCB-TANKDSEC(1),TANKRCB-TANKDSEC(R8) SET FCN  DMT41830
         L     R8,TANKCON          FOR $TPPUT                           DMT41840
         BAL   R14,$TPPUT          GO PUT RECORD                        DMT41850
         L     R8,TSAVB            CALLER'S                             DMT41860
         L     R14,TSAVA           REGS                                 DMT41870
         BR    R14                 RETURN TO CALLER                     DMT41880
         SPACE 1                                                        DMT41890
*---------------------------------------------------------------------* DMT41900
*                                                                     * DMT41910
*                  $TPACKTC -- Acknowledge transmission complete      * DMT41920
*                                                                     * DMT41930
*---------------------------------------------------------------------* DMT41940
$TPACKTC DS    0H                                              SML2NJE4 DMT41950
         MVI   TTANK+TANKRCB-TANKDSEC,X'C0' RCB to Acknowledge SML2NJE4 DMT41960
         B     $TPOPACK                                        SML2NJE4 DMT41970
         EJECT                                                          DMT41980
*.                                                                      DMT41990
*                                                                       DMT42000
* ENTRY NAME -                                                          DMT42010
*                                                                       DMT42020
*        COMSUP                                                         DMT42030
*                                                                       DMT42040
* FUNCTION -                                                            DMT42050
*                                                                       DMT42060
*        THIS ROUTINE IS RESPONSIBLE FOR ALL I/O ON THE                 DMT42070
*        COMMUNICATIONS LINE.  IT DEQUEUES TP BUFFERS FROM              DMT42080
*        $OUTBUF FOR TRANSMISSION AND QUEUES RECEIVED TP BUFFERS        DMT42090
*        ONTO THE $INBUF QUEUE FOR DEBLOCKING BY $TPGET.                DMT42100
*                                                                       DMT42110
* CALLS TO OTHER ROUTINES -                                             DMT42120
*                                                                       DMT42130
*        DMTIOMRQ - TO INITIATE AN I/O OPERATION                        DMT42140
*                                                                       DMT42150
* OPERATION -                                                           DMT42160
*                                                                       DMT42170
*        1. CLOSE THE LINE INTERRUPT ENTRY IN THE COMMUTATOR            DMT42180
*           TABLE AND CHECK CSW FOR ERRORS.                             DMT42190
*                                                                       DMT42200
*        2. CHECK BSC CONTROL CHARACTERS ON THE BUFFER RECEIVED         DMT42210
*           TO DETERMINE THE KIND OF RESPONSE FROM THE LINE             DMT42220
*                                                                       DMT42230
*        3. PROCESS AN ACK RESPONSE BY TRYING TO OBTAIN AN OUTPUT       DMT42240
*           BUFFER AND WRITING IT TO THE LINE.                          DMT42250
*                                                                       DMT42260
*        4. PROCESS STX RESPONSE BY VERIFYING THE BSC CONTROL           DMT42270
*           CHARACTERS AND QUEUEING THE INPUT BUFFER FOR DEBLOCKING     DMT42280
*           BY $TPGET.                                                  DMT42290
*                                                                       DMT42300
*        5. PROCESS NAK RESPONSE REST THE BSC LEADER CHARACTER AND RE-  DMT42310
*           WRITE THE BUFFER.                                           DMT42320
*                                                                       DMT42330
* RESPONSES -                                                           DMT42340
*                                                                       DMT42350
*        NONE                                                           DMT42360
*                                                                       DMT42370
* ERROR MESSAGES -                                                      DMT42380
*                                                                       DMT42390
*        NONE                                                           DMT42400
*                                                                       DMT42410
*.                                                                      DMT42420
         EJECT                                                          DMT42430
         USING LINKTABL,R6         GET LINKTABLE ADDRESSABILITY         DMT42440
COMSUP   EQU   *                                                        DMT42450
$INTRUPT MVI   $COMCOM+5,CLOSE                                          DMT42460
         TM    BUFSYNSW,$COMBUSY   IS THERE COMMUNICATIONS ACTIVE?      DMT42470
         BO    CEXIT               NO                                   DMT42480
         STM   R13,R15,CREGS       SAVE INTERRUPTED REGS                DMT42490
         L     R13,CBUFFER         GET CURRENT BUFFER ADDR              DMT42500
         TM    BUFSYNSW,CUWFAKE    DUMMY I/O                            DMT42510
         BO    CWRTSIO             YES                                  DMT42520
         TM    ADACSW+5,X'BF'      TEST FOR UNEXPECTED ERRORS           DMT42530
         BNZ   CBADERR             BR IF ANY                            DMT42540
         TM    ADACSW+4,X'F3'      TEST OTHER UNUSUAL ENDINGS           DMT42550
         BNZ   CERROR              BR IF ANY                            DMT42560
*              CHANNEL-END , DEVICE-END ASSUMED                         DMT42570
         EJECT                                                          DMT42580
         SPACE 3                                                        DMT42590
$ENDREAD DS    0H                  EXTERNAL ENTRY POINT                 DMT42600
         SPACE 1                                                        DMT42610
         USING BUFDSECT,R13        *                                    DMT42620
CNOLOGAL DS    0H                  ENTRY TO SKIP LOGGING EVERYTHING     DMT42630
         MVC   CCWC+6(2),RDCOUNT       RESET BUFFER SIZE       @VA08725 DMT42640
         TM    XJESYS,PRIMARY      Is remote end primary?      SML2NJE4 DMT42650
         BNO   CNOLOG0             NO CONTINUE                          DMT42660
         CLC   BUFSTART(2),IPRISEQ Did we get the start?       SML2NJE4 DMT42670
         BE    CACKED              YES TREAT LIKE ACK                   DMT42680
CNOLOG0  EQU   *                                                        DMT42690
         BAL   R14,TRTRAN          LOG THE TRANSACTION                  DMT42700
         MVC   CRESP,BUFSTART      GET FIRST RESPONSE BYTE              DMT42710
         XC    TOCNT(2),TOCNT CLEAR TIMEOUT COUNTER            @VA05950 DMT42720
         CLI   CRESP,XDLE          IS IT DLE LEADER...                  DMT42730
         BNE   CNOLOG1             BR IF NO                             DMT42740
         MVC   CRESP,BUFSTART+1    YES... GET REAL RESPONSE             DMT42750
CNOLOG1  EQU   *                                                        DMT42760
         CLI   CRESP,XSOH          IS THIS NON-XPARENT LEADER...        DMT42770
         BE    CINBUF              BR IF YES TO PROCESS TEXT            DMT42780
         CLI   CRESP,XSTX          IS THIS DATA                         DMT42790
         BE    CINBUF              BR IF YES TO PROCESS                 DMT42800
         CLI   CRESP,XACK0         IS THIS WRITE ACKNOWLEDGEMENT        DMT42810
         BE    CACKED              BR IF YES                            DMT42820
         CLI   CRESP,XNAK          WERE WE NAK'ED                       DMT42830
         BE    CNAKED              BR IF YES                            DMT42840
         B     CRESPBAD            UNKNOWN RESPONSE RECEIVED            DMT42850
         EJECT                                                          DMT42860
*                                                                       DMT42870
*              POSITIVE ACKNOWLEDGEMENT OF LAST WRITE RECEIVED          DMT42880
*                                                                       DMT42890
         SPACE 3                                                        DMT42900
CACKED   DS    0H                  ACKNOWLEDGEMENT WAS ACK              DMT42910
         TM    BUFSTAT,BUFTONAK+BUFNAK NAK SENT AFTER T/O      @VA08636 DMT42920
         BO    CNAKNAK                 NAK AFTER T/O ON DATA   @VA08636 DMT42930
         NI    BUFSTAT,X'FF'-BUFTONAK  RESET T/O INDICATOR     @VA08636 DMT42940
         NI    $FCSIN,255-X'40'    TURN OFF WAIT-A-BIT                  DMT42950
         OI    BUFSYNSW,CACKSW     SET ACK RECEIVED                     DMT42960
CWRTOK   DS    0H                                                       DMT42970
         TM    BUFSTAT,BUFFAKE     IS THIS A DUMMY BUFFER               DMT42980
         BO    CWRTNEXT            BR IF YES                            DMT42990
         MVI   BUFSTAT,0           RESET STATUS BYTE                    DMT43000
         MVC   0(4,R13),$BUFPOOL   GET FIRST FREE OFF QUEUE             DMT43010
         ST    R13,$BUFPOOL        MAKE THIS ONE THE FIRST              DMT43020
         TM    WCTSTAT,TCTREL      IS THE MSG PROC WAITING?             DMT43030
         BNO   CWRTOK1             NO CONTINUE                          DMT43040
         OI    $MSGCOM+1,OPEN      OPEN THE MSG GATE                    DMT43050
         B     CWRTNEXT            AND CONTINUE                         DMT43060
         SPACE                                                          DMT43070
CWRTOK1  EQU   *                                                        DMT43080
         CLI   PCTWFB,X'FF'        PRT/PUN waiting to send ACK?SML2NJE4 DMT43090
         BNE   CWRTOK2             No - continue               SML2NJE4 DMT43100
         OI    $PCOMM1+1,OPEN      Open the PRT/PUN gate       SML2NJE4 DMT43110
CWRTOK2  EQU   *                                               SML2NJE4 DMT43120
         CLI   RCTWFB,X'FF'        IS THE READER WAITING?               DMT43130
         BNE   CWRTNEXT            NO - CONTINUE                        DMT43140
         OI    $RCOMM1+1,OPEN      OPEN THE READER GATE                 DMT43150
CWRTNEXT EQU   *                   ENTRY TO START NEXT WRITE            DMT43160
         TM    BUFSYNSW,CACKSW     WAS AN ACK RECEIVED?                 DMT43170
         BO    CNOD                YES                                  DMT43180
         BAL   R15,CSETCOM         MAKE A COMMUTATOR PASS               DMT43190
         BAL   R15,CSETCOM         AND ANOTHER                          DMT43200
CNOD     EQU   *                   ACK BYPASS                           DMT43210
         NI    BUFSYNSW,255-CACKSW RESET SWITCH                         DMT43220
CYCLE    EQU   *                   COMMUTATOR CYCLE POINT               DMT43230
         TM    $FCSIN,X'40'        IS WAIT-A-BIT SET                    DMT43240
         BO    CWAITBIT            BR IF YES                            DMT43250
         MVC   CFCSTEMP(2),$FCSIN MOVE RECEIVED TO TEMP AREA   @VA03301 DMT43260
         NC    CFCSTEMP(2),CFCSSTD SETUP FOR TEST              @VA03301 DMT43270
         XC    CFCSTEMP(2),CFCSSTD TEST AGAINST STANDARD       @VA03301 DMT43280
         BC    4,CWAITBIT     STREAM IS NEGATED                @VA03301 DMT43290
CYCLE1   EQU   *                                               @VA03301 DMT43300
         NI    BUFSYNSW,255-$TPPNONE RESET BUFFERING STOP               DMT43310
         L     R6,XJELINK          Get link table address      HRC000DT DMT43320
         USING LINKTABL,R6         Link table addressability   SML2NJE3 DMT43330
         TM    LFLAG,LHOLD         ARE ARE HELD?                        DMT43340
         BO    CRESPOND       SEND RESPONSE                    @VA05952 DMT43350
         DROP  R6                  Finished with link table    SML2NJE3 DMT43360
         CLC   $OUTBUF,=F'0'       ARE WE EMPTY                         DMT43370
         BE    CRESPOND            YES                                  DMT43380
         L     R13,$OUTBUF         GET FIRST BUFFER ADDR                DMT43390
         MVC   $OUTBUF(4),0(R13)   REMOVE THIS ONE FROM CHAIN           DMT43400
         EJECT                                                          DMT43410
         SPACE 4                                                        DMT43420
CSTNDWRT DS    0H                  ENTRY FOR BUFFER WRITE WITH BCB      DMT43430
         MVC   BUFSTART,XSTXSEQ    SET START OF TEXT HEADER             DMT43440
         OI    BUFSTAT,BUFTEXT     SHOW TEXT BUFFER                     DMT43450
         MVC   CSETBCB(1),CBCBCNTO BCB FOR CURRENT BUFFER               DMT43460
         LH    R15,CBCBCNTO-1      GET CURRENT COUNT                    DMT43470
         LA    R15,1(,R15)         Increment to next           HRC001DT DMT43480
         STH   R15,CBCBCNTO-1      AND SAVE                             DMT43490
         NI    CBCBCNTO,X'80'+15   MODULO 16                            DMT43500
         B     CNWRITE             GO WRITE BUFFER                      DMT43510
         SPACE 3                                                        DMT43520
*                                                                       DMT43530
*              WAIT-A-BIT SEQUENCE RECEIVED                             DMT43540
*                                                                       DMT43550
         SPACE 1                                                        DMT43560
CWAITBIT DS    0H                  *                                    DMT43570
         OI    BUFSYNSW,$TPPNONE   STOP ALL BUFFERING                   DMT43580
         B     CRESPOND            GO RESPOND                           DMT43590
         EJECT                                                          DMT43600
         SPACE 3                                                        DMT43610
CINBUF   DS    0H                  *                                    DMT43620
         TM    BUFSTAT,BUFFAKE         IS THIS A DUMMY BUFFER? @VA08779 DMT43630
         BO    WAITON                  YES, NO CALC REQUIRED   @VA08779 DMT43640
         CLI   BUFDATA,X'E0'       SEE IF HE IS RESETING                DMT43650
         BE    CBCBRSET            AND GO TRY TO RESET THINGS           DMT43660
         LA    R15,BUFSTART-1      GET START OF ACTUAL BUFFER           DMT43670
         A     R15,TPBUFSIZ        POSITION TO END OF BUFFER            DMT43680
         SH    R15,ADACSW+6        SUBSTACT OUT RESIDUAL COUNT          DMT43690
         CLI   0(R15),XETB         WAS ENDING SEQUENCE CORRECT          DMT43700
         BNE   CRESPBAD            BR IF YES TO LOG AND NAK             DMT43710
WAITON   EQU   *                       NO CALC FOR BUFFER REQ  @VA08779 DMT43720
         MVC   $FCSIN,BUFFCS       SET NEW FUNCTION CONTROL             DMT43730
         SPACE 1                                                        DMT43740
*              VERIFY BLOCK CONTROL BYTE COUNT                          DMT43750
         MVC   CBCB(1),BUFBCB      GET BCB COUNT                        DMT43760
         CLC   CBCBCNTI(1),CBCB    DOES RECEIVED MATCH EXPECTED         DMT43770
         BNE   CBCBCHEK            BR IF NO                             DMT43780
         LH    R15,CBCBCNTI-1      GET CURRENT COUNT                    DMT43790
         LA    R15,1(,R15)         To next expected            HRC001DT DMT43800
         STH   R15,CBCBCNTI-1      AND RESET                            DMT43810
         NI    CBCBCNTI,X'80'+15   MOLULO 16                            DMT43820
         SPACE 1                                                        DMT43830
CBCBOK   DS    0H                  ENTRY FROM IGNORE                    DMT43840
         TM    BUFSTAT,BUFFAKE     IS THIS DUMMY BUFFER                 DMT43850
         BO    CWRTOK              BR IF YES TO IGNORE                  DMT43860
         CLI   BUFDATA,X'00'       IS IT A NULL BUFFER?                 DMT43870
         BE    CWRTOK              YES..ALL DONE                        DMT43880
         CLI   BUFDATA+1,C'B'      Q. IF SIGN-OFF RECORD FROM C         DMT43890
         BNE   CNOTOFF             IF NO CONTINUE                       DMT43900
*        Should also check hold, buffers, cancel I/O etc       SML2NJE4 DMT43910
         BAL   R14,CLOSEURS        Close any open UR devices   SML2NJE4 DMT43920
         B     ISIO                Go back to the beginning    SML2NJE4 DMT43930
         SPACE 1                                                        DMT43940
CNOTOFF  EQU   *                                                        DMT43950
         MVI   $TPGETCM+1,OPEN     OPEN TPGETS GATE                     DMT43960
         MVI   BUFSTAT,0           RESET BUFFER STATUS BITS             DMT43970
         LA    R15,$INBUF          QUEUE CONTROL WORD                   DMT43980
CINBUF1  EQU   *                                                        DMT43990
         CLC   0(4,R15),=F'0'      IS IT THE LAST                       DMT44000
         BE    CINBUF2             YES                                  DMT44010
         L     R15,0(0,R15)        GET THE NEXT ONE                     DMT44020
         B     CINBUF1             AND COMPARE                          DMT44030
         SPACE 1                                                        DMT44040
CINBUF2  EQU   *                                                        DMT44050
         ST    R13,0(0,R15)        CHAIN THIS ONE TO IT                 DMT44060
         MVC   0(4,R13),=F'0'      SET NEW FORWARD ZERO                 DMT44070
         B     CWRTNEXT            AND CONTINUE XMISSION                DMT44080
         EJECT                                                          DMT44090
*                                                                       DMT44100
*              RECEIVED BCB CHECK COUNT NOT CORRECT                     DMT44110
*                                                                       DMT44120
CBCBCHEK DS    0H                  DETERMINE DAMAGE                     DMT44130
         TM    CBCB,BCBIGNRE       IS THE IGNORE BIT ON                 DMT44140
         BO    CBCBOK              BR IF YES                            DMT44150
         TM    CBCB,BCBRESET       IS THIS A RESET REQUEST              DMT44160
         BZ    CBCBBAD             BR IF NO                             DMT44170
         MVN   CBCBCNTI(1),CBCB    YES... DO IT                         DMT44180
         B     CBCBOK              AND PROCESS RECORD                   DMT44190
         SPACE 1                                                        DMT44200
CBCBBAD  DS    0H                  BLOCK COUNTS DO NOT AGREE            DMT44210
         MVC   CTEMP+1(1),CBCB     ISOLATE RECEIVED CNT                 DMT44220
         LH    R15,CBCBCNTI-1      GET EXPECTED CNT                     DMT44230
         SH    R15,CTEMP           LESS RECEIVED                        DMT44240
         BP    CBCBBAD1            BR IF TOO LOW                        DMT44250
         AH    R15,=H'16'          MAKE DIFFERENCE POSITIVE             DMT44260
CBCBBAD1 EQU   *                                                        DMT44270
         CH    R15,CMAXDUP         IS DIFFERENCE REASONABLE             DMT44280
         BH    CBLKLOST            BR IF NO                             DMT44290
         B     CWRTOK              IGNORE BLOCK                         DMT44300
         SPACE 2                                                        DMT44310
CBLKLOST DS    0H                  ONE OR MORE BLOCKS ARE LOST          DMT44320
         MVN   CLOSTBCB,CBCB       SET RECEIVED BLOCK COUNT             DMT44330
         MVN   CLSTSRCB,CBCBCNTI   SET EXPECTED BLOCK COUNT             DMT44340
         MVC   BUFCOUNT(CLOSTEND-CLOSTBLK),CLOSTBLK SET BAD BLOCK       DMT44350
         MVC   CSETBCB(1),CLOSTBCB SET RESTORE BCB INSTRUCTION V03.1    DMT44360
         B     CNWRITE             GO TELL OTHER SIDE ABOUT BAD BCB     DMT44370
         EJECT                                                          DMT44380
         SPACE 3                                                        DMT44390
CRESPOND DS    0H                  ENTRY TO RESPOND                     DMT44400
         L     R6,XJELINK          Get link table address      HRC000DT DMT44410
         CLC   $BUFPOOL,=F'0'      ARE WE EMPTY?                        DMT44420
         BE    CSTOPIN             YES                                  DMT44430
         L     R13,$BUFPOOL        GET FIRST BUFFER ADDR                DMT44440
         MVC   $BUFPOOL(4),0(R13)  REMOVE THIS ONE FROM CHAIN           DMT44450
         B     CBUFGOTN            BR IF GOTTEN                         DMT44460
         SPACE 1                                                        DMT44470
CSTOPIN  DS    0H                  ENTRY TO STOP ALL INPUT              DMT44480
         LA    R13,CDUMMY          USE DUMMY BUFFER                     DMT44490
         MVI   BUFDATA,0           SET NULL BUFFER RCB                  DMT44500
         MVI   BUFSTAT,BUFFAKE     FORCE STATUS TO DUMMY                DMT44510
         B     CSTNDWRT            GO DO NORMAL WRITE                   DMT44520
         SPACE 1                                                        DMT44530
CBUFGOTN DS    0H                                                       DMT44540
         MVI   BUFDATA,0           SET NULL BUFFER RCB                  DMT44550
         MVC   BUFCOUNT,=AL2(CDUMEND-CDUMSTRT) SET WRITE COUNT          DMT44560
         CLC   CFCSOUT,$FCSOUT     HAS FCS BEEN CHANGED                 DMT44570
         BNE   CSTNDWRT            BR IF YES TO DO NORMAL WRITE         DMT44580
         MVC   BUFSTART,XACKSEQ    SETUP STANDARD SEQUENCE              DMT44590
CSENDRES DS    0H                  *                                    DMT44600
         OI    BUFSTAT,BUFRESP     SHOW RESPONSE BUFFER                 DMT44610
         B     CNWRITE             AND GO WRITE                         DMT44620
         EJECT                                                          DMT44630
*                                                                       DMT44640
*              A NEGATIVE RESPONSE RECEIVED                             DMT44650
*                                                                       DMT44660
         SPACE 3                                                        DMT44670
CNAKED   DS    0H                  PREPARE TO RETRANSMIT                DMT44680
         TM    BUFSTAT,BUFNAK      WERE WE SENDING A NAK                DMT44690
         BO    CNAKNAK             BR IF YES                            DMT44700
         MVC   BUFSTART(10),CBUFLAST RESET START OF BUFFER     @VA05474 DMT44710
         TM    BUFSTAT,BUFTEXT     WAS THIS A TEXT BUFFER               DMT44720
         BO    CREWRITE            BR IF YES TO RETRY                   DMT44730
         MVC   BUFSTART(2),XACKSEQ SETUP STANDARD SEQUENCE     @VA05470 DMT44740
         B     CWRTSIO             AND GO WRITE IT                      DMT44750
         SPACE 1                                                        DMT44760
CNAKNAK  DS    0H                  OUR NAK WAS NAK'ED                   DMT44770
         TM    BUFSTAT,BUFTEXT     WAS ORIGINAL BUFFER TEXT...          DMT44780
         BZ    CWRTOK              NO...FORGET IT                       DMT44790
*                                  YES...PREPARE TO RESEND              DMT44800
         MVC   BUFSTART,XSTXSEQ    RESET TEXT LEADERS                   DMT44810
         NI    BUFSTAT,X'FF'-BUFTONAK-BUFNAK-BUFRESP RESET BITS@VA08636 DMT44820
         B     CNWRITE             WRITE BUFFER AGAIN                   DMT44830
         SPACE 5                                                        DMT44840
*                                                                       DMT44850
*              UNKNOWN RESPONSE ... RESEND LAST DATA                    DMT44860
*                                                                       DMT44870
CRESPBAD DS    0H                                                       DMT44880
         SPACE 3                                                        DMT44890
*                                                                       DMT44900
*              SEND A NEGATIVE RESPONSE                                 DMT44910
*                                                                       DMT44920
CSENDNAK DS    0H                  ENTRY                                DMT44930
         MVC   BUFSTART,XNAKSEQ    SET NAK SEQUENCE                     DMT44940
         OI    BUFSTAT,BUFRESP+BUFNAK SHOW NAK RESPONSE                 DMT44950
         B     CNWRITE             AND GO WRITE IT                      DMT44960
         EJECT                                                          DMT44970
*                                                                       DMT44980
*                     A RESET BCB RECEIVED FROM OTHER END               DMT44990
*                     THE PROCEDURE USED HERE IS TO TREAT A RESET       DMT45000
*                     AS A NAK REPLACE THE FIRST 9 BYTES OF BUFFER      DMT45010
*                     AND RETRANSMIT WITH CORRECTED BCB COUNT           DMT45020
*                                                                       DMT45030
         SPACE 2                                                        DMT45040
CBCBRSET DS    0H                                                       DMT45050
*********************************************************************** DMT45060
* A BCB SEQUENCE CHECK WILL MEAN THAT A BLOCK OF DATA HAS BEEN LOST     DMT45070
* AND INTEGRITY OF THE DATA IS NOW QUESTIONABLE. THE ONLY RECOURSE      DMT45080
* TO ENSURE THE ENTIRE DATA SET IS COMPLETE IS TO TERMINATE THE         DMT45090
* LINK AND HAVE IT STARTED AGAIN WITH THE REMOTE OPERATOR FORWARD       DMT45100
* SPACE TO THE POINT OF BLOCK CHECK AND RESUMMING THE DATA SET AGAIN    DMT45110
*********************************************************************** DMT45120
         B     EOJ                     TERMINATE LINK NOW      @VA08633 DMT45130
         EJECT                                                          DMT45140
*                                                                       DMT45150
*              COMSUP IS EXITING WITHOUT I/O ACTIVE                     DMT45160
*              PREPARE FOR RE-ENTRY THROUGH COMUTATOR                   DMT45170
*                                                                       DMT45180
         SPACE 3                                                        DMT45190
CSETCOM  DS    0H                  *                                    DMT45200
         MVI   $COMCOM+1,OPEN      OPEN GATE                            DMT45210
         OI    BUFSYNSW,$COMBUSY   SHOW NO ACTIVITY                     DMT45220
         STM   R13,R15,CRETREGS    SAVE SOME REGISTERS                  DMT45230
         B     CREXIT              AND RETURN TO INTERRUPTED LOC        DMT45240
         SPACE 1                                                        DMT45250
$COMSUP  DS    0H                                                       DMT45260
         MVI   $COMCOM+1,CLOSE     CLOSE COMUTATOR ENTRY                DMT45270
         LM    R13,R15,CRETREGS    RESTORE                              DMT45280
         LA    R4,$COMCOM+4        -> exit addr to commutator     *XJE  DMT45290
         STCM  R4,7,$COMEXIT+1     Set it                         *XJE  DMT45300
**RELOC**MVC   $COMEXIT+1(3),=AL3($COMCOM+4) SET EXIT TO COMUTATOR      DMT45310
         NI    BUFSYNSW,255-$COMBUSY ALLOW COMMUNICATIONS INTERRUPTS    DMT45320
         BR    R15                 RE-ENTER COMSUP                      DMT45330
         EJECT                                                          DMT45340
         SPACE 3                                                        DMT45350
CNWRITE  DS    0H                                                       DMT45360
         LA    R15,BUFSTART        TO XMISSION POINT                    DMT45370
         ST    R15,CCWA            INTO CCW                             DMT45380
         MVI   CCWA,WRITE          RESET OP                             DMT45390
         ST    R15,CCWC            SET RETURN DATA ADDR                 DMT45400
         MVI   CCWC,READ           RESET OP                             DMT45410
         MVC   CCWA+6(2),BUFCOUNT  SET WRITE COUNT                      DMT45420
         MVI   CCWA+4,XCHN         SET PROPER CCW CHAINING              DMT45430
         ST    R13,CBUFFER         SAVE BUFFER ADDR                     DMT45440
         MVI   CCWB,WRITE          RESET OP FOR ENDING SEQ              DMT45450
         TM    BUFSTAT,BUFRESP     IS THIS JUST A RESPONSE              DMT45460
         BZ    CREWRITE            BR IF NO                             DMT45470
         MVI   CCWA+4,CC+SILI      SET COMMAND CHAINING                 DMT45480
         MVC   CCWA+6(3),=X'000203' SET COUNT AND 2ND CCW OP            DMT45490
         B     CWRTSIO             GO START WRITE                       DMT45500
         SPACE 1                                                        DMT45510
CREWRITE DS    0H                  ENTRY TO RETRY WRITE                 DMT45520
         MVC   CFCSOUT,$FCSOUT     SAVE LAST FCS SENT                   DMT45530
         MVC   BUFFCS,$FCSOUT      SET CURRENT FCS                      DMT45540
         MVC   BUFBCB(1),CSETBCB   SET BCB INTO BUFFER                  DMT45550
         MVC   COLDRCB(1),BUFDATA  SAVE RCB THAT IS SENT                DMT45560
         TM    BUFSTAT,BUFFAKE     IS THIS A DUMMY BUFFER               DMT45570
         BZ    CWRTSIO             BR IF NO                             DMT45580
         OI    BUFFCS,X'40'        YES...SET WAIT-A-BIT                 DMT45590
         MVC   CCWC+6(2),DUMCOUNT SET READ CNT FOR W/BIT       @VA07451 DMT45600
         SPACE 1                                                        DMT45610
CWRTSIO  DS    0H                  START THE WRITE                      DMT45620
         MVC   CBUFLAST(10),BUFSTART SAVE INCASE OF RESET               DMT45630
         NI    BUFSYNSW,255-CUWFAKE MAKE SURE DUMMY READ NOT ON         DMT45640
         BAL   R15,$SIO            ISSUE THE I/O                        DMT45650
         DC    AL4(CCWS-DMTXJEA)   Offset to CCW string           *XJE  DMT45660
         SPACE 3                                                        DMT45670
*                                                                       DMT45680
*              INTERRUPT EXIT ROUTINE                                   DMT45690
*                                                                       DMT45700
         SPACE 3                                                        DMT45710
CREXIT   DS    0H                                                       DMT45720
         LM    R13,R15,CREGS       RESTORE INTERRUPTED REGS             DMT45730
CEXIT    DS    0H                                                       DMT45740
         L     R4,$COMEXIT         GET RETURN POINT                     DMT45750
         BR    R4                  AND RETURN                           DMT45760
         EJECT                                                          DMT45770
*.                                                                      DMT45780
*                                                                       DMT45790
* ENTRY NAME -                                                          DMT45800
*                                                                       DMT45810
*        CERROR                                                         DMT45820
*                                                                       DMT45830
* FUNCTION -                                                            DMT45840
*                                                                       DMT45850
*        THIS ROUTINE IS RESPONSIBLE FOR ANALYZING ALL ERRORS ON        DMT45860
*        THE COMMUNICATIONS LINE.  THE APPROPRIATE CORRECTIVE           DMT45870
*        ACTIVE IS TAKEN DEPENDING ON THE TYPE OF ERROR.                DMT45880
*                                                                       DMT45890
* CALLS TO OTHER ROUTINES -                                             DMT45900
*                                                                       DMT45910
*        NONE                                                           DMT45920
*                                                                       DMT45930
* OPERATION -                                                           DMT45940
*                                                                       DMT45950
*        1. DETERMINE THE TYPE OF ERROR.                                DMT45960
*                                                                       DMT45970
*        2. TRY TO REWRITE THE LINE OR SEND A NEGATIVE                  DMT45980
*           RESPONSE.                                                   DMT45990
*                                                                       DMT46000
*        3. RECORD A LINE TRANSACTION, A LINE ERROR, OR                 DMT46010
*           TIMEOUT.                                                    DMT46020
*                                                                       DMT46030
*        4. WRITE AN ERROR MESSAGE.                                     DMT46040
*                                                                       DMT46050
* RESPONSES -                                                           DMT46060
*                                                                       DMT46070
*        NONE                                                           DMT46080
*                                                                       DMT46090
* ERROR MESSAGES -                                                      DMT46100
*                                                                       DMT46110
*        NONE                                                           DMT46120
*                                                                       DMT46130
*.                                                                      DMT46140
         SPACE 3                                                        DMT46150
CERROR   DS    0H                                                       DMT46160
         MVC   CCSW,ADACSW         PRESERVE CSW AROUND SENSE AND LOG    DMT46170
         TM    ADACSW+4,UC         TEST UNIT CHECK                      DMT46180
         BO    CUNITCHK            BR IF YES                            DMT46190
         TM    ADACSW+4,UE         TEST UNIT EXCEPTION                  DMT46200
         BO    CUNITEXC            BR IF YES                            DMT46210
         SPACE 1                                                        DMT46220
CBADERR  DS    0H                  ENTRY FOR UNUSUAL ERROR              DMT46230
         BAL   R14,TRERR           LOG THE ERROR                        DMT46240
         B     CHECKCCW            GO DETERMINE I/O TYPE                DMT46250
         EJECT                                                          DMT46260
CUNITCHK DS    0H                  ENTRY FOR UNIT CHECK                 DMT46270
         TM    ADASENSE,B'00000001' IS IT A TIMEOUT?                    DMT46280
         BO    CHECKTO             YES CONTINUE                         DMT46290
         BAL   R14,TRERR           RECORD THE ERROR                     DMT46300
         B     CHECKCCW            AND CONTINUE                         DMT46310
         SPACE 1                                                        DMT46320
CHECKTO  EQU   *                                                        DMT46330
         OI    BUFSTAT,BUFTONAK        T/O ON RD,SET FOR A NAK @VA08636 DMT46340
         BAL   R14,TRTIMOT         COUNT THE TIMEOUT                    DMT46350
         LH    R14,TOCNT      GET TIMEOUT COUNT                @VA05950 DMT46360
         LA    R14,1(R14)     UP BY ONE                        @VA05950 DMT46370
         STH   R14,TOCNT      SAVE FOR LATER                   @VA05950 DMT46380
         CH    R14,=H'17'     THRESHOLD REACHED (ABOUT 1 MIN)  @VA05950 DMT46390
         BNL   EOJ                                             @VA05950 DMT46400
         SPACE 1                                                        DMT46410
CHECKCCW EQU   *                                                        DMT46420
         LA    R14,CREWRITE        PREPARE TO REWRITE                   DMT46430
         ICM   R15,B'1111',CCSW    GET COMMAND ADDR AND CHECK FOR ZERO  DMT46440
         BCR   8,R14               BR IF YES TO TRY REWRITE             DMT46450
         TM    CCSW+5,CCC          TEST CHANNEL CONTROL CHECK           DMT46460
         BCR   1,R14               YES... GUESS AT REWRITE              DMT46470
         SH    R15,=H'8'           Otherwise back to failed CC HRC001DT DMT46480
         CLI   0(R15),WRITE        WAS IT A WRITE                       DMT46490
         BCR   8,R14               BR IF YES TO RETRY IT                DMT46500
         CLC   BUFDATA(1),COLDRCB  COMPARE AGAINST LAST RCB SENT        DMT46510
         BE    CSENDNAK                                        @VA05950 DMT46520
         NI    BUFSTAT,255-BUFTEXT OTHERWISE FORGET TEXT                DMT46530
         B     CSENDNAK                                        @VA05950 DMT46540
         SPACE 1                                                        DMT46550
         EJECT                                                          DMT46560
*                                                                       DMT46570
*              UNIT EXCEPTION SET                                       DMT46580
*                                                                       DMT46590
         SPACE 3                                                        DMT46600
CUNITEXC DS    0H                                                       DMT46610
         L     R15,ADACSW          GET CSW ADDR                         DMT46620
         SH    R15,=H'8'           Back up to cmd in error     HRC001DT DMT46630
         MVC   CUNITCMD(1),0(R15)  SAVE COMMAND CODE                    DMT46640
         SPACE 1                                                        DMT46650
         CLI   CUNITCMD,WRITE      WAS THIS A WRITE...                  DMT46660
         BNE   CSENDNAK            BR IF NO TO FORCE RESEND (EOT REC)   DMT46670
         SPACE 1                                                        DMT46680
CDMYREAD EQU   *                                                        DMT46690
         OI    BUFSYNSW,CUWFAKE    SET SWITCH TO IGNORE ERROR           DMT46700
         BAL   R15,$SIO            ISSUE THE I/O                        DMT46710
         DC    AL4(CCWD-DMTXJEA)   Offset to CCW string           *XJE  DMT46720
         B     CREXIT              AND EXIT TO AWAIT INT                DMT46730
         EJECT                                                          DMT46740
*---------------------------------------------------------------------* DMT46750
*                                                                     * DMT46760
*           IOERROR MESSAGE PRINT ROUTINE                             * DMT46770
*                                                                     * DMT46780
*               AT ENTRY: R1 --> TO FAILING CCW                       * DMT46790
*                                                                     * DMT46800
*                                                                     * DMT46810
*---------------------------------------------------------------------* DMT46820
         SPACE                                                          DMT46830
         DS    0H                                                       DMT46840
IOERRPRT EQU   *                                                        DMT46850
         STM   R14,R1,IOERRSV      STORE REGS IN SAVE AREA              DMT46860
         MVC   IOERRLNE(8),XJELINE Store line address in msg   HRC000DT DMT46870
         UNPK  IERRCSW1(9),ADACSW(5) SPREAD THE CSW                     DMT46880
         UNPK  IERRCSW2(9),ADACSW+4(5) SPREAD THE CSW                   DMT46890
         TR    IERRCSW1(16),AXSTRTAB-240 AND TRANSLATE TO HEX           DMT46900
         MVC   IERRSIO(1),ADASIOCC MOVE IN STARTIO CONDITION CODE       DMT46910
         OI    IERRSIO,X'F0'       AND MAKE PRINTABLE                   DMT46920
         UNPK  IERRSENS(3),ADASENSE(2) SPREAD THE DIGITS                DMT46930
         MVI   IERRSENS+2,C' '     RESTORE THE CLOBBERED BLANK          DMT46940
         TR    IERRSENS(2),AXSTRTAB-240 AND TRANSLATE TO HEX            DMT46950
         TM    ADASIOCC,X'02'      BAD CONDITION?                       DMT46960
         BO    IOERRPR1            YES SKIP CCW                         DMT46970
         UNPK  IERRCCW1(9),0(5,R1) UNPACK THE CCW INTO MSG              DMT46980
         UNPK  IERRCCW2(9),4(5,R1) UNPACK THE CCW INTO MSG              DMT46990
         TR    IERRCCW1(16),AXSTRTAB-240 AND TRANSLATE TO HEX           DMT47000
IOERRPR1 EQU   *                                                        DMT47010
         LA    R0,IOERMSGL         GET THE MSG LENGTH                   DMT47020
         LA    R1,IOERRMSG         GET THE MSG ADDR                     DMT47030
         BAL   R14,MSG             AND WRITE IT                         DMT47040
         MVI   IERRCCW1,C'0'       CLEAR FIRST BYTE                     DMT47050
         MVC   IERRCCW1+1(15),IERRCCW1 AND THE REST                     DMT47060
         LM    R14,R1,IOERRSV      RESTORE REGISTERS                    DMT47070
         BR    R14                 AND RETURN                           DMT47080
         EJECT                                                          DMT47090
*---------------------------------------------------------------------* DMT47100
*                                                                     * DMT47110
*                                                                     * DMT47120
*        EVENT TRACING ROUTINE                                        * DMT47130
*                                                                     * DMT47140
*              ENTRY:                                                 * DMT47150
*                                                                     * DMT47160
*                  TRTRAN -- TO RECORD A LINE TRANSACTION             * DMT47170
*                  TRERR -- TO RECORD A LINE ERROR                    * DMT47180
*                  TRTIMOT -- TO RECORD A TIMEOUT                     * DMT47190
*                                                                     * DMT47200
*                                                                     * DMT47210
*---------------------------------------------------------------------* DMT47220
         SPACE 1                                                        DMT47230
         USING LINKTABL,R1         GET LINK TABLE ADDRESSABILITY        DMT47240
         SPACE 1                                                        DMT47250
         DS    0H                                                       DMT47260
TRTRAN   EQU   *                                                        DMT47270
         STM   R14,R1,TRSAVE       SAVE REGISTERS                       DMT47280
         L     R1,XJELINK          Get link table address      HRC000DT DMT47290
         TM    LFLAG,LTRALL        SHOULD WE BE DOING THIS?             DMT47300
         BNO   TREXIT              NO -- TIME TO EXIT                   DMT47310
         LH    R15,LTRNSCNT        GET THE CURRENT COUNT                DMT47320
         LA    R15,1(,R15)         UP BY ONE                            DMT47330
         STH   R15,LTRNSCNT        AND REPLACE IN COUNT FIELD           DMT47340
         CL    R15,TRASHLD         IS IT TIME TO PRINT?                 DMT47350
         BL    TREXIT              NO RETURN                            DMT47360
         B     TRPRT               GO PRINT THE MSG                     DMT47370
         SPACE                                                          DMT47380
TRERR    EQU   *                                                        DMT47390
         STM   R14,R1,TRSAVE       SAVE REGISTERS                       DMT47400
         L     R1,XJELINK          Get link table address      HRC000DT DMT47410
         TM    LFLAG,LTRALL+LTRERR SHOULD WE BE DOING THIS?             DMT47420
         BZ    TREXIT              NO -- TIME TO EXIT                   DMT47430
         LH    R15,LERRCNT         GET THE CURRENT COUNT                DMT47440
         LA    R15,1(,R15)         UP BY ONE                            DMT47450
         STH   R15,LERRCNT         AND REPLACE IN COUNT FIELD           DMT47460
         CL    R15,ERRSHLD         IS IT TIME TO PRINT?                 DMT47470
         BL    TREXIT              NO RETURN                            DMT47480
         B     TRPRT               GO PRINT THE MSG                     DMT47490
         SPACE                                                          DMT47500
TRTIMOT  EQU   *                                                        DMT47510
         STM   R14,R1,TRSAVE       SAVE REGISTERS                       DMT47520
         L     R1,XJELINK          Get link table address      HRC000DT DMT47530
         TM    LFLAG,LTRALL+LTRERR SHOULD WE BE DOING THIS?             DMT47540
         BZ    TREXIT              NO -- TIME TO EXIT                   DMT47550
         LH    R15,LTOCNT          GET THE CURRENT COUNT                DMT47560
         LA    R15,1(,R15)         UP BY ONE                            DMT47570
         STH   R15,LTOCNT          AND REPLACE IN COUNT FIELD           DMT47580
         CL    R15,ERRSHLD         IS IT TIME TO PRINT?                 DMT47590
         BL    TREXIT              NO RETURN                            DMT47600
         EJECT                                                          DMT47610
TRPRT    EQU   *                                                        DMT47620
         MVC   TRLINK(8),AXSLINK   MOVE LINKID INTO MSG                 DMT47630
         LH    R15,LTRNSCNT        GET THE CURRENT COUNT                DMT47640
         CVD   R15,TRCVD           CONVERT TO DECIMAL                   DMT47650
         UNPK  TRMTRN,TRCVD        SPREAD THE DIGITS                    DMT47660
         OI    TRMTRN+7,X'F0'      MAKE THE LAST ONE PRINTABLE          DMT47670
         LH    R15,LERRCNT         GET THE CURRENT COUNT                DMT47680
         CVD   R15,TRCVD           CONVERT TO DECIMAL                   DMT47690
         UNPK  TRMERR,TRCVD        SPREAD THE DIGITS                    DMT47700
         OI    TRMERR+7,X'F0'      MAKE THE LAST ONE PRINTABLE          DMT47710
         LH    R15,LTOCNT          GET THE CURRENT COUNT                DMT47720
         CVD   R15,TRCVD           CONVERT TO DECIMAL                   DMT47730
         UNPK  TRMTO,TRCVD         SPREAD THE DIGITS                    DMT47740
         OI    TRMTO+7,X'F0'       MAKE THE LAST ONE PRINTABLE          DMT47750
         SR    R15,R15             CLEAR OUT R15                        DMT47760
         STH   R15,LTRNSCNT        CLEAR THE COUNTER                    DMT47770
         STH   R15,LERRCNT         CLEAR THE COUNTER                    DMT47780
         STH   R15,LTOCNT          CLEAR THE COUNTER                    DMT47790
         LA    R0,TRMSGL           GET THE MSG LENGTH                   DMT47800
         LA    R1,TRMSG            GET THE MSG ADDR                     DMT47810
         BAL   R14,MSG             AND WRITE OUT THE MSG                DMT47820
         SPACE                                                          DMT47830
TREXIT   EQU   *                                                        DMT47840
         LM    R14,R1,TRSAVE       RESTORE THE REGS                     DMT47850
         BR    R14                 AND RETURN                           DMT47860
         EJECT                                                          DMT47870
*---------------------------------------------------------------------* DMT47880
*                                                                     * DMT47890
*                       ADAPTER SIO ROUTINE                           * DMT47900
*                                                                     * DMT47910
*---------------------------------------------------------------------* DMT47920
         SPACE 1                                                        DMT47930
$SIO     DS    0H                                                       DMT47940
         STM   R11,R2,ADSAV        SAVE REGS                            DMT47950
         ICM   R14,15,0(R15)       Get offset to CCW string       *XJE  DMT47960
         AR    R14,R9              Compute actual addr            *XJE  DMT47970
         STCM  R14,7,ADCCWA+1      Put CCW ADDRESS TO IOB         *XJE  DMT47980
         ST    R14,CLASTCAW        SAVE                           *XJE  DMT47990
         MVI   ADASENSE,X'00'      CLEAR SENSE BYTE                     DMT48000
         CLI   0(R14),DISABLE IS IT A DISABLE?                 @VA04353 DMT48010
         BE    RSIO           YES...DON'T LOG IT               @VA04353 DMT48020
         CLI   0(R14),READ    IS IT A READ?                    @VA04353 DMT48030
         BE    NOTWRITE       YES...DON'T BUMP POINTER         @VA04353 DMT48040
         LA    R14,8(R14)     POINT TO WRITE DATA CCW          @VA04353 DMT48050
NOTWRITE MVC   KCCW,0(R14)    SAVE CCW                         @VA04353 DMT48060
         L     R14,0(R14)          GET CCW ADDR                         DMT48070
         LA    R1,W                INDICATE WRITE TO LOG                DMT48080
         BAL   R15,KLOGIT          GO LOG THE WRITE                     DMT48090
RSIO     EQU   *                                                        DMT48100
         XC    ADAECB(4),ADAECB    CLEAR OUT ADAPTER SYNCH LOCK         DMT48110
         LA    R1,ADAECB           GET ADAPTER IO BLOCK ADDR            DMT48120
         L     R15,IOREQ           SYSTEM I/O REQUEST PROCESSOR         DMT48130
         BALR  R14,R15             GO EXECUTE THE I/O                   DMT48140
         CLI   ADASIOCC,X'00'      DID IT START OKAY                    DMT48150
         BE    RSIO1               OKAY CONTINUE                        DMT48160
         L     R1,CLASTCAW         GET LAST CCW ADDR                    DMT48170
         BAL   R14,IOERRPRT        WRITE THE ERROR MSG                  DMT48180
         CLI   ADASIOCC,NOP            LINE NOT THERE?         @VA08191 DMT48190
         BE    XJECRASH                Yes, exit W/O disable   HRC000DT DMT48200
         B     RSIO                AND RETRY                            DMT48210
         SPACE 1                                                        DMT48220
RSIO1    EQU   *                                                        DMT48230
         LM    R11,R2,ADSAV        RESTORE REGS                         DMT48240
         B     4(R15)              BACK TO USER                         DMT48250
         EJECT                                                          DMT48260
*---------------------------------------------------------------------* DMT48270
*                                                                     * DMT48280
*              HERE IF ERRORS OCCURED DURING INITIALIZATION       *XJE* DMT48290
*                                                                     * DMT48300
*---------------------------------------------------------------------* DMT48310
         SPACE 1                                                        DMT48320
         DS    0H                                                       DMT48330
XJELERR1 EQU   *                                                  *XJE  DMT48340
         MSGX  901,AXSLINK         WRITE THE MESSAGE                    DMT48350
         B     EOJ                 AND EXIT                             DMT48360
         SPACE 2                                                        DMT48370
XJELERR2 EQU   *                                                  *XJE  DMT48380
         MSGX  906,AXSLINK         WRITE THE MSG                        DMT48390
         B     EOJ                 AND EXIT                             DMT48400
*                                                                       DMT48410
*---------------------------------------------------------------------* DMT48420
*                                                                     * DMT48430
*                     LOG ROUTINE                                     * DMT48440
*                                                                     * DMT48450
*---------------------------------------------------------------------* DMT48460
         SPACE 3                                                        DMT48470
         USING IOTABLE,R1          GET IOTABLE ADDRSSABILITY            DMT48480
KTAB     DC    C'0123456789ABCDEF' TRANSLATE TAB                        DMT48490
KLOGIT   STM   R13,R2,KSAV         SAVE REGISTERS                       DMT48500
         TM    $LOGSW,LOGON        IS LOGING SET ON?                    DMT48510
         BNOR  R15            (BN0  RSIO) NO...RETURN          @VA04353 DMT48520
         TM    $LOGSW,LOGOPEN      IS THE LOG DEVICE OPEN?              DMT48530
         BO    LOGCONT             YES CONTINUE                         DMT48540
         LA    R1,LOGBLK           GET LOG REQUEST BLOCK                DMT48550
         LA    R0,X'11'            INDICATE OPEN                        DMT48560
         BAL   R14,AXS             GO GET A DEVICE                      DMT48570
         MVC   LOGLINK(8),AXSLINK  SET LINKID IN MSG                    DMT48580
         LA    R1,LOGTIME          GET BUFFER FOR DIAG                  DMT48590
*********DIAG  R1,R2,X'0C'         GET TIME AND DATA FROM VM            DMT48600
         MVC   LOGDTIME(8),LOGTIME MOVE TO MSG                          DMT48610
         MVC   LOGDTIME+9(8),LOGTIME+8 MOVE TO MSG                      DMT48620
         L     R1,LOGFIOA          GET FIOA ADDR                        DMT48630
         LA    R15,LOGHDCCW        Move CCW addr to CAW           *XJE  DMT48640
         ST    R15,PROGADDR        Set it                         *XJE  DMT48650
         B     WRLOG1              AND CONTINUE                         DMT48660
         SPACE 1                                                        DMT48670
LOGCONT  EQU   *                                                        DMT48680
         UNPK  IOLINE(15),0(8,R14) CONVERT THE FIRST PART OF BUFFER     DMT48690
         TR    IOLINE(14),KTAB-240 TO EBCDIC                            DMT48700
         UNPK  IOLINE+14(15),7(8,R14) CONVERT THE SECOND PART OF BUFFER DMT48710
         TR    IOLINE+14(14),KTAB-240 TO EBCDIC                         DMT48720
         UNPK  IOLINE+28(15),14(8,R14) AND THE LAST PART                DMT48730
         TR    IOLINE+28(14),KTAB-240 TO EBCDIC                         DMT48740
         MVI   IOLINE+42,C' '      RESTORE CLOBBERED BLANK              DMT48750
         UNPK  IOLINE+43(15),ADACSW+1(8) CONVERT THE CSW                DMT48760
         TR    IOLINE+43(14),KTAB-240 TO EBCDIC                         DMT48770
         MVI   IOLINE+57,C' '      RESTORE CLOBBERED BLANK              DMT48780
         UNPK  IOLINE+58(7),ADAECB(4) CONVERT THE SYNCH LOCK            DMT48790
         TR    IOLINE+58(6),KTAB-240 TO EBCDIC                          DMT48800
         MVI   IOLINE+64,C' '      RESTORE CLOBBERED BLANK              DMT48810
         UNPK  IOLINE+66(3),ADASENSE(2) CONVERT THE SENSE INFO @VA04353 DMT48820
         TR    IOLINE+66(2),KTAB-240 ...TO EBCDIC              @VA04353 DMT48830
         MVI   IOLINE+68,C' ' RESTORE CLOBBERED BLANK          @VA04353 DMT48840
         CLI   0(R1),C'W'          CHECK FOR WRITE                      DMT48850
         BE    WRLOG2         CSW NOT USEFUL                   @VA04353 DMT48860
         ICM   R1,B'0111',ADACSW+1 LAST CCW ADDRESS            @VA04353 DMT48870
         BZ    KFULL          INVALID ADDRESS                  @VA04353 DMT48880
         SH    R1,=H'8'       Back up to last CCW              HRC001DT DMT48890
         MVC   KCCW,0(R1)     SAVE CCW                         @VA04353 DMT48900
WRLOG2   UNPK  IOLINE+70(9),KCCW(5) CCW1                       @VA04353 DMT48910
         TR    IOLINE+70(8),KTAB-240 TRANSLATE                 @VA04353 DMT48920
         UNPK  IOLINE+78(9),KCCW+4(5) CCW2                     @VA04353 DMT48930
         TR    IOLINE+78(8),KTAB-240 MAKE IT EBCDIC            @VA04353 DMT48940
         MVI   IOLINE+86,C' ' RESTORE CLOBBERED BLANK          @VA04353 DMT48950
         CLI   IOLINE+70,WRITE IS IT A WRITE?                  @VA04353 DMT48960
         BNE   WRLOG               NO..MUST BE READ                     DMT48970
         L     R13,KSAV            RESTORE R13                          DMT48980
         UNPK  IOLINE+43(15),0(8,R13) LETS SEE THE FIRST PART OF THE BU DMT48990
         TR    IOLINE+43(14),KTAB-240 TO EBCDIC                         DMT49000
         MVI   IOLINE+57,C' '      RESTORE CLOBBERED BLANK              DMT49010
         EJECT                                                          DMT49020
WRLOG    EQU   *                                                        DMT49030
         TM    KCCW+4,SKIP    TRANSFER SUPPRESSED?             @VA04353 DMT49040
         BO    KWRITE         NO BUFFER TO DISPLAY             @VA04353 DMT49050
         LH    R14,KCCW+6     LOAD CCW BYTE COUNT              @VA04353 DMT49060
         CLI   KCCW,WRITE     IS IT A WRITE?                   @VA04353 DMT49070
         BE    KWRITE         NOT LAST CCW                     @VA04353 DMT49080
         SH    R14,ADACSW+6   RESIDUAL BYTE COUNT              @VA04353 DMT49090
KWRITE   SLA   R14,1          *2 FOR UNPACK                    @VA04353 DMT49100
         CL    R14,=F'40'     MORE THAN 40 BYTES?              @VA04353 DMT49110
         BH    KFULL          YES...IOLINE IS FULL             @VA04353 DMT49120
         LA    R1,IOLINE(R14) ADDRESS OF BLANKING AREA         @VA04353 DMT49130
         LA    R14,IOLINE+41  END OF BLANKING AREA-1           @VA04353 DMT49140
         SR    R14,R1         SIZE OF BLANKING AREA-1          @VA04353 DMT49150
         MVI   0(R1),C' '     BLANK OUT THE AREA               @VA04353 DMT49160
         EX    R14,MVCBLANK                                    @VA04353 DMT49170
KFULL    EQU   *                                               @VA04353 DMT49180
         L     R1,LOGFIOA          GET LOG DEVICE BLOCK ADDR            DMT49190
         LA    R15,LOGCCW          Move CCW addr to CAW           *XJE  DMT49200
         ST    R15,PROGADDR        Set it                         *XJE  DMT49210
WRLOG1   EQU   *                                                        DMT49220
         XC    IOSYNCH(4),IOSYNCH  CLEAR SYNCH LOCK                     DMT49230
         L     R15,IOREQ           SYSTEM IO ROUTINE ADDR               DMT49240
         BALR  R14,R15             EXECUTE THE IO                       DMT49250
         L     R15,WAITREQ         PREPARE FOR WAIT                     DMT49260
         BALR  R14,R15             AND WAIT FOR COMPLETION              DMT49270
         MVI   IOLINE,C' '    MAKE THE....                     @VA04353 DMT49280
         MVC   IOLINE+1(119),IOLINE ....IOLINE BLANK           @VA04353 DMT49290
LOGRET   EQU   *                                                        DMT49300
         LM    R13,R2,KSAV         RESTORE REGISTERS                    DMT49310
         TM    $LOGSW,LOGOPEN IS THE LOG OPEN?                 @VA04353 DMT49320
         BOR   R15            YES...ALL DONE,RETURN.           @VA04353 DMT49330
         OI    $LOGSW,LOGOPEN SET LOG OPEN                     @VA04353 DMT49340
         B     LOGCONT        MAKE THE FIRST ENTRY             @VA04353 DMT49350
         DROP  R1                                              @VA04353 DMT49360
         EJECT                                                          DMT49370
*---------------------------------------------------------------------* DMT49380
*                                                                     * DMT49390
*                      CLOSE LOG ROUTINE                              * DMT49400
*                                                                     * DMT49410
*---------------------------------------------------------------------* DMT49420
         SPACE 1                                                        DMT49430
         DC    0H'0'                                                    DMT49440
LOGCLOSE EQU   *                                                        DMT49450
         TM    $LOGSW,LOGOPEN          IS LOG RUNNING          @VA08193 DMT49460
         BZR   R14                     QUICK RETURN IF NO      @VA08193 DMT49470
         STM   R14,R1,LOGCLSAV     SAVE REGISTERS                       DMT49480
         NI    $LOGSW,255-LOGON-LOGOPEN RESET FLAGS                     DMT49490
         LA    R1,LOGBLK           GET LOG REQUEST BLOCK                DMT49500
         LA    R0,X'12'            INDICATE CLOSE                       DMT49510
         BAL   R14,AXS             GET RID OF LOG DEVICE                DMT49520
         LM    R14,R1,LOGCLSAV     RESTORE REGISTERS                    DMT49530
         BR    R14                     AND RETURN              @VA08193 DMT49540
         SPACE 1                                                        DMT49550
LOGCLSAV DS    4F                  SAVE AREA                            DMT49560
         EJECT                                                          DMT49570
         SPACE 7                                                        DMT49580
         DS    0H                                                       DMT49590
SIGNOFF  EQU   *                                                        DMT49600
         BAL   R15,$SIO            Send signoff record on line SML2NJE4 DMT49610
         DC    AL4(SGNOFCCW-DMTXJEA)  Offset to CCW string        *XJE  DMT49620
         LA    R1,ADAECB           BSC adapter synch lock      SML2NJE4 DMT49630
         L     R15,WAITREQ         Address of system wait rtn  SML2NJE4 DMT49640
         BALR  R14,R15             Wait for record to be sent  SML2NJE4 DMT49650
EOJ      EQU   *                                               @VA05662 DMT49660
         BAL   R15,$SIO                DISABLE LINE            @VA08191 DMT49670
         DC    AL4(CCWOFF-DMTXJEA)     Offset to CCW string       *XJE  DMT49680
         LA    R1,ADAECB               BSC ADAPTER SYNC LOCK   @VA08191 DMT49690
         L     R15,WAITREQ             GO TO WAIT              @VA08191 DMT49700
         BALR  R14,R15                 FOR DISABLE COMPLETE    @VA08191 DMT49710
XJECRASH EQU   *                       No disable issued here  HRC000DT DMT49720
         BAL   R14,CLOSEURS        Close unit record devices   SML2NJE4 DMT49730
         MSGX  143,(AXSLINK,XJELINE) Write the message         HRC000DT DMT49740
*********LA    R1,TERMBLK          GET TERMINATE GIVE BUFFER            DMT49750
*********L     R15,GIVEREQ         GET GIVE PROCESSOR ADDRESS           DMT49760
*********BALR  R14,R15             GO EXECUTE THE REQUEST               DMT49770
*--Termination: return back to NJEINIT                            *XJE
*********L     R15,WAITREQ         GET SYSTEM WAIT ROUTINE              DMT49780
*********LA    R1,LONGWAIT         A VERY LONG WAIT                     DMT49790
*********BALR  R14,R15             WAIT A LONG TIME                     DMT49800
         L     R13,XJESAVE+4       -> caller's save area          *XJE
         LM    R14,R12,12(R13)     Restore caller's regs (NJEINIT)*XJE
         BR    R14                 Return to NJEINIT              *XJE
*
*
CLOSEURS EQU   *                                               SML2NJE4 DMT49810
         ST    R14,CLOSESAV        Save return address         SML2NJE4 DMT49820
         TM    MASTERSW,SYSOUT     SYSOUT output device open?  SML2NJE4 DMT49830
         BZ    NOSYSOUT            No PRT/PUN device to close  SML2NJE4 DMT49840
         LA    R1,PDEVSYNC         Get SYSOUT device block     SML2NJE4 DMT49850
         LA    R0,X'12'            Close output function code  SML2NJE4 DMT49860
         MVI   19(R1),X'20'        Close purge option          SML2NJE4 DMT49870
         BAL   R14,AXS             Call DMTAXS to close        SML2NJE4 DMT49880
         MVI   19(R1),X'00'        Restore default close opts  SML2NJE4 DMT49890
         NI    MASTERSW,255-SYSOUT Mark SYSOUT device closed   SML2NJE4 DMT49900
NOSYSOUT EQU   *                                               SML2NJE4 DMT49910
         TM    MASTERSW,JOB        SYSIN output device open?   SML2NJE4 DMT49920
         BZ    NOSYSIN             No PUN device to close      SML2NJE4 DMT49930
         LA    R1,JDEVSYNC         Get SYSIN device block      SML2NJE4 DMT49940
         LA    R0,X'12'            Close output function code  SML2NJE4 DMT49950
         MVI   19(R1),X'20'        Close purge option          SML2NJE4 DMT49960
         BAL   R14,AXS             Call DMTAXS to close        SML2NJE4 DMT49970
         MVI   19(R1),X'00'        Restore default close opts  SML2NJE4 DMT49980
         NI    MASTERSW,255-JOB    Mark SYSIN device closed    SML2NJE4 DMT49990
NOSYSIN  EQU   *                                               SML2NJE4 DMT50000
         TM    MASTERSW,READER     RDR input device open?      SML2NJE4 DMT50010
         BZ    NOREADER            Reader not currently open   SML2NJE4 DMT50020
         LA    R1,RDEVSYNC         Get input RDR device block  SML2NJE4 DMT50030
         LA    R0,X'02'            Close input function code   SML2NJE4 DMT50040
         MVI   19(R1),X'81'        Close hold and keep options SML2NJE4 DMT50050
         BAL   R14,AXS             Call DMTAXS to close RDR    SML2NJE4 DMT50060
         MVI   19(R1),X'00'        Restore default close opts  SML2NJE4 DMT50070
         NI    MASTERSW,255-READER Mark RDR device closed      SML2NJE4 DMT50080
NOREADER EQU   *                                               SML2NJE4 DMT50090
         BAL   R14,LOGCLOSE        Ensure logging PRT closed   SML2NJE4 DMT50100
         L     R14,CLOSESAV        Restore return address      SML2NJE4 DMT50110
         BR    R14                 Return to caller            SML2NJE4 DMT50120
*                                                              SML2NJE4 DMT50130
         DROP  R11,R10                                            *XJE  DMT50140
         LTORG                                                          DMT50150
         EJECT                                                          DMT50160
*                                                                       DMT50170
********************                                                    DMT50180
*                  *   Selected functions externalized from             DMT50190
* CSECT DMTXJE2    *   DMTXJE1 in order to provide base register        DMT50200
*                  *   relief.  Handles reading and purging             DMT50210
********************   spool files, in part.                            DMT50220
*                                                                       DMT50230
DMTXJE2  CSECT                                                    *XJE  DMT50240
         STM   R0,R15,XJE2SAVE     Save callers regs              *XJE  DMT50250
         LR    R12,R15                                            *XJE  DMT50260
         USING DMTXJE2,R12                                        *XJE  DMT50270
*                                                                 *XJE  DMT50280
         LR    R14,R0              Copy entry code                *XJE  DMT50290
         B     XJE2FUNC(R14)       Branch into branch table       *XJE  DMT50300
*                                                                 *XJE  DMT50310
XJE2FUNC B     AXSGET           00 Open reader file               *XJE  DMT50320
         B     AXSPURGE         04 Purge spool file               *XJE  DMT50330
         B     VMDEBLOK         08 Deblock VM spool records       *XJE  DMT50340
         B     TODEBCDX         0C Convert the time               *XJE  DMT50350
*.                                                                      DMT50360
*                                                                       DMT50370
* ENTRY NAME -                                                          DMT50380
*                                                                       DMT50390
*        AXSGET                                                         DMT50400
*                                                                       DMT50410
* FUNCTION -                                                            DMT50420
*                                                                       DMT50430
*        THIS ROUTINE FUNCTIONS AS THE INTERFACE TO DMTAXS, FOR         DMT50440
*        GETTING FILES TO TRANSMIT, AND PURGE THOSE FILES WHEN          DMT50450
*        TRANSMISSION IS COMPLETE.                                      DMT50460
*                                                                       DMT50470
* CALLS TO OTHER ROUTINES -                                             DMT50480
*                                                                       DMT50490
*        DMTWAT - TO WAIT FOR AN EVENT COMPLETION                       DMT50500
*        DMTGIV - TO INITIATE A GIVE REQUEST                            DMT50510
*                                                                       DMT50520
* OPERATION -                                                           DMT50530
*                                                                       DMT50540
*        1. INITIATE AND WAIT FOR COMPLETION A CALL TO DMTAXS           DMT50550
*           FOR AN INPUT SPOOL FILE TO TRANSMIT.                        DMT50560
*                                                                       DMT50570
*        2. IF FILE OPENED CONSTRUCT HEADER LINE AND SETUP INITIAL      DMT50580
*           PARAMETERS FOR VMDEBLOK                                     DMT50590
*                                                                       DMT50600
*        3. IF FILE NOT OPENED RETURN TO CALLER WITH CONDITION CODE SET DMT50610
*                                                                       DMT50620
*        FOR AN INPUT FILE PURGE:                                       DMT50630
*                                                                       DMT50640
*        1. SETUP UP A CALL TO DMTAXS TO CLOSE INPUT FILE.              DMT50650
*                                                                       DMT50660
*        2. WAIT FOR COMPLETION AND RETURN TO CALLER.                   DMT50670
*                                                                       DMT50680
* RESPONSES -                                                           DMT50690
*                                                                       DMT50700
*        NONE                                                           DMT50710
*                                                                       DMT50720
* ERROR MESSAGES -                                                      DMT50730
*                                                                       DMT50740
*        NONE                                                           DMT50750
*                                                                       DMT50760
*.                                                                      DMT50770
         EJECT                                                          DMT50780
         USING TAG,R8                                                   DMT50790
AXSGET   DC    0H'0'                                                    DMT50800
*                                                                       DMT50810
         MVI   RDEVRLEN,X'13'      SET REQUEST LENGTH                   DMT50820
         MVI   RDEVFUN,X'01'       SET FUNCTION FOR INPUT OPEN          DMT50830
         MVC   RDEVLINK(8),AXSLINK SET LINK ID IN REQUEST               DMT50840
         SR    R0,R0               CLEAR R0 TO SIGNAL GIVE INIT REQ     DMT50850
         ST    R0,RDEVSYNC         CLEAR THE AXS REQUEST SYNCH LOCK TOO DMT50860
         LA    R1,RDEVSYNC         R1=ADDR OF THE REQ ELEMENT FOR AXS   DMT50870
         L     R15,GIVEREQ         R15=ENTRY ADDR FOR SUP GIVE ROUTINE  DMT50880
         BALR  R14,R15             MAKE THE REQUEST AVAILABLE TO AXS0   DMT50890
         L     R15,WAITREQ         R1= ADDR OF ENTRY TO WAIT ROUTINE    DMT50900
         BALR  R14,R15             WAIT FOR AXS0 TO PROCESS THE REQUEST DMT50910
         CLI   RDEVSYNC,X'40'      WAS THE REQUEST SUCCESSFUL?    *XJE  DMT50920
         BE    AXSGOPEN            YEP - GO TRY TO OPEN THE FILE        DMT50930
         TM    RDEVSYNC,X'41'      FILE ALREADY THERE             *XJE  DMT50940
         BO    AXSGOPEN            THATS OKAY TOO                       DMT50950
         XC    RDEVSYNC(4),RDEVSYNC CLEAR OUT SYNC LOCK                 DMT50960
         LA    R15,4               SET NON ZERO RETURN CODE             DMT50970
         B     XJE2XIT             RETURN WITH NO BLOCK INDICATION*XJE  DMT50980
         SPACE 1                                                        DMT50990
AXSGOPEN EQU   *                                                        DMT51000
         USING SPLINK,R1           GET SPLINK ADDRESSABILITY            DMT51010
         OI    RSW1,RACTIV         INDICATE FILE OPENED                 DMT51020
         L     R1,RDEVFIOA         GET FILE I/O AREA ADDRESS            DMT51030
         L     R8,SPRECNUM         PICKUP SPRECNUM FROM NEW BLOCK       DMT51040
         ST    R8,VMSPNUM          PICKUP COUNT OF REMAINING CCWS       DMT51050
         LA    R8,SPRECNUM+4       SETP OVER POINTERS IN SPOOL BLOCK    DMT51060
         ST    R8,VMSPANCH         TO PICKUP CURRENT CCW ANCHOR         DMT51070
         ST    R8,VMSPNEXT         CCW POINTER AND NEXT                 DMT51080
         OI    RSW1,CLINE          TO INDICATE BLOCK PRESENT            DMT51090
         OI    RSW1,HEADFLAG       INDICATE TIME TO PRT HEADER          DMT51100
         L     R8,RDEVTAG          GET TAG ADDR                         DMT51110
         CLI   TAGINDEV,TYP3210    IS IT SPOOLED CONSOLE OUTPUT?        DMT51120
         BE    AXSGLINE            YES..TREAT LIKE PRINT                DMT51130
         TM    TAGINDEV,TYPPRT     IS IT A PRINT FILE?                  DMT51140
         BO    AXSGLINE            YEP - GO GIN UP A REM HEAD LINE      DMT51150
         MVI   HDRCHAR,X'5C'       INSERT *                             DMT51160
         MVC   HDRCHAR+1(80-HDRSGLEN-1),HDRCHAR AND PROPAGATE           DMT51170
         B     AXSGCOMM            AND ENTER COMMON HEAD CODE           DMT51180
         EJECT                                                          DMT51190
AXSGLINE EQU   *                                                        DMT51200
         MVI   HDRCHAR,C' '        INSERT BLANK                         DMT51210
         MVC   HDRCHAR+1(80-HDRSGLEN-1),HDRCHAR AND PROPAGATE           DMT51220
AXSGCOMM EQU   *                                                        DMT51230
         MVC   HDRORGID(8),TAGINLOC MOVE IN THE ORIGIN LOCATION         DMT51240
         MVC   HDRVMID(8),TAGINVM  AND THE ORIGIN VIRTUAL MACHINE       DMT51250
         MVC   HDRTOD(MASKLEN),TODMASK MOVE IN THE EDITING MASK         DMT51260
         LA    R2,HDRTOD           R2 CONTAINS THE EBCDIC TOD ADDR      DMT51280
         LA    R1,TAGINTOD         -> TOD clock data              *XJE
         BAL   R14,TODEBCD         AND CONVERT                          DMT51290
         DROP  R1                                                       DMT51300
         SPACE 1                                                        DMT51310
AXSGEXIT EQU   *                                                        DMT51320
         XC    RDEVSYNC(4),RDEVSYNC CLEAR OUT SYNC LOCK                 DMT51330
         SR    R15,R15             SET ZERO RETURN CODE                 DMT51340
         B     XJE2XIT             AND RETURN TO THE MAIN ROUTINE *XJE  DMT51350
         EJECT                                                          DMT51360
AXSPURGE EQU   *                                                        DMT51370
         MVI   RDEVFUN,X'02'       SET PURGE REQUEST CODE FOR AXS1      DMT51380
         SR    R0,R0               CLEAR R0 TO SIG GIVE INIT REQ        DMT51390
         ST    R0,RDEVSYNC         CLEAR THE REQUEST SYNCH LOCK TOO     DMT51400
         LA    R1,RDEVSYNC         R1=ADDR OF PURGE REQ FOR AXS         DMT51410
         L     R15,GIVEREQ         R15=ADDR OF ENTRY TO SUP GIVE ROUT   DMT51420
         BALR  R14,R15             INITIATE THE REQUEST                 DMT51430
         L     R15,WAITREQ         R15=ADDR OF ENTRY TO SUP WAIT ROUT   DMT51440
         BALR  R14,R15             WAIT FOR THE REQUEST TO BE COMPLETED DMT51450
         XC    RDEVSYNC(4),RDEVSYNC CLEAR OUT SYNC LOCK                 DMT51460
         XC    RDEVSOPT(1),RDEVSOPT CLEAR OUT SUBOPTION FIELD           DMT51470
         L     R15,XJE2SAVE+15*4   RESTORE Original R15           *XJE  DMT51480
         B     XJE2XIT             AND RETURN TO THE CALLER       *XJE  DMT51490
*                                                                       DMT51500
         DROP  R8                                                       DMT51510
*                                                                       DMT51520
         EJECT                                                          DMT51530
*.                                                                      DMT51540
*                                                                       DMT51550
* ENTRY NAME -                                                          DMT51560
*                                                                       DMT51570
*        VMDEBLOK                                                       DMT51580
*                                                                       DMT51590
* FUNCTION -                                                            DMT51600
*                                                                       DMT51610
*        THIS ROUTINE FUNCTIONS AS A DEBLOCK ROUTINE FOR THE            DMT51620
*        VM/370 PAGE SPOOL BUFFERS.  IT RETURNS THE DEBLOCKED           DMT51630
*        RECORD IN THE RCTTDTA1 BUFFER.                                 DMT51640
*                                                                       DMT51650
* CALLS TO OTHER ROUTINES -                                             DMT51660
*                                                                       DMT51670
*        DMKDRD - VIA DIAGNONE CODE X'0014'                             DMT51680
*                                                                       DMT51690
* OPERATION -                                                           DMT51700
*                                                                       DMT51710
*        1. IF NEEDED READ THE NEXT SPOOL PAGE BUFFER FROM VM.          DMT51720
*                                                                       DMT51730
*        2. CONSTRUCT THE RECORD FROM THE CCW DATA IN THE SPOOL         DMT51740
*           PAGE BUFFER.                                                DMT51750
*                                                                       DMT51760
*        3. MOVE IN THE CARRIAGE CONTROL BYTE FROM THE CCW.             DMT51770
*                                                                       DMT51780
*        4. RETURN TO CALLER.                                           DMT51790
*                                                                       DMT51800
* RESPONSES -                                                           DMT51810
*                                                                       DMT51820
*        NONE                                                           DMT51830
*                                                                       DMT51840
* ERROR MESSAGES -                                                      DMT51850
*                                                                       DMT51860
*        NONE                                                           DMT51870
*                                                                       DMT51880
*.                                                                      DMT51890
         SPACE 1                                                        DMT51900
*                                                                       DMT51910
*        REGISTERS                                                      DMT51920
*                                                                       DMT51930
*        GPR.1  INPUT AREA FOR PACK                                     DMT51940
*        GPR.2  OUTPUT AREA FOR PACK                                    DMT51950
*        GPR.3  ANCHOR CCW IN VM SPOOL BLOCK                            DMT51960
*        GPR.5  INPUT LENGTH FOR PACK                                   DMT51970
*        GPR.6  COUNT OF NON-TIC CCWS LEFT IN VM SPOOL BUFFER           DMT51980
*        GPR.7  NEXT CCW IN VM SPOOL BLOCK                              DMT51990
*        GPR.9  BASE REGISTER                                           DMT52000
*        GPR.10 BASE REGISTER                                           DMT52010
*        GPR.11 BASE REGISTER                                           DMT52020
*        GPR.12 BASE REGISTER                                           DMT52030
*        GPR.14 LINK REGISTER                                           DMT52040
         EJECT                                                          DMT52050
VMDEBLOK DS    0H                                                       DMT52060
         L     R1,RDEVFIOA         -> record buffer               *XJE
         L     R15,SPLREQ          -> NJESPL routine              *XJE
         BALR  R14,R15             Go read a record from NETSPOOL *XJE
         LTR   R15,R15             End of file?                   *XJE
         BNZ   VMDERET1            Branch if yes                  *XJE
*
         L     R1,RDEVFIOA         -> record                      *XJE
         MVI   RCTTDTA1+1,C' '     Blank first byte of buffer  SML2NJE4 DMT53590
         MVC   RCTTDTA1+2(132),RCTTDTA1+1 Blank rest of buffer SML2NJE4 DMT53600
         MVC   RCTOPCOD(1),2(R1)   Plug in CCW op-code            *XJE
         SR    R5,R5               Clear for IC                   *XJE
         ICM   R5,3,0(R1)          Pick up count of data          *XJE
         STH   R5,RCTCCWCT         SET DATA LENGTH IN TCT         *XJE  DMT53660
         BCTR  R5,0           REDUCE BY ONE FOR CHARACTER      @VA05472 DMT53670
*                             OPERATION                                 DMT53680
         LA    R2,RCTTDTA1+1        Get address for output dataSML2NJE4 DMT53690
         TM    RSW1,PTRANS          Is this a PRT file?        SML2NJE4 DMT53700
         BZ    XMSKIPCC             Not a PRT file. No CC.     SML2NJE4 DMT53710
         TM    RCTOPCOD,X'03'       Is this a NOP (NJE header) SML2NJE4 DMT53720
         BO    XMSKIPCC             Is a NOP. No CC then.      SML2NJE4 DMT53730
         LA    R2,RCTTDTA1+2        Skip an extra byte for CC  SML2NJE4 DMT53740
XMSKIPCC EQU   *                                                  *XJE  DMT53750
         LA    R1,3(,R1)            -> past len and OP byte       *XJE
         EX    R5,VMDEMVC          MOVE IN PACKED DATA.                 DMT53760
*VMDEMVC MVC   0(*-*,R2),0(R1)     Executed by above code      SML2NJE4 DMT53950
         B     VMDERET2                                           *XJE
*
*--- The rest of VMDEBLOK, below, is not used any longer and      *XJE  DMT52070
*--- is replaced by the code just above.                          *XJE  DMT52070
*                                                                       DMT52070
*                                                                       DMT52070
*                                                                       DMT52070
*        SETUP SPOOL BLOCK POINTERS                                     DMT52080
*                                                                       DMT52090
*                                                                       DMT52100
*        CHECK FOR VM SPOOL BLOCK PRESENT                               DMT52110
*                                                                       DMT52120
         TM    RSW1,CLINE          ANYTHING IN BUFFER?                  DMT52130
         BO    VMSPBIN             IF THE VM SPOOL BLOCK IS IN.         DMT52140
*                                                                       DMT52150
*        READ A VM SPOOL BLOCK.                                         DMT52160
*                                                                       DMT52170
VMSPGET  EQU   *                                                        DMT52180
*                                                                       DMT52190
         USING SPLINK,R5           GET SPLINK ADDRESSABILITY            DMT52200
         L     R5,RDEVFIOA         GET FILE I/O AREA ADDRESS            DMT52210
         L     R8,RDEVTAG          GET READER TAG ADDRESS               DMT52220
         LH    R6,TAGDEV-TAG(,R8)  GET READER ADDRESS             *XJE  DMT52230
         SR    R7,R7               IND READ OF NEXT SP BLK REC          DMT52240
*********DIAG  R5,R6,X'14'         COMMAND SPOOL READER                 DMT52250
*                                                                       DMT52260
         BC    8,VMSPOK            IF THE READ IS SUCCESSFUL.           DMT52270
*                                                                       DMT52280
         BC    4,VMDERET1          IF END OF FILE.                      DMT52290
         BC    2,VMDERET1          IF NO MORE FILES.                    DMT52300
*                                                                       DMT52310
*        ERROR ON SPOOL READ, GPR12 WILL CONTAIN..                      DMT52320
*  4     INVALID SPOOL READER ADDRESS                                   DMT52330
*  8     INVALID DEVICE                                                 DMT52340
* 12     DEVICE BUSY WITH SIO I/O                                       DMT52350
* 16     PAGING I/O ERROR IN SETTING UP BUFFER.                         DMT52360
*                                                                       DMT52370
**                                 WRITE ERROR MSG                      DMT52380
**       MSGX  108,AXSFILE         Message 108 expansion below    *XJE  DMT52390
         MVC   MSGXNUM,=AL2(108)      +                                 DMT52400
         MVC   MSGXVAL+0(8),AXSFILE   +                                 DMT52410
         LA    0,8+4                  +                                 DMT52420
         BAL   14,XJE3MSG          To local msg routine                 DMT52430
         B     VMDERET1            AND IGNORE FOR PRESENT.              DMT52440
         EJECT                                                          DMT52450
VMSPOK   EQU   *                   HERE ON SUCCESSFUL READ              DMT52460
         L     R6,SPRECNUM         PICKUP SPRECNUM FROM NEW BLOCK.      DMT52470
         LTR   R6,R6               ALL DONE IF ZERO                     DMT52480
         BZ    VMSPGET             TO GET THE NEXT SPOOL BLOCK.         DMT52490
         LA    R3,SPRECNUM+4       STEP OVER POINTERS IN SPOOL BLOCK    DMT52500
         LR    R7,R3               AND INITIALIZE WORKING REGS.         DMT52510
         OI    RSW1,CLINE          TO INDICATE BLOCK PRESENT            DMT52520
         B     VMSPCCW             TO PROCESS NEXT CCW CHAIN.           DMT52530
         DROP  R5                                                       DMT52540
         SPACE                                                          DMT52550
*                                                                       DMT52560
*        BUFFER IS PRESENT ON ENTRY TO VMSB2CP.                         DMT52570
*                                                                       DMT52580
VMSPBIN  EQU   *                                                        DMT52590
         L     R3,VMSPANCH         TO PICKUP CURRENT CCW ANCHOR.        DMT52600
         L     R7,VMSPNEXT         AND NEXT CCW POINTER.                DMT52610
         L     R6,VMSPNUM          PICKUP COUNT OF REMAINING CCWS.      DMT52620
         EJECT                                                          DMT52630
*                                                                       DMT52640
*        HERE TO PROCESS NEXT CCW CHAIN.                                DMT52650
*                                                                       DMT52660
VMSPCCW  EQU   *                                                        DMT52670
*                                                                       DMT52680
*   PRINTER                                                             DMT52690
*        DATA MOVING CCW'S ARE..                                        DMT52700
*          (0,1,8,9,A,B,C,D,E)(1,9)                                     DMT52710
*          PLUS 63 BUT NOT 81 AND E9.                                   DMT52720
*   PUNCH                                                               DMT52730
*        DATA MOVING CCW'S ARE..                                        DMT52740
*          (0,2,4,6,8,A)1                                               DMT52750
*                                                                       DMT52760
*   READER                                                              DMT52770
*        DATA MOVING CCW'S ARE 02 AND 42                                DMT52780
*          THESE ARE PRESENT FOR REAL READER FILES.                     DMT52790
*          (AND REQUIRE DIFFERENT TREATMENT THAN VIRTUAL FILES          DMT52800
*           FROM THE PRINTER OR PUNCH.)                                 DMT52810
*                                                                       DMT52820
*        IMMEDIATE CCW OPS WITH NO DATA ARE..                           DMT52830
*          (0,1,8,9,A,B,C,D,E)(B,3)                                     DMT52840
*          EXCEPT 03,83, AND EB.                                        DMT52850
*                                                                       DMT52860
*        03 IS NOP (USED FOR PASSING SPOOL INFORMATION.)                DMT52870
*        08 IS TIC TO NEXT CCW CHAIN, IF ANY.                           DMT52880
*                                                                       DMT52890
*        AFTER PROCESSING A NON-TIC CCW CC SUCCESSFULLY, BCT TO VMSPRET DMT52900
*                                                                       DMT52910
VMSP4    EQU   *                                                        DMT52920
         SPACE 2                                                        DMT52930
*        NOP (X'03') IS ASSUMED TO BE A DATA MOVER IF                   DMT52940
*        FOLLOWED BY A TIC, OTHERWISE IT IS PROCESSED                   DMT52950
*        AS AN IMMEDIATE.                                               DMT52960
*                                                                       DMT52970
*                                                                       DMT52980
         TM    0(R7),X'06'         DECODE CCW                           DMT52990
         BZ    VMSP1               IF DATA MOVER OR TIC                 DMT53000
         CLI   0(R7),X'63'         AND                                  DMT53010
         BE    VMSPDATA            IF THIS IS A LOAD OF FORMS BUFFER    DMT53020
         CLI   0(R7),X'03'         ALSO CHECK FOR A NOP AND             DMT53030
         BE    VMSPNOP             IF IT IS.                            DMT53040
*                                                                       DMT53050
***** CHECK FOR REAL READER FILES (42,02)      IGNORE FOR MOMENT ****** DMT53060
*                                                                       DMT53070
         CLI   0(R7),X'42'         REAL READER CCW?                     DMT53080
         BE    VMSPFINI            YES                                  DMT53090
         CLI   0(R7),X'02'         REAL READER CCW?                     DMT53100
         BE    VMSPFINI            YES                                  DMT53110
         EJECT                                                          DMT53120
*        NOT DATA MOVER, TIC, OR END.  IMMEDIATE IS ASSUMED.            DMT53130
*                                                                       DMT53140
VMSPIMED EQU   *                                                        DMT53150
         MVC   RCTOPCOD(1),0(R7)   SET OP CODE                          DMT53160
         LA    R4,1                SET DATA LENGTH TO 1                 DMT53170
         STH   R4,RCTCCWCT         AND STORE IN TCT                     DMT53180
         MVC   RCTTDTA1+1(2),BLANK  One (or two incl CC) bytes SML2NJE4 DMT53190
*                                                                       DMT53200
*        HERE IF NON-TIC                                                DMT53210
*                                                                       DMT53220
VMSP2    EQU   *                                                        DMT53230
         LA    R7,8(,R7)           STEP TO NEXT CCW AND                 DMT53240
         CLI   0(R7),X'08'         CHECK IF TIC                         DMT53250
         BE    VMSP3               IF IT IS, ELSE                       DMT53260
         LR    R3,R7               MOVE ANCHOR ALSO. THEN               DMT53270
VMSP3    EQU   *                                                        DMT53280
         BCT   R6,VMSPRET          TO PROCESS NEXT, IF ANY              DMT53290
         B     VMSPFINI            THAT'S ALL FOLKS.                    DMT53300
*                                                                       DMT53310
*        HERE IF CCW IS XXXXX00X (BASE 2)                               DMT53320
*                                                                       DMT53330
VMSP1    EQU   *                                                        DMT53340
         TM    0(R7),X'01'         CONTINUE DECODE                      DMT53350
         BO    VMSPDATA            IF CCW IS XXXXX001                   DMT53360
         CLI   0(R7),X'08'         CHECK DIRECTLY FOR TIC               DMT53370
         BE    VMSPTIC             IF YES.                              DMT53380
         SPACE 2                                                        DMT53390
**       MSGX  190,AXSFILE         MSG 190 expansion below              DMT53400
         MVC   MSGXNUM,=AL2(190)      +                                 DMT53410
         MVC   MSGXVAL+0(8),AXSFILE   +                                 DMT53420
         LA    0,8+4                  +                                 DMT53430
         BAL   14,XJE3MSG          To local msg routine                 DMT53440
         B     VMSPFINI            TO IGNORE FOR PRESENT.               DMT53450
         SPACE 3                                                        DMT53460
VMSPTIC  EQU   *                   PROCESS TIC.                         DMT53470
         LH    R7,2(R7)            GET DISPLACEMENT OF NEXT CCW AND     DMT53480
         AR    R3,R7               ADD IN LAST ANCHOR TO GET NEW ONE.   DMT53490
         LR    R7,R3               TO INDICATE NEXT CCW TO BE PROCESSED DMT53500
         B     VMSPCCW             TO PROCESS IT.                       DMT53510
         SPACE 3                                                        DMT53520
VMSPNOP  EQU   *                   PROCESS NOP                          DMT53530
         CLI   8(R7),X'08'         LOOK AHEAD FOR TIC AND               DMT53540
         BE    VMSPDATA            TREAT A DATA MOVER IF PRESENT.       DMT53550
         B     VMSPIMED            ELSE TREAT AS IMMEDIATE.             DMT53560
         EJECT                                                          DMT53570
VMSPDATA EQU   *                   HERE FOR DATA MOVING CCW CC.         DMT53580
         MVI   RCTTDTA1+1,C' '     Blank first byte of buffer  SML2NJE4 DMT53590
         MVC   RCTTDTA1+2(132),RCTTDTA1+1 Blank rest of buffer SML2NJE4 DMT53600
         LH    R1,2(R7)            GET OFFSET FROM ANCHOR FOR DATA      DMT53610
         AR    R1,R3               AND MAKE IT ABSOLUTE                 DMT53620
         SR    R5,R5               CLEAR OUT REGISTER                   DMT53630
         IC    R5,7(R7)            PICKUP COUNT OF DATA                 DMT53640
         MVC   RCTOPCOD(1),0(R7)   MOVE IN CCW CC, THEN                 DMT53650
         STH   R5,RCTCCWCT         SET DATA LENGTH IN TCT               DMT53660
         BCTR  R5,0           REDUCE BY ONE FOR CHARACTER      @VA05472 DMT53670
*                             OPERATION                                 DMT53680
         LA    R2,RCTTDTA1+1        Get address for output dataSML2NJE4 DMT53690
         TM    RSW1,PTRANS          Is this a PRT file?        SML2NJE4 DMT53700
         BZ    VMSKIPCC             Not a PRT file. No CC.     SML2NJE4 DMT53710
         TM    RCTOPCOD,X'03'       Is this a NOP (NJE header) SML2NJE4 DMT53720
         BO    VMSKIPCC             Is a NOP. No CC then.      SML2NJE4 DMT53730
         LA    R2,RCTTDTA1+2        Skip an extra byte for CC  SML2NJE4 DMT53740
VMSKIPCC EQU   *                                               SML2NJE4 DMT53750
         EX    R5,VMDEMVC          MOVE IN PACKED DATA.                 DMT53760
         B     VMSP2               AND RETURN                           DMT53770
         SPACE 3                                                        DMT53780
VMSPFINI EQU   *                   DONE WITH A VM SPOOL BLOCK           DMT53790
         NI    RSW1,X'FF'-CLINE    TO TURN OFF BLOCK FLAG AND           DMT53800
         SPACE 3                                                        DMT53810
VMSPRET  EQU   *                                                        DMT53820
         ST    R3,VMSPANCH         SAVE CCW ANCHOR.                     DMT53830
         ST    R7,VMSPNEXT         AND NEXT CCW                         DMT53840
         ST    R6,VMSPNUM          AND COUNT OF REMAINING CCW'S.        DMT53850
         SR    R15,R15             SET 0 RET CODE                       DMT53860
         B     VMDERET2            TO COMPLETE RETURN.                  DMT53870
         SPACE 1                                                        DMT53880
VMDERET1 EQU   *                                                        DMT53890
         LA    R15,4               SET NON ZERO RETURN CODE             DMT53900
         SPACE 1                                                        DMT53910
VMDERET2 EQU   *                                                        DMT53920
         B     XJE2XIT             AND RETURN                     *XJE  DMT53930
         SPACE 3                                                        DMT53940
VMDEMVC  MVC   0(*-*,R2),0(R1)     Executed by above code      SML2NJE4 DMT53950
         SPACE 1                                                        DMT53960
*        TEMPORARIES                                                    DMT53970
         EJECT                                                          DMT53980
*.                                                                      DMT53990
*                                                                       DMT54000
* ENTRY NAME -                                                          DMT54010
*                                                                       DMT54020
*        TODEBCD                                                        DMT54030
*                                                                       DMT54040
* FUNCTION -                                                            DMT54050
*                                                                       DMT54060
*        CONVERT S/370 TOD TO EBCDIC DATE AND TIME                      DMT54070
*                                                                       DMT54080
* CALLS TO OTHER ROUTINES -                                             DMT54090
*                                                                       DMT54100
*        GTODEBC - TO CONVERT THE TIME AND DATE                         DMT54110
*                                                                       DMT54120
* OPERATION -                                                           DMT54130
*                                                                       DMT54140
*        1. ISSUE A CALL TO COMMON GTODEBCD ROUTINE TO                  DMT54150
*           RETRIEVE TIME AND DATE.                                     DMT54160
*                                                                       DMT54170
* RESPONSES -                                                           DMT54180
*                                                                       DMT54190
*        NONE                                                           DMT54200
*                                                                       DMT54210
* ERROR MESSAGES -                                                      DMT54220
*                                                                       DMT54230
*        NONE                                                           DMT54240
*                                                                       DMT54250
* On entry:  R1 -> two words containing TOD value to convert      *XJE  DMT54250
*                                                                       DMT54250
*.                                                                      DMT54260
TODEBCDX EQU   *             EXTERNAL EP to TODEBCD                     DMT54270
         BAL   R14,TODEBCD                                              DMT54280
         B     XJE2XIT             AND RETURN                     *XJE  DMT54290
*                                                                       DMT54300
         SPACE 3                                                        DMT54310
TODEBCD  DC    0H'0'         LOCAL ENTRY                                DMT54320
         STM   R13,R14,TODSAVE1    SAVE RETURN                          DMT54330
         LM    R0,R1,0(R1)         Get file date / time           *XJE  DMT17420
         LA    R13,MMDDYYHH        GET WORK ADDR ADDR FOR CALL          DMT54340
*DEL     L     R15,TCOM            GET COMMON ROUTINES LIST       *XJE  DMT54350
         L     R15,GTODEBCD        AND THE TIME CONVERT ADDR            DMT54360
         BALR  R14,R15             AND DO IT                            DMT54370
         LM    R13,R14,TODSAVE1    RESTORE REGS                         DMT54380
         BR    R14                                                      DMT54390
*                                                                 *XJE  DMT54400
*.                                                                *XJE  DMT54410
*                                                                 *XJE  DMT54420
* ENTRY NAME -                                                    *XJE  DMT54430
*                                                                 *XJE  DMT54440
*        XJE3MSG                                                  *XJE  DMT54450
*                                                                 *XJE  DMT54460
* FUNCTION -                                                      *XJE  DMT54470
*                                                                 *XJE  DMT54480
*        This is a local copy of the MSG routine for this csect.  *XJE  DMT54490
*        THIS ROUTINE PREPARES AND SENDS REQUESTS TO THE          *XJE  DMT54500
*        SPECIALIZED TASK REX, IN ORDER TO WRITE MESSAGES         *XJE  DMT54510
*        ON THE OPERATOR'S CONSOLE.                               *XJE  DMT54520
*                                                                 *XJE  DMT54530
* CALLS TO OTHER ROUTINES -                                       *XJE  DMT54540
*                                                                 *XJE  DMT54550
*        DMTREX - TO EXECUTE THE MSG WRITE                        *XJE  DMT54560
*                                                                 *XJE  DMT54570
* OPERATION -                                                     *XJE  DMT54580
*                                                                 *XJE  DMT54590
*        1. MOVE VARIABLE PART OF MSG TO GIVE REQUEST BUFFER      *XJE  DMT54600
*                                                                 *XJE  DMT54610
*        2. INITIATE GIVE REQUEST TO DMTREX WITH MSG BUFFER.      *XJE  DMT54620
*                                                                 *XJE  DMT54630
*        3. WAIT FOR COMPLETION                                   *XJE  DMT54640
*                                                                 *XJE  DMT54650
*        4. RETURN TO CALLER                                      *XJE  DMT54660
*                                                                 *XJE  DMT54670
* ENTRY CONDITIONS:                                               *XJE  DMT54680
*                                                                 *XJE  DMT54690
*        IN REG. 14 THE RETURN ADDRESS                            *XJE  DMT54700
*        IN REG. 15 THE ROUTING CODE                              *XJE  DMT54710
*        IN REG. 1 THE POINTER TO THE VARIABLE PORTION OF         *XJE  DMT54720
*              THE MESSAGE STRING                                 *XJE  DMT54730
*        IN REG. 0 THE LENGTH OF THE VARIABLE PORTION OF THE MSG  *XJE  DMT54740
*                                                                 *XJE  DMT54750
* EXIT CONDITIONS:                                                *XJE  DMT54760
*                                                                 *XJE  DMT54770
*        NONE                                                     *XJE  DMT54780
*                                                                 *XJE  DMT54790
* NOTE:                                                           *XJE  DMT54800
*        NONE                                                     *XJE  DMT54810
*                                                                 *XJE  DMT54820
* RESPONSES -                                                     *XJE  DMT54830
*                                                                 *XJE  DMT54840
*        NONE                                                     *XJE  DMT54850
*                                                                 *XJE  DMT54860
* ERROR MESSAGES -                                                *XJE  DMT54870
*                                                                 *XJE  DMT54880
*        NONE                                                     *XJE  DMT54890
*                                                                 *XJE  DMT54900
*.                                                                *XJE  DMT54910
         EJECT                                                    *XJE  DMT54920
XJE3MSG  DC    0H'0'                                              *XJE  DMT54930
         STM   R14,R2,MSGSAVE      SAVE REGISTERS                 *XJE  DMT54940
*****    LA    R1,MSGXNUM          -> Message id, variables       *XJE  DMT54950
         LR    R2,R0               MOVE R0 INTO WORK REG          *XJE  DMT54960
         BCTR  R2,0                REDUCE BY ONE FOR MVC          *XJE  DMT54970
         EX    R2,XSGMVC1          AND MOVE TO MSG REQ BUFFER     *XJE  DMT54980
         AH    R2,=H'24'           UP FOR HEADER                  *XJE  DMT54990
         STC   R2,MSGBLK           AND STORE IN MSG REQ BUFFER    *XJE  DMT55000
         CLI   MSGLINK,X'00'       NEED ROUTING?                  *XJE  DMT55010
         BNE   XSG1                NO CONTINUE                    *XJE  DMT55020
         MVC   MSGLINK(8),AXSLINK  MOVE IN OUR LINKID             *XJE  DMT55030
XSG1     EQU   *                                                  *XJE  DMT55040
         LA    R1,MSGREQ           GET READY FOR GIVE             *XJE  DMT55050
         XC    MSGREQ(4),MSGREQ    CLEAR OUT SYNCH LOCK           *XJE  DMT55060
         L     R15,GIVEREQ         SYSTEM GIVE REQUEST EXECUTATOR *XJE  DMT55070
         BALR  R14,R15             GO GIVE THE BUFFER TO REX      *XJE  DMT55080
         L     R15,WAITREQ         WAIT FOR THE COMPLETION OF     *XJE  DMT55090
         BALR  R14,R15             CONSOLE OPERATION              *XJE  DMT55100
         MVI   MSGLINK,X'00'       SHOW NO RESPONSE               *XJE  DMT55110
         MVI   MSGBLK+2,X'00'      INDICATE NO ROUTING            *XJE  DMT55120
         LM    R14,R2,MSGSAVE      RESTORE REGS                   *XJE  DMT55130
         BR    R14                 AND RETURN                     *XJE  DMT55140
*                                                                 *XJE  DMT55150
XSGMVC1  MVC   MSGBUF(0),0(R1)     TO BE EXECUTED FROM ABOVE      *XJE  DMT55160
*                                                                 *XJE  DMT55170
XJE2XIT  EQU   *                   Exit with RC in R15            *XJE  DMT55180
         LM    R0,R14,XJE2SAVE                                    *XJE  DMT55190
         BR    R14                                                *XJE  DMT55200
*                                                                       DMT55210
         LTORG                                                    *XJE  DMT55220
         EJECT                                                          DMT55230
*                                                                       DMT55240
********************                                                    DMT55250
*                  *   Management of various NJE headers                DMT55260
* CSECT DMTXJE3    *   Uses csect DMTXJEB for header work               DMT55270
*                  *   areas.                                           DMT55280
********************                                                    DMT55290
*                                                                       DMT55300
DMTXJE3  CSECT                                                    *XJE  DMT55310
         STM   R0,R15,XJE3SAVE     Save regs                      *XJE  DMT55320
         LR    R12,R15             Set base                       *XJE  DMT55330
         USING DMTXJE3,R12                                        *XJE  DMT55340
*                                                                       DMT55350
         L     R10,=A(DMTXJEB)     -> DMTXJEB variables stg       *XJE  DMT55360
         USING DMTXJEB,R10         establish addressability       *XJE  DMT55370
  LA 10,2048(,R9)                                                       DMT55380
  LA  10,2048(,10)                                                      DMT55390
*                                                                       DMT55400
*                                                                       DMT55410
         LR    R14,R0              Get entry code                 *XJE  DMT55420
         B     XJE3FUNC(R14)       Branch into table of functions *XJE  DMT55430
*                                                                       DMT55440
XJE3FUNC B     BLDNMRC          00 Build NJE NMR hdr for cmd      *XJE  DMT55450
         B     BLDNMRM          04 Build NJE NMR hdr for msg      *XJE  DMT55460
         B     DEFNJEHD         08 Generate default NJE header    *XJE  DMT55470
         B     BLDNJEJH         0C Build NJE job hdr for out file *XJE  DMT55480
         B     BLDNJEDS         10 Build NJE dataset hdr out file *XJE  DMT55490
         B     BLDNJEJT         14 Build NJE job trailer out file *XJE  DMT55500
*                                                              SML2NJE4 DMT55510
*        BLDNMRC - Build NJE NMR header for command            SML2NJE4 DMT55520
*                                                              SML2NJE4 DMT55530
*        Registers on entry:                                   SML2NJE4 DMT55540
*              R1  - Length of command                         SML2NJE4 DMT55550
*              R14 - Return address                            SML2NJE4 DMT55560
*                                                              SML2NJE4 DMT55570
*              R2 is used to address NMRDSECT without saving   SML2NJE4 DMT55580
*                                                              SML2NJE4 DMT55590
*              Base registers R9/R10/R12 are used to              *XJE  DMT55600
*              address various items.                          SML2NJE4 DMT55610
*                                                              SML2NJE4 DMT55620
*        On exit, R1 is updated to include length of NMR hdrs  SML2NJE4 DMT55630
*                                                              SML2NJE4 DMT55640
BLDNMRC  DS    0H                                              SML2NJE4 DMT55650
         LA    R2,NMRODATA         Get address of NMR buffer   SML2NJE4 DMT55660
         USING NMRDSECT,R2         Get NMR addressability      SML2NJE4 DMT55670
         MVI   NMRFLAG,NMRFLAGC    Indicate command not msg    SML2NJE4 DMT55680
         MVI   NMRLVPR,X'77'       Set priority and level      SML2NJE4 DMT55690
         MVI   NMRTYPE,X'00'       Unformatted command         SML2NJE4 DMT55700
         STC   R1,NMRML            Set command length          SML2NJE4 DMT55710
         MVC   NMRTONOD,CMDRESP+20 Set destination node        SML2NJE4 DMT55720
         MVI   NMRTOQUL,X'00'      Zero NMRTOQUL               SML2NJE4 DMT55730
         MVC   NMROUT,CMDRESP+12   Set originating userid      SML2NJE4 DMT55740
         TM    NMROUT,X'80'        Is origin userid present?   SML2NJE4 DMT55750
         BZ    BNCNOSRU            No origin userid present    SML2NJE4 DMT55760
         OI    NMRFLAG,NMRFLAGT    Indicate org userid present SML2NJE4 DMT55770
BNCNOSRU EQU   *                                               SML2NJE4 DMT55780
         MVC   NMRFMNOD,LOCATION   Make origin node local      SML2NJE4 DMT55790
         MVI   NMRFMQUL,X'00'      Zero NMRFMQUL               SML2NJE4 DMT55800
         LA    R1,NMRHSIZE(,R1)    Add length of NMR header    SML2NJE4 DMT55810
         DROP  R2                                              SML2NJE4 DMT55820
         ST    R1,XJE3SAVE+1*4     Return the R1 value            *XJE  DMT55830
         B     XJE3XIT             Return to caller               *XJE  DMT55840
*                                                              SML2NJE4 DMT55850
*        BLDNMRM - Build NJE NMR header for message            SML2NJE4 DMT55860
*                                                              SML2NJE4 DMT55870
*        On entry, R1 should contain length of message.        SML2NJE4 DMT55880
*        On exit, R1 is updated to include length of NMR hdrs  SML2NJE4 DMT55890
*        Base registers R9/R10/R12 are used to address            *XJE  DMT55900
*        various items.  R0,R2-R8 are used for scratch         SML2NJE4 DMT55910
*                                                              SML2NJE4 DMT55920
*        This is pretty gruesome stuff!                        SML2NJE4 DMT55930
*                                                              SML2NJE4 DMT55940
BLDNMRM  DS    0H                                              SML2NJE4 DMT55950
         XC    NMROTEMP,NMROTEMP   Zero temporary workspace    SML2NJE4 DMT55960
         LA    R8,NMRODATA         Get address of NMR buffer   SML2NJE4 DMT55970
         USING NMRDSECT,R8         Get NMR addressability      SML2NJE4 DMT55980
         LM    R2,R5,NMRODATA      Get destination node,userid SML2NJE4 DMT55990
         STM   R2,R3,NMRTONOD      Store destination node      SML2NJE4 DMT56000
         MVI   NMRFLAG,0           Msg, no destination userid  SML2NJE4 DMT56010
         LTR   R4,R4               Check if dest userid blank  SML2NJE4 DMT56020
         BNM   BNMNODU             Top bit clear => blank / 0  SML2NJE4 DMT56030
         OI    NMRFLAG,NMRFLAGT    Flag dest userid in NMROUT  SML2NJE4 DMT56040
BNMNODU  DS    0H                                              SML2NJE4 DMT56050
         MVI   NMRLVPR,X'77'       Set level and priority      SML2NJE4 DMT56060
         MVI   NMRTYPE,NMRTYPET    No src userid, no timestamp SML2NJE4 DMT56070
         CLC   22(4,R8),=C'170I'   Is source userid present?   SML2NJE4 DMT56080
         BE    BNMNOUSR            MSG command, no src userid  SML2NJE4 DMT56090
         CLC   22(4,R8),=C'171I'   Is source userid present?   SML2NJE4 DMT56100
         BNE   BNMCMRSP            Locally generated cmd reply SML2NJE4 DMT56110
BNMNOUSR DS    0H                                              SML2NJE4 DMT56120
         STCM  R4,B'1111',NMROUT+0 Store 1/2 destination useridSML2NJE4 DMT56130
         STCM  R5,B'1111',NMROUT+4 Store 2/2 destination useridSML2NJE4 DMT56140
         LM    R3,R5,BNMADDRS      Get addresses for loop      SML2NJE4 DMT56150
         LA    R14,NMRODATA        -> data field                  *XJE  DMT56160
         AR    R3,R14              Add offset to address          *XJE  DMT56170
         AR    R5,R14              Add offset to address          *XJE  DMT56180
BNMLOOP1 DS    0H                                              SML2NJE4 DMT56190
         CLI   0(R3),C'('          Find bracket before userid  SML2NJE4 DMT56200
         BE    BNMSUSER            Found end of source node    SML2NJE4 DMT56210
         CLI   0(R3),C')'          Find bracket after userid   SML2NJE4 DMT56220
         BE    BNMUSRND            Found end of source userid  SML2NJE4 DMT56230
         CLI   0(R3),C':'          Find colon after link name  SML2NJE4 DMT56240
         BE    BNMSNODE            Found end of source node    SML2NJE4 DMT56250
BNMRSLP1 DS    0H                                              SML2NJE4 DMT56260
         BXLE  R3,R4,BNMLOOP1      Keep looking for colon      SML2NJE4 DMT56270
BNMCOLON DS    0H                                              SML2NJE4 DMT56280
         LA    R3,2(,R3)           Increment past colon, space SML2NJE4 DMT56290
         LA    R4,1                Restore loop increment      SML2NJE4 DMT56300
         LA    R5,8(,R3)           Longest possible userid     SML2NJE4 DMT56310
BNMLOOP2 DS    0H                                              SML2NJE4 DMT56320
         CLI   0(R3),C' '          Find blank after userid     SML2NJE4 DMT56330
         BE    BNMBLANK            Found blank after userid    SML2NJE4 DMT56340
         BXLE  R3,R4,BNMLOOP2      Keep looking for blank      SML2NJE4 DMT56350
BNMBLANK DS    0H                                              SML2NJE4 DMT56360
         LA    R6,1(,R3)           Get start of message        SML2NJE4 DMT56370
         LA    R3,NMRODATA(R1)     Get address of message end  SML2NJE4 DMT56380
         SR    R3,R6               Get length of message text  SML2NJE4 DMT56390
         LR    R1,R3               Save msg length for later   SML2NJE4 DMT56400
         LA    R4,NMRMSG           Get msg / src user address  SML2NJE4 DMT56410
         TM    NMRTYPE,NMRTYPE4    Source userid available?    SML2NJE4 DMT56420
         BNO   BNMNOSU             No. Via SML link or console SML2NJE4 DMT56430
         LA    R5,L'NMRECSID       Get length of NMRECSID      SML2NJE4 DMT56440
         LR    R3,R0               Get length of source userid SML2NJE4 DMT56450
         ICM   R3,B'1000',BLANK    Insert padding character    SML2NJE4 DMT56460
         MVCL  R4,R2               Move down source userid     SML2NJE4 DMT56470
         LR    R3,R1               Restore R3                  SML2NJE4 DMT56480
         LA    R1,L'NMRECSID(,R1)  Increase msg & NMR length   SML2NJE4 DMT56490
BNMNOSU  DS    0H                                              SML2NJE4 DMT56500
         LR    R2,R6               Get message start address   SML2NJE4 DMT56510
         LR    R5,R3               Dest length = source length SML2NJE4 DMT56520
         MVCL  R4,R2               Move message down           SML2NJE4 DMT56530
         B     BNMCOMON            Do common code              SML2NJE4 DMT56540
BNMSUSER DS    0H                                              SML2NJE4 DMT56550
         OI    NMRTYPE,NMRTYPE4    Source userid is present    SML2NJE4 DMT56560
BNMSNODE DS    0H                                              SML2NJE4 DMT56570
         CLI   NMROTEMP,X'00'      Already got source node?    SML2NJE4 DMT56580
         BNE   BNMCOLON            Yes. Skip getting it again  SML2NJE4 DMT56590
         LA    R2,NMRODATA+32      Get start of source node    SML2NJE4 DMT56600
         SR    R3,R2               Get length of source node   SML2NJE4 DMT56610
         ICM   R3,B'1000',BLANK    Insert padding character    SML2NJE4 DMT56620
         LA    R4,NMROTEMP         Get temporary staging area  SML2NJE4 DMT56630
         LA    R5,L'NMROTEMP       Get length of staging area  SML2NJE4 DMT56640
         MVCL  R4,R2               Copy source node            SML2NJE4 DMT56650
         LR    R3,R2               Restore pointer in R3       SML2NJE4 DMT56660
         CLI   0(R3),C'('          Are we done with source yet SML2NJE4 DMT56670
         BNE   BNMCOLON            Finished with msg source    SML2NJE4 DMT56680
         LM    R4,R5,BNMADDRS+4    Restore R4 and R5 too       SML2NJE4 DMT56690
         LA    R14,NMRODATA        -> data field                  *XJE  DMT56700
         AR    R5,R14              Add offset to address          *XJE  DMT56710
         LA    R2,1(,R3)           Save start of source userid SML2NJE4 DMT56720
         B     BNMRSLP1            Go back to looking for ')'  SML2NJE4 DMT56730
BNMUSRND DS    0H                                              SML2NJE4 DMT56740
         LR    R0,R3               Get end of source userid +1 SML2NJE4 DMT56750
         SLR   R0,R2               Get length of source userid SML2NJE4 DMT56760
         B     BNMRSLP1            Back to looking for colon   SML2NJE4 DMT56770
BNMCMRSP DS    0H                                              SML2NJE4 DMT56780
         MVC   NMROTEMP,LOCATION   Set source node to local    SML2NJE4 DMT56790
         LA    R6,NMRODATA-1(R1)   Get address of message end  SML2NJE4 DMT56800
         SH    R1,=H'16'           Subtract node, user length  SML2NJE4 DMT56810
         LR    R0,R1               Copy message length         SML2NJE4 DMT56820
BNMLOOP3 DS    0H                                              SML2NJE4 DMT56830
         MVC   NMRHSIZE-16(1,R6),0(R6) Move message up 14 bytesSML2NJE4 DMT56840
         BCTR  R6,0                Decrement address           SML2NJE4 DMT56850
         BCT   R0,BNMLOOP3         Loop until start of msg     SML2NJE4 DMT56860
         STCM  R4,B'1111',NMROUT+0 Store 1/2 destination useridSML2NJE4 DMT56870
         STCM  R5,B'1111',NMROUT+4 Store 2/2 destination useridSML2NJE4 DMT56880
BNMCOMON DS    0H                                              SML2NJE4 DMT56890
         STC   R1,NMRML            Set length of message text  SML2NJE4 DMT56900
         MVI   NMRTOQUL,X'00'      Clear NMRTOQUL              SML2NJE4 DMT56910
         MVC   NMRFMNOD,NMROTEMP   Move in originating node    SML2NJE4 DMT56920
         MVI   NMRFMQUL,X'00'      Fix NMRFMQUL                SML2NJE4 DMT56930
         DROP  R8                                              SML2NJE4 DMT56940
         LA    R1,NMRHSIZE(,R1)    Add in NMR header size      SML2NJE4 DMT56950
         ST    R1,XJE3SAVE+1*4     Return the R1 value            *XJE  DMT56960
         B     XJE3XIT             Return to caller               *XJE  DMT56970
*                                                                       DMT56980
*        DEFNJEHD - Generate default NJE header contents       SML2NJE4 DMT56990
*                                                              SML2NJE4 DMT57000
*        On entry, R3 should contain the address of the file   SML2NJE4 DMT57010
*        tag.                                                  SML2NJE4 DMT57020
*        Base registers R9/R10/R12 are used to address            *XJE  DMT57030
*        various items.                                        SML2NJE4 DMT57040
*                                                              SML2NJE4 DMT57050
DEFNJEHD DS    0H                                              SML2NJE4 DMT57060
         USING TAG,R3              Get tag addressability      SML2NJE4 DMT57070
         STCK  TAGINTOD            Default file time to now    SML2NJE4 DMT57080
         MVC   TAGINLOC,=C'????????' Default origin node       SML2NJE4 DMT57090
         MVC   TAGINVM,=C'????????'  Default origin userid     SML2NJE4 DMT57100
         MVC   TAGTOLOC,=C'????????' Default destination node  SML2NJE4 DMT57110
         MVC   PCTTOVM,=C'????????'  Default destination user  SML2NJE4 DMT57120
         MVI   TAGCLASS,C'A'       Default spool class to A    SML2NJE4 DMT57130
         MVC   TAGRECLN,=AL2(80)   Assume punch record length  SML2NJE4 DMT57140
         MVC   TAGDIST,=CL12' '    Blank distribution code     SML2NJE4 DMT57150
         MVC   TAGNAME,=CL12' '    Blank filename              SML2NJE4 DMT57160
         MVC   TAGTYPE,=CL12' '    Blank filetype              SML2NJE4 DMT57170
         MVC   TAGPRIOR,=AL2(50)   Transmission priority 50    SML2NJE4 DMT57180
         MVI   TAGINDEV,0          Don't assume device type    SML2NJE4 DMT57190
         MVC   TAGID,=H'0000'      Default spool file number   SML2NJE4 DMT57200
         MVC   TAGCOPY,=H'1'       Assume number of copies 1   SML2NJE4 DMT57210
         MVI   PSW1,X'00'          Clear discard and EOF flags SML2NJE4 DMT57220
         DROP  R3                  Finished with tag           SML2NJE4 DMT57230
         B     XJE3XIT             Return to caller               *XJE  DMT57240
         EJECT                                                 SML2NJE4 DMT57250
*                                                              SML2NJE4 DMT57260
*        BLDNJEJH - Build NJE job header for outgoing file     SML2NJE4 DMT57270
*                                                              SML2NJE4 DMT57280
*        On entry, R8 should contain the file tag.             SML2NJE4 DMT57290
*        R0 and R4 are modified without saving.                SML2NJE4 DMT57300
*        Base registers R9/R10/R12 are used to address            *XJE  DMT57310
*        various items.                                        SML2NJE4 DMT57320
*                                                              SML2NJE4 DMT57330
BLDNJEJH DS    0H                                              SML2NJE4 DMT57340
         USING TAG,R8                                          SML2NJE4 DMT57350
         MVI   RCTTSRC1,X'C0'      SRCB for NJE job header     SML2NJE4 DMT57360
         MVC   RCTTCT1,=AL2(NJHSIZE) Job header total length   SML2NJE4 DMT57370
         LA    R4,RCTTDTA1         NJE header buffer address   SML2NJE4 DMT57380
         USING NJEPDSEC,R4         Tell assembler to use it    SML2NJE4 DMT57390
         XC    NJEPDSEC(NJHSIZE),NJEPDSEC Zero whole segment   SML2NJE4 DMT57400
         MVC   NJEPLEN,=AL2(NJHSIZE) Length of job hdr segment SML2NJE4 DMT57410
         LA    R4,NJEPSIZE(,R4)    Skip over segment prefix    SML2NJE4 DMT57420
         USING NJHGDSEC,R4         Job header general section  SML2NJE4 DMT57430
         MVC   NJHGLEN,=AL2(NJHGSIZE) Length of general sect.  SML2NJE4 DMT57440
         MVC   NJHGJID,TAGID       Spool file number           SML2NJE4 DMT57450
         MVI   NJHGJCLS,C'A'       Execution class             SML2NJE4 DMT57460
         MVI   NJHGMCLS,C'A'       Message class               SML2NJE4 DMT57470
         MVI   NJHGPRIO,X'07'      Job priority                SML2NJE4 DMT57480
         MVI   NJHGJCPY,X'01'      Output copies               SML2NJE4 DMT57490
         XR    R0,R0               Assume PUN file (00)        SML2NJE4 DMT57500
         TM    TAGINDEV,TYPPUN     Are we actually punching?   SML2NJE4 DMT57510
         BO    NJEHPUN             Yes                         SML2NJE4 DMT57520
         BCTR  R0,0                Decrement to FF if PRT file SML2NJE4 DMT57530
NJEHPUN  STC   R0,NJHGLNCT         Lines per page              SML2NJE4 DMT57540
         MVC   NJHGACCT,BLANK      Accounting                  SML2NJE4 DMT57550
         MVC   NJHGJNAM,TAGINVM    Job name                    SML2NJE4 DMT57560
         MVC   NJHGUSID,TAGINVM    Job userid                  SML2NJE4 DMT57570
         MVC   NJHGETS,TAGINTOD    File date / time            SML2NJE4 DMT57580
         MVC   NJHGORGN,TAGINLOC   Originating node            SML2NJE4 DMT57590
         MVC   NJHGORGR,TAGINVM    Originating userid          SML2NJE4 DMT57600
*        The following two are TAGTOLOC and TAGTOVM for SYSIN  SML2NJE4 DMT57610
         MVC   NJHGXEQN,TAGINLOC   Execution node              SML2NJE4 DMT57620
         MVC   NJHGXEQU,TAGINVM    Execution userid            SML2NJE4 DMT57630
*        The following two are TAGINLOC and TAGINVM for SYSIN  SML2NJE4 DMT57640
         MVC   NJHGPRTN,TAGTOLOC   PRT file destination node   SML2NJE4 DMT57650
         MVC   NJHGPRTR,TAGTOVM    PRT file destination userid SML2NJE4 DMT57660
*        The following two are TAGINLOC and TAGINVM for SYSIN  SML2NJE4 DMT57670
         MVC   NJHGPUNN,TAGTOLOC   PUN file destination node   SML2NJE4 DMT57680
         MVC   NJHGPUNR,TAGTOVM    PUN file destination userid SML2NJE4 DMT57690
         MVC   NJHGPRGN(8),TAGINVM Start of programmer field   SML2NJE4 DMT57700
         MVC   NJHGPRGN+8(12),=CL12' ' End of programmer field SML2NJE4 DMT57710
         MVC   NJHGROOM,TAGDIST    Distribution code           SML2NJE4 DMT57720
         MVC   NJHGBLDG,BLANK      Building                    SML2NJE4 DMT57730
         MVC   NJHGNREC,TAGRECNM   Record count (SYSOUT only)  SML2NJE4 DMT57740
         B     XJE3XIT             Return to caller               *XJE  DMT57750
         DROP  R4                  Finished with job header    SML2NJE4 DMT57760
         DROP  R8                  Finished with file tag      SML2NJE4 DMT57770
*                                                              SML2NJE4 DMT57780
*        BLDNJEDS - Build NJE dataset header for outgoing file SML2NJE4 DMT57790
*                                                              SML2NJE4 DMT57800
*        On entry, R8 should contain the file tag.             SML2NJE4 DMT57810
*        R4 is modified without saving.                        SML2NJE4 DMT57820
*        Base registers R9/R10/R12 are used to address            *XJE  DMT57830
*        various items.                                        SML2NJE4 DMT57840
*                                                              SML2NJE4 DMT57850
BLDNJEDS DS    0H                                              SML2NJE4 DMT57860
         USING TAG,R8                                          SML2NJE4 DMT57870
         MVI   RCTTSRC1,X'E0'      SRCB for NJE data set hdr   SML2NJE4 DMT57880
         MVC   RCTTCT1,=AL2(NDHSIZE) Data set segment length   SML2NJE4 DMT57890
         LA    R4,RCTTDTA1         NJE header buffer address   SML2NJE4 DMT57900
         USING NJEPDSEC,R4         Tell assembler to use it    SML2NJE4 DMT57910
         XC    NJEPDSEC(NDHSIZE),NJEPDSEC Zero whole segment   SML2NJE4 DMT57920
         MVC   NJEPLEN,=AL2(NDHSIZE) Length of ds hdr segment  SML2NJE4 DMT57930
         LA    R4,NJEPSIZE(,R4)    Skip over segment prefix    SML2NJE4 DMT57940
         USING NDHGDSEC,R4         Ds header general section   SML2NJE4 DMT57950
         MVC   NDHGLEN,=AL2(NDHGSIZE) Ds hdr gen. sect. length SML2NJE4 DMT57960
         MVC   NDHGNODE,TAGTOLOC   Destination node            SML2NJE4 DMT57970
         MVC   NDHGRMT,TAGTOVM     Destination userid          SML2NJE4 DMT57980
         MVC   NDHGPROC,TAGNAME    Filename (1st 8 characters) SML2NJE4 DMT57990
         MVC   NDHGSTEP,TAGTYPE    Filetype (1st 8 characters) SML2NJE4 DMT58000
         MVC   NDHGDD,BLANK        DDNAME                      SML2NJE4 DMT58010
         MVC   NDHGCLAS,TAGCLASS   Sysout class                SML2NJE4 DMT58020
         MVC   NDHGNREC,TAGRECNM   Record count                SML2NJE4 DMT58030
         MVC   NDHGLREC,TAGRECLN   Record length               SML2NJE4 DMT58040
         MVC   NDHGDSCT,TAGCOPY+1  Copies                      SML2NJE4 DMT58050
         MVC   NDHGFORM,BLANK      Form                        SML2NJE4 DMT58060
         MVC   NDHGFCB,BLANK       FCB                         SML2NJE4 DMT58070
         MVC   NDHGUCS,BLANK       UCS                         SML2NJE4 DMT58080
         MVC   NDHGXWTR,BLANK      External writer             SML2NJE4 DMT58090
         MVC   NDHGNAME,BLANK      Data set name qualifier     SML2NJE4 DMT58100
         TM    TAGINDEV,TYPPUN     Are we punching?            SML2NJE4 DMT58110
         BNO   NJEDPRT             Skip over punch only stuff. SML2NJE4 DMT58120
         MVI   NDHGRCFM,X'80'      Record format fixed, nocc   SML2NJE4 DMT58130
         MVI   NDHGFLG2,X'40'      Flag as PUN file            SML2NJE4 DMT58140
         B     NJEDPUN             Skip over print only stuff. SML2NJE4 DMT58150
NJEDPRT  EQU   *                                               SML2NJE4 DMT58160
         MVI   NDHGRCFM,X'42'      Record format variable, cc  SML2NJE4 DMT58170
         MVI   NDHGFLG2,X'80'      Flag as PRT file            SML2NJE4 DMT58180
NJEDPUN  EQU   *                                               SML2NJE4 DMT58190
         DROP  R4                  Finished with gen sect. hdr SML2NJE4 DMT58200
*                                                              SML2NJE4 DMT58210
         LA    R4,NDHGSIZE(,R4)    Skip over general section   SML2NJE4 DMT58220
         USING NDHVDSEC,R4         Data set header RSCS sect.  SML2NJE4 DMT58230
         MVC   NDHVLEN(2),=AL2(NDHVSIZE) Ds RSCS sect. length  SML2NJE4 DMT58240
         MVI   NDHVTYPE,X'87'      RSCS section identifier     SML2NJE4 DMT58250
         MVC   NDHVCLAS,TAGCLASS   Spool file class            SML2NJE4 DMT58260
         MVC   NDHVIDEV,TAGINDEV   CP device type code         SML2NJE4 DMT58270
         MVC   NDHVDIST,TAGDIST    Distribution code           SML2NJE4 DMT58280
         MVC   NDHVFNAM,TAGNAME    Filename                    SML2NJE4 DMT58290
         MVC   NDHVFTYP,TAGTYPE    Filetype                    SML2NJE4 DMT58300
         MVI   NDHVPRIO+1,50       Transmission priority       SML2NJE4 DMT58310
         MVI   NDHVVRSN,X'01'      RSCS version 1              SML2NJE4 DMT58320
         MVI   NDHVRELN,X'07'      RSCS release 7              SML2NJE4 DMT58330
         B     XJE3XIT             Return to caller               *XJE  DMT58340
         DROP  R4                  Finished with RSCS section  SML2NJE4 DMT58350
         DROP  R8                  Finished with file tag      SML2NJE4 DMT58360
*                                                              SML2NJE4 DMT58370
*        BLDNJEJT - Build NJE job trailer for outgoing file    SML2NJE4 DMT58380
*                                                              SML2NJE4 DMT58390
*        On entry, R8 should contain the file tag.             SML2NJE4 DMT58400
*        R4 is modified without saving.                        SML2NJE4 DMT58410
*        Base registers R9/R10/R12 are used to address            *XJE  DMT58420
*        various items.                                        SML2NJE4 DMT58430
*                                                              SML2NJE4 DMT58440
BLDNJEJT DS    0H                                              SML2NJE4 DMT58450
         USING TAG,R8                                          SML2NJE4 DMT58460
         MVI   RCTTSRC1,X'D0'      SRCB for NJE job trailer    SML2NJE4 DMT58470
         MVC   RCTTCT1,=AL2(NJTSIZE) Job trailer segment len.  SML2NJE4 DMT58480
         LA    R4,RCTTDTA1         NJE header buffer address   SML2NJE4 DMT58490
         USING NJEPDSEC,R4         Tell assembler to use it    SML2NJE4 DMT58500
         XC    NJEPDSEC(NJTSIZE),NJEPDSEC Zero whole segment   SML2NJE4 DMT58510
         MVC   NJEPLEN,=AL2(NJTSIZE) Job trailer segment len.  SML2NJE4 DMT58520
         LA    R4,NJEPSIZE(,R4)    Skip over segment prefix    SML2NJE4 DMT58530
         USING NJTGDSEC,R4         Job trailer general section SML2NJE4 DMT58540
         MVC   NJTGLEN,=AL2(NJTGSIZE) Length of general sect.  SML2NJE4 DMT58550
         MVI   NJTGXCLS,C'A'       Execution class             SML2NJE4 DMT58560
         TM    TAGINDEV,TYPPUN     Are we punching?            SML2NJE4 DMT58570
         BO    NJETPUN             Yes. Skip print only stuff. SML2NJE4 DMT58580
         MVC   NJTGALIN,TAGRECNM   Record count                SML2NJE4 DMT58590
         B     NJETPRT             Skip over punch only stuff. SML2NJE4 DMT58600
NJETPUN  EQU   *                                               SML2NJE4 DMT58610
         MVC   NJTGACRD,TAGRECNM   Record count                SML2NJE4 DMT58620
NJETPRT  EQU   *                                               SML2NJE4 DMT58630
         MVI   NJTGIXPR,X'07'      Initial execution priority  SML2NJE4 DMT58640
         MVI   NJTGAXPR,X'07'      Actual execution priority   SML2NJE4 DMT58650
         MVI   NJTGIOPR,X'07'      Actual output priority      SML2NJE4 DMT58660
         MVI   NJTGAOPR,X'07'      Actual output priority      SML2NJE4 DMT58670
         B     XJE3XIT             Return to caller               *XJE  DMT58680
         DROP  R4                  Finished with job trailer   SML2NJE4 DMT58690
         DROP  R8                  Finished with file tag      SML2NJE4 DMT58700
         DROP  R10                 DMTXJEB                        *XJE  DMT58710
*                                                                       DMT58720
XJE3XIT  EQU   *                                                        DMT58730
         LM    R0,R15,XJE3SAVE     Restore caller's regs          *XJE  DMT58740
         BR    R14                 Return to caller               *XJE  DMT58750
*                                                              SML2NJE4 DMT58760
         LTORG                                                 SML2NJE4 DMT58770
*                        CONTROL CHARACTERS                             DMT58780
         SPACE 2                                                        DMT58790
XSOH     EQU   X'01'               START OF HEADING                     DMT58800
XSTX     EQU   X'02'               START OF TEXT                        DMT58810
XETX     EQU   X'03'               END OF TEXT                          DMT58820
XDLE     EQU   X'10'               DATA LINK ESCAPE                     DMT58830
XETB     EQU   X'26'               END OF TEXT BLOCK                    DMT58840
XENQ     EQU   X'2D'               ENQUIRY                              DMT58850
XSYN     EQU   X'32'               SYNCHRONIZATION                      DMT58860
XEOT     EQU   X'37'               LOST BLOCK ALARM                     DMT58870
XNAK     EQU   X'3D'               NEGATIVE ACKNOWLEDGEMENT             DMT58880
XACK1    EQU   X'61'               POSITIVE ACKNOWLEDGEMENT-CONDITIONAL DMT58890
XACK0    EQU   X'70'               POSITIVE ACKNOWLEDGEMENT             DMT58900
XLDR     EQU   XDLE                TRANSPARENT HEADER                   DMT58910
XTRL     EQU   XDLE                TRANSPARENT TRAILER                  DMT58920
XCHN     EQU   X'60'               TRANSPARENT CCW CHAINING BITS        DMT58930
         SPACE 2                                                        DMT58940
*                        BLOCK CONTROL BYTE INDICATORS                  DMT58950
         SPACE 2                                                        DMT58960
BCBIGNRE EQU   X'10'               IGNORE BLOCK COUNT INDICATOR         DMT58970
BCBRESET EQU   X'20'               RESET BLOCK COUNT INDICATOR          DMT58980
*                                                                       DMT58990
         EJECT                                                          DMT59020
*                                                                       DMT59030
********************                                                    DMT59040
*                  *   Contains certain structures and variables        DMT59050
* CSECT DMTXJEA    *   that were scattered all over the original        DMT59060
*                  *   line driver and consolidated here and is         DMT59070
********************   addressable by a single base register.           DMT59080
*                                                                       DMT59090
DMTXJEA  CSECT                                                          DMT59100
         USING DMTXJE1,R12,R11,R10 Addresability for labels       *XJE  DMT59110
*                                   used in instructions below.   *XJE  DMT59120
*
XJESAVE  DS    18F                 OS-style save area             *XJE
*                                                                       DMT59130
BUFMAXCT DC    F'5'                MAX LENGTH OF BUFFER FIELD           DMT59140
BUFFCNT  DC    H'0'                COUNT OF BUFFER FIELD                DMT59150
         CNOP  6,8                                                      DMT59160
$CCOM1   BALR  R7,0                ENTRY FROM COMMUTATOR TO PROCESSOR   DMT59170
$TCT1    DS    0H                  ORIGIN OF TASK CONTROL TABLE         DMT59180
CTCT     DS    0H                                                       DMT59190
$CTLTCT  EQU   *                                                        DMT59200
CCTSTRT  B     $CRTN1              B TO PROPER PROCESSOR ENTRY          DMT59210
CCTENTY  EQU   *-2                 ADR PORTION ***MODIFIED BY PROCE     DMT59220
CCTRTN   B     $CCOMM1+4           B TO NEXT PROCESSOR VIA COMMUTA      DMT59230
CCTCCW   DC    X'0'                CCW FOR DEVICE OP-CODE               DMT59240
CCTDATA  DC    AL3(0)              ADDRESS OF DATA TRANSFERRED          DMT59250
CCTFLAG  DC    X'20'               FLAGS ON CCW                         DMT59260
CCTOPCOD DC    X'00'               SAVE AREA FOR CCW OP-CODE            DMT59270
CCTCCWCT DC    AL2(80)             CCW COUNT OF DATA TRANSFERRED        DMT59280
CCTECB   DC    X'00'               EVENT CONTROL                        DMT59290
CCTSTAT  DC    X'00'               STATUS FLAGS                         DMT59300
CCTWFB   DC    AL1(0)              WAITING FOR BUFFERS                  DMT59310
CCTSAV1  DC    F'0'                SAVE AREA FOR PROCESSOR ROUTINE      DMT59320
CCTNEXT  DC    A($TCT2)            NEXT TCT IN CHAIN                    DMT59330
CCTFCS   DC    X'0000'             FUNCTION CONTROL SEQUENCE MASK       DMT59340
CCTRCBR  DC    X'80'               RECV RECORD CONTROL BLOCK            DMT59350
CCTRCBT  DC    X'00'               TRANS RECORD CONTROL BLOCK           DMT59360
CCTCOM   DC    A($CCOMM1)          POINTER BACK TO COMMUTATOR           DMT59370
CDEVSYNC DC    F'0'                SYNCH LOCK                           DMT59380
CDEVREQN DC    CL4'AXS '           FILE ACCESS NAME                     DMT59390
CDEVREQ  DC    A(*+8)              REQUEST BUFFER ADDRESS               DMT59400
CDEVRESP DC    AL1(19),AL3(*+3)    RESPONSE BUFFER                      DMT59410
CDEVRLEN DC    AL1(0)              REQUEST LENGTH                       DMT59420
CDEVFUN  DC    AL1(0)              REQUEST FUNCTION                     DMT59430
CDEVRESV DC    AL1(0)              RESERVED BYTE                        DMT59440
CDEVSOPT DC    AL1(0)              SUB OPTION BYTE                      DMT59450
CDEVTAG  DC    A(0)                TAG ADDRESS                          DMT59460
CDEVFIOA DC    A(0)                FILE I/O AREA                        DMT59470
CDEVLINK DC    CL8' '              LINK NAME                            DMT59480
CSW1     DC    AL1(0)              DEVICE SWITCH 1                      DMT59490
CSW2     DC    AL1(0)              DEVICE SWITCH 2                      DMT59500
CSW3     DC    AL1(0)              DEVICE SWITCH 3                      DMT59510
CSW4     DC    AL1(0)              DEVICE SWITCH 4                      DMT59520
CCTTOVM  DC    CL8' '              VM OUTPUT DESTINATION                DMT59530
*                                                                       DMT59540
*        NORMAL DEVICE ECTENTION                                        DMT59550
*                                                                       DMT59560
CCTTANK  DC    A(0)                NEXT TANK TO OUTPUT                  DMT59570
CCTBUFER DC    A(0)                ADDR OF CURRENT BUFFER               DMT59580
*                                                                       DMT59590
*              TNKLM,TNKCT AND BUFLM,BUFCT MUST APPEAR IN SEQ AND STRT  DMT59600
*                                  ON HALF WORD BOUNDARIES              DMT59610
CCTTNKLM DC    AL1(15)             MAX NUM OF TANKS ASSIGNABLE TO       DMT59620
CCTTNKCT DC    AL1(0)              CURRENT NUM ASSIGNED                 DMT59630
CCTBUFLM DC    AL1(5)              MAX NUM OF BUFFERS ASSIGNABLE        DMT59640
CCTBUFCT DC    AL1(0)              CURRENT NUM ASSIGNED                 DMT59650
*                                                                       DMT59660
         CNOP  6,8                                                      DMT59670
$WCOM1   BALR  R7,0                ENTRY FROM COMMUTATOR TO PROCESSOR   DMT59680
$TCT2    DS    0H                  ORIGIN OF TASK CONTROL TABLE         DMT59690
WTCT     DS    0H                                                       DMT59700
$CONTCT  EQU   *                                                        DMT59710
WCTSTRT  B     $WRTN1              B TO PROPER PROCESSOR ENTRY          DMT59720
WCTENTY  EQU   *-2                 ADR PORTION ***MODIFIED BY PROCE     DMT59730
WCTRTN   B     $WCOMM1+4           B TO NEXT PROCESSOR VIA COMMUTA      DMT59740
WCTCCW   DC    X'0'                CCW FOR DEVICE OP-CODE               DMT59750
WCTDATA  DC    AL3(0)              ADDRESS OF DATA TRANSFERRED          DMT59760
WCTFLAG  DC    X'20'               FLAGS ON CCW                         DMT59770
WCTOPCOD DC    X'00'               SAVE AREA FOR CCW OP-CODE            DMT59780
WCTCCWCT DC    AL2(80)             CCW COUNT OF DATA TRANSFERRED        DMT59790
WCTECB   DC    X'00'               EVENT CONTROL                        DMT59800
WCTSTAT  DC    X'10'               STATUS FLAGS                         DMT59810
WCTWFB   DC    AL1(0)              WAITING FOR BUFFERS                  DMT59820
WCTSAV1  DC    F'0'                SAVE AREA FOR PROCESSOR ROUTINE      DMT59830
WCTNEXT  DC    A($TCT3)            NEXT TCT IN CHAIN                    DMT59840
WCTFCS   DC    X'0040'             FUNCTION CONTROL SEQUENCE MASK       DMT59850
WCTRCBR  DC    X'9A'               Recv record control block            DMT59860
WCTRCBT  DC    X'00'               TRANS RECORD CONTROL BLOCK           DMT59870
WCTCOM   DC    A($WCOMM1)          POINTER BACK TO COMMUTATOR           DMT59880
WDEVSYNC DC    F'0'                SYNCH LOCK                           DMT59890
WDEVREQN DC    CL4'AXS '           FILE ACCESS NAME                     DMT59900
WDEVREQ  DC    A(*+8)              REQUEST BUFFER ADDRESS               DMT59910
WDEVRESP DC    AL1(19),AL3(*+3)    RESPONSE BUFFER                      DMT59920
WDEVRLEN DC    AL1(0)              REQUEST LENGTH                       DMT59930
WDEVFUN  DC    AL1(0)              REQUEST FUNCTION                     DMT59940
WDEVRESV DC    AL1(0)              RESERVED BYTE                        DMT59950
WDEVSOPT DC    AL1(0)              SUB OPTION BYTE                      DMT59960
WDEVTAG  DC    A(0)                TAG ADDRESS                          DMT59970
WDEVFIOA DC    A(0)                FILE I/O AREA                        DMT59980
WDEVLINK DC    CL8' '              LINK NAME                            DMT59990
WSW1     DC    AL1(0)              DEVICE SWITCH 1                      DMT60000
WSW2     DC    AL1(0)              DEVICE SWITCH 2                      DMT60010
WSW3     DC    AL1(0)              DEVICE SWITCH 3                      DMT60020
WSW4     DC    AL1(0)              DEVICE SWITCH 4                      DMT60030
WCTTOVM  DC    CL8' '              VM OUTPUT DESTINATION                DMT60040
*                                                                       DMT60050
*        NORMAL DEVICE EWTENTION                                        DMT60060
*                                                                       DMT60070
WCTTANK  DC    A(0)                NEXT TANK TO OUTPUT                  DMT60080
WCTBUFER DC    A(0)                ADDR OF CURRENT BUFFER               DMT60090
*                                                                       DMT60100
*              TNKLM,TNKCT AND BUFLM,BUFCT MUST APPEAR IN SEQ AND STRT  DMT60110
*                                  ON HALF WORD BOUNDARIES              DMT60120
WCTTNKLM DC    AL1(13)             MAX NUM OF TANKS ASSIGNABLE TO       DMT60130
WCTTNKCT DC    AL1(0)              CURRENT NUM ASSIGNED                 DMT60140
WCTBUFLM DC    AL1(3)              MAX NUM OF BUFFERS ASSIGNABLE        DMT60150
WCTBUFCT DC    AL1(0)              CURRENT NUM ASSIGNED                 DMT60160
         EJECT                                                          DMT60170
*                                                                       DMT60180
*        TANK EXTENTIONS FOR READER AND CONSOLE PROCESSORS              DMT60190
*                                                                       DMT60200
WCTTANK1 DC    A(0)                TANKCHN AND WORK AREA ONE            DMT60210
WCTTRCB1 DC    X'9A'               RCB identification for NMR  SML2NJE4 DMT60220
WCTTSRC1 DC    X'80'               SRCB identification         SML2NJE4 DMT60230
WCTTCT1  DC    H'0'                Number of data characters   SML2NJE4 DMT60240
*                                                              SML2NJE4 DMT60250
WCTTNMR1 DC    XL30'00'            NMR header                  SML2NJE4 DMT60260
WCTTDTA1 DC    CL148' '            NMRMSG message or command   SML2NJE4 DMT60270
         DC    CL4' '              Used for compress workspace?SML2NJE4 DMT60280
*                                                                       DMT60290
         CNOP  6,8                                                      DMT60300
$PCOM1   BALR  R7,0                ENTRY FROM COMMUTATOR TO PROCESSOR   DMT60310
$TCT3    DS    0H                  ORIGIN OF TASK CONTROL TABLE         DMT60320
PTCT     DS    0H                                                       DMT60330
PCTSTRT  B     $PRTN1              B TO PROPER PROCESSOR ENTRY          DMT60340
PCTENTY  EQU   *-2                 ADR PORTION ***MODIFIED BY PROCE     DMT60350
PCTRTN   B     $PCOMM1+4           B TO NEXT PROCESSOR VIA COMMUTA      DMT60360
PCTCCW   DC    X'0'                CCW FOR DEVICE OP-CODE               DMT60370
PCTDATA  DC    AL3(0)              ADDRESS OF DATA TRANSFERRED          DMT60380
PCTFLAG  DC    X'20'               FLAGS ON CCW                         DMT60390
PCTOPCOD DC    X'01'               SAVE AREA FOR CCW OP-CODE            DMT60400
PCTCCWCT DC    AL2(80)             CCW COUNT OF DATA TRANSFERRED        DMT60410
PCTECB   DC    X'00'               EVENT CONTROL                        DMT60420
PCTSTAT  DC    X'08'               STATUS FLAGS                         DMT60430
PCTWFB   DC    AL1(0)              WAITING FOR BUFFERS                  DMT60440
PCTSAV1  DC    F'0'                SAVE AREA FOR PROCESSOR ROUTINE      DMT60450
PCTNEXT  DC    A($TCT4)            NEXT TCT IN CHAIN                    DMT60460
PCTFCS   DC    X'0001'             FCS mask for this processor SML2NJE4 DMT60470
PCTRCBR  DC    X'99'               Receive RCB for stream 1    SML2NJE4 DMT60480
PCTRCBT  DC    X'00'               TRANS RECORD CONTROL BLOCK           DMT60490
PCTCOM   DC    A($PCOMM1)          POINTER BACK TO COMMUTATOR           DMT60500
PDEVSYNC DC    F'0'                SYNCH LOCK                           DMT60510
PDEVREQN DC    CL4'AXS '           FILE ACCESS NAME                     DMT60520
PDEVREQ  DC    A(*+8)              REQUEST BUFFER ADDRESS               DMT60530
PDEVRESP DC    AL1(19),AL3(*+3)    RESPONSE BUFFER                      DMT60540
PDEVRLEN DC    AL1(19)             REQUEST LENGTH                       DMT60550
PDEVFUN  DC    AL1(0)              REQUEST FUNCTION                     DMT60560
PDEVRESV DC    AL1(0)              RESERVED BYTE                        DMT60570
PDEVSOPT DC    AL1(0)              SUB OPTION BYTE                      DMT60580
APDEVTAG DC    A(PDEVTAG)          Tag address                 SML2NJE4 DMT60590
PDEVFIOA DC    A(0)                FILE I/O AREA                        DMT60600
PDEVLINK DC    CL8' '              LINK NAME                            DMT60610
PSW1     DC    AL1(0)              DEVICE SWITCH 1                      DMT60620
PSW2     DC    AL1(0)              DEVICE SWITCH 2                      DMT60630
PSW3     DC    AL1(0)              DEVICE SWITCH 3                      DMT60640
PSW4     DC    AL1(0)              DEVICE SWITCH 4                      DMT60650
PCTTOVM  DC    CL8' '              VM OUTPUT DESTINATION                DMT60660
*                                                                       DMT60670
*        NORMAL DEVICE EPTENTION                                        DMT60680
*                                                                       DMT60690
PCTTANK  DC    A(0)                NEXT TANK TO OUTPUT                  DMT60700
PCTBUFER DC    A(0)                ADDR OF CURRENT BUFFER               DMT60710
*                                                                       DMT60720
*              TNKLM,TNKCT AND BUFLM,BUFCT MUST APPEAR IN SEQ AND STRT  DMT60730
*                                  ON HALF WORD BOUNDARIES              DMT60740
PCTTNKLM DC    AL1(1)              MAX NUM OF TANKS ASSIGNABLE TO       DMT60750
PCTTNKCT DC    AL1(0)              CURRENT NUM ASSIGNED                 DMT60760
PCTBUFLM DC    AL1(2)              MAX NUM OF BUFFERS ASSIGNABLE        DMT60770
PCTBUFCT DC    AL1(0)              CURRENT NUM ASSIGNED                 DMT60780
*                                                              SML2NJE4 DMT60790
*        Added variable locations used to process NJE headers  SML2NJE4 DMT60800
*                                                              SML2NJE4 DMT60810
APNJEHDR DC    A(PNJEHEAD)         Start address of NJE headersSML2NJE4 DMT60820
APNJEDTA DC    A(0)                Address of NJE data set hdr SML2NJE4 DMT60830
APNJETRL DC    A(0)                Address of NJE job trailer  SML2NJE4 DMT60840
APNJEHND DC    A(PNJEHEND)         End address of NJE headers  SML2NJE4 DMT60850
PNJEBPTR DC    A(0)                NJE headers buffer pointer  SML2NJE4 DMT60860
PNRECLEN DC    H'0'                Record length of SYSOUT dev SML2NJE4 DMT60870
PNSEGNUM DC    X'FF'               Expected NJE segment number SML2NJE4 DMT60880
PNSEGTYP DC    X'70'               Expected NJE segment type   SML2NJE4 DMT60890
*                                                                       DMT60900
         CNOP  6,8                                                      DMT60910
$RCOM1   BALR  R7,0                ENTRY FROM COMMUTATOR TO PROCESSOR   DMT60920
$TCT4    DS    0H                  ORIGIN OF TASK CONTROL TABLE         DMT60930
RTCT     DS    0H                                                       DMT60940
RCTSTRT  B     $RRTN1              B TO PROPER PROCESSOR ENTRY          DMT60950
RCTENTY  EQU   *-2                 ADR PORTION ***MODIFIED BY PROCE     DMT60960
RCTRTN   B     $RCOMM1+4           B TO NEXT PROCESSOR VIA COMMUTA      DMT60970
RCTCCW   DC    X'0'                CCW FOR DEVICE OP-CODE               DMT60980
RCTDATA  DC    AL3(0)              ADDRESS OF DATA TRANSFERRED          DMT60990
RCTFLAG  DC    X'20'               FLAGS ON CCW                         DMT61000
RCTOPCOD DC    X'00'               SAVE AREA FOR CCW OP-CODE            DMT61010
RCTCCWCT DC    AL2(80)             CCW COUNT OF DATA TRANSFERRED        DMT61020
RCTECB   DC    X'00'               EVENT CONTROL                        DMT61030
RCTSTAT  DC    X'00'               STATUS FLAGS                         DMT61040
RCTWFB   DC    AL1(0)              WAITING FOR BUFFERS                  DMT61050
RCTSAV1  DC    F'0'                SAVE AREA FOR PROCESSOR ROUTINE      DMT61060
RCTNEXT  DC    A($TCT6)            Next TCT in chain           SML2NJE4 DMT61070
RCTFCS   DC    X'0800'             FUNCTION CONTROL SEQUENCE MASK       DMT61080
RCTRCBR  DC    X'FF'               RECV RECORD CONTROL BLOCK            DMT61090
RCTRCBT  DC    X'99'               Transmit RCB for stream 1   SML2NJE4 DMT61100
RCTCOM   DC    A($RCOMM1)          POINTER BACK TO COMMUTATOR           DMT61110
RDEVSYNC DC    F'0'                SYNCH LOCK                           DMT61120
RDEVREQN DC    CL4'AXS '           FILE ACCESS NAME                     DMT61130
RDEVREQ  DC    A(*+8)              REQUEST BUFFER ADDRESS               DMT61140
RDEVRESP DC    AL1(19),AL3(*+3)    RESPONSE BUFFER                      DMT61150
RDEVRLEN DC    AL1(0)              REQUEST LENGTH                       DMT61160
RDEVFUN  DC    AL1(0)              REQUEST FUNCTION                     DMT61170
RDEVRESV DC    AL1(0)              RESERVED BYTE                        DMT61180
RDEVSOPT DC    AL1(0)              SUB OPTION BYTE                      DMT61190
RDEVTAG  DC    A(0)                TAG ADDRESS                          DMT61200
RDEVFIOA DC    A(0)                FILE I/O AREA                        DMT61210
RDEVLINK DC    CL8' '              LINK NAME                            DMT61220
RSW1     DC    AL1(0)              DEVICE SWITCH 1                      DMT61230
RSW2     DC    AL1(0)              DEVICE SWITCH 2                      DMT61240
RSW3     DC    AL1(0)              DEVICE SWITCH 3                      DMT61250
RSW4     DC    AL1(0)              DEVICE SWITCH 4                      DMT61260
RCTTOVM  DC    CL8' '              VM OUTPUT DESTINATION                DMT61270
*                                                                       DMT61280
*        TANK ERTENTIONS FOR READER AND CONSOLE PROCESSORS              DMT61290
*                                                                       DMT61300
RCTTANK1 DC    A(0)                TANKCHN AND WORK AREA ONE            DMT61310
RCTTRCB1 DC    X'99'               Transmit RCB for stream 1   SML2NJE4 DMT61320
RCTTSRC1 DC    X'80'               SRCB IDENTIFICATION                  DMT61330
RCTTCT1  DC    H'80'               NUMBER OF DATA CHARACTERS            DMT61340
RCTTDTA1 DC    CL136' '                                                 DMT61350
         DC    CL64' '             Bigger tank for NJE headers SML2NJE4 DMT61360
*                                                              SML2NJE4 DMT61370
*        Added variable locations used to decode NJE headers   SML2NJE4 DMT61380
*                                                              SML2NJE4 DMT61390
ARNJEHDR DC    A(RNJEHEAD)         Start address of NJE headersSML2NJE4 DMT61400
ARNJEDTA DC    A(0)                Address of NJE data set hdr SML2NJE4 DMT61410
ARNJETRL DC    A(0)                Address of NJE job trailer  SML2NJE4 DMT61420
ARNJEHND DC    A(RNJEHEND)         End address of NJE headers  SML2NJE4 DMT61430
RNSAVE   DS    4F                  Save area across $PUT call  SML2NJE4 DMT61440
RNSEGNUM DS    X                   Current NJE segment number  SML2NJE4 DMT61450
*                                                                       DMT61460
         CNOP  6,8                                                      DMT61470
$JCOM1   BALR  R7,0                ENTRY FROM COMMUTATOR TO PROCESSOR   DMT61480
$TCT6    DS    0H                  ORIGIN OF TASK CONTROL TABLE         DMT61490
JTCT     DS    0H                                                       DMT61500
JCTSTRT  B     $JRTN1              B TO PROPER PROCESSOR ENTRY          DMT61510
JCTENTY  EQU   *-2                 ADR PORTION ***MODIFIED BY PROCE     DMT61520
JCTRTN   B     $JCOMM1+4           B TO NEXT PROCESSOR VIA COMMUTA      DMT61530
JCTCCW   DC    X'0'                CCW FOR DEVICE OP-CODE               DMT61540
JCTDATA  DC    AL3(0)              ADDRESS OF DATA TRANSFERRED          DMT61550
JCTFLAG  DC    X'20'               FLAGS ON CCW                         DMT61560
JCTOPCOD DC    X'41'               SAVE AREA FOR CCW OP-CODE            DMT61570
JCTCCWCT DC    AL2(80)             CCW COUNT OF DATA TRANSFERRED        DMT61580
JCTECB   DC    X'00'               EVENT CONTROL                        DMT61590
JCTSTAT  DC    X'00'               STATUS FLAGS                         DMT61600
JCTWFB   DC    AL1(0)              WAITING FOR BUFFERS                  DMT61610
JCTSAV1  DC    F'0'                SAVE AREA FOR PROCESSOR ROUTINE      DMT61620
JCTNEXT  DC    A(0)                NEXT TCT IN CHAIN                    DMT61630
JCTFCS   DC    X'0800'             FUNCTION CONTROL SEQUENCE MASK       DMT61640
JCTRCBR  DC    X'93'               RECV RECORD CONTROL BLOCK            DMT61650
JCTRCBT  DC    X'00'               TRANS RECORD CONTROL BLOCK           DMT61660
JCTCOM   DC    A($JCOMM1)          POINTER BACK TO COMMUTATOR           DMT61670
JDEVSYNC DC    F'0'                SYNCH LOCK                           DMT61680
JDEVREQN DC    CL4'AXS '           FILE ACCESS NAME                     DMT61690
JDEVREQ  DC    A(*+8)              REQUEST BUFFER ADDRESS               DMT61700
JDEVRESP DC    AL1(19),AL3(*+3)    RESPONSE BUFFER                      DMT61710
JDEVRLEN DC    AL1(19)             REQUEST LENGTH                       DMT61720
JDEVFUN  DC    AL1(0)              REQUEST FUNCTION                     DMT61730
JDEVRESV DC    AL1(0)              RESERVED BYTE                        DMT61740
JDEVSOPT DC    AL1(0)              SUB OPTION BYTE                      DMT61750
AJDEVTAG DC    A(JDEVTAG)          Tag address                 SML2NJE4 DMT61760
JDEVFIOA DC    A(0)                FILE I/O AREA                        DMT61770
JDEVLINK DC    CL8' '              LINK NAME                            DMT61780
JSW1     DC    AL1(0)              DEVICE SWITCH 1                      DMT61790
JSW2     DC    AL1(0)              DEVICE SWITCH 2                      DMT61800
JSW3     DC    AL1(0)              DEVICE SWITCH 3                      DMT61810
JSW4     DC    AL1(0)              DEVICE SWITCH 4                      DMT61820
JCTTOVM  DC    CL8' '              VM OUTPUT DESTINATION                DMT61830
*                                                                       DMT61840
*        NORMAL DEVICE EXTENTION                                        DMT61850
*                                                                       DMT61860
JCTTANK  DC    A(0)                NEXT TANK TO OUTPUT                  DMT61870
JCTBUFER DC    A(0)                ADDR OF CURRENT BUFFER               DMT61880
*                                                                       DMT61890
*              TNKLM,TNKCT AND BUFLM,BUFCT MUST APPEAR IN SEQ AND STRT  DMT61900
*                                  ON HALF WORD BOUNDARIES              DMT61910
JCTTNKLM DC    AL1(2)         MAX NUM OF TANKS ASSIGNABLE TO   @VA04612 DMT61920
JCTTNKCT DC    AL1(0)              CURRENT NUM ASSIGNED                 DMT61930
JCTBUFLM DC    AL1(2)              MAX NUM OF BUFFERS ASSIGNABLE        DMT61940
JCTBUFCT DC    AL1(0)              CURRENT NUM ASSIGNED                 DMT61950
*                                                              SML2NJE4 DMT61960
*        Added variable locations used to decode NJE headers   SML2NJE4 DMT61970
*                                                              SML2NJE4 DMT61980
AJNJEHDR DC    A(JNJEHEAD)         Start address of NJE headersSML2NJE4 DMT61990
AJNJEDTA DC    A(0)                Address of NJE data set hdr SML2NJE4 DMT62000
AJNJETRL DC    A(0)                Address of NJE job trailer  SML2NJE4 DMT62010
AJNJEHND DC    A(JNJEHEND)         End address of NJE headers  SML2NJE4 DMT62020
JNJEBPTR DC    A(0)                NJE headers buffer pointer  SML2NJE4 DMT62030
JRECLEN  DC    H'0'                Record length of SYSIN dev  SML2NJE4 DMT62040
JNSEGNUM DC    X'00'               Expected NJE segment number SML2NJE4 DMT62050
JNSEGTYP DC    X'00'               Expected NJE segment type   SML2NJE4 DMT62060
*                                                                       DMT62070
*                                                                       DMT62080
INTFAKE  DC    AL4($START)         FAKE ENTRY POINT                     DMT62090
INITWAIT DC    A(ADAECB)                                                DMT62100
CECBA    DC    X'80',AL3(CMDECB)   WAIT LIST FOR INIT                   DMT62110
*                                                                       DMT62120
         DS    0D                  *                                    DMT62130
INITCCW  CCW   X'2F',INITCCW+5,CC+SILI,1 DISABLE  (CHANGED TO SENSE)    DMT62140
INITCCWS CCW   X'23',ISETMODE,CC+SILI,1 SET MODE (CHANGED TO A NOP)     DMT62150
INITENA  CCW   X'27',0,CC+SILI,1   ENABLE                               DMT62160
INITCCWR CCW   1,INITSEQ,CC+SILI,2 Write initial sequence      SML2NJE4 DMT62170
INITCCRD CCW   2,IREADRES,SILI,2   Read answer from remote     SML2NJE4 DMT62180
INITSEQ  DC    AL1(XSOH,XENQ)      Initial seq sent by primary SML2NJE4 DMT62190
IREADRES DC    AL2(0)              Response chars from remote  SML2NJE4 DMT62200
IPRISEQ  DC    AL1(XSOH,XENQ)      Expected reply from primary SML2NJE4 DMT62210
ISECRES  DC    AL1(XDLE,XACK0)     Expected rply from secondarySML2NJE4 DMT62220
IALTSEQ  DC    AL1(XDLE,XNAK)      Expected rply from undecidedSML2NJE4 DMT62230
IREADSKP CCW   2,0,CC+SILI+SKIP,65000 Read to clear data lost  SML2NJE4 DMT62240
ISETMODE DC    X'00'               SET MODE BYTE                        DMT62250
         EJECT                                                          DMT62260
*---------------------------------------------------------------------* DMT62270
*                                                                     * DMT62280
*                  TP BUFFER POOL                                     * DMT62290
*                                                                     * DMT62300
*---------------------------------------------------------------------* DMT62310
         SPACE 1                                                        DMT62320
BUFLN1   DC    A(0)                BUFFER LENGTH                        DMT62330
BUFLN2   DC    A(0)                DOUBLE BUFFER LENGTH                 DMT62340
TNKLN1   DC    A(TANKEND-TANKCHN)  TANK LENGTH                          DMT62350
TNKLN2   DC    A(2*(TANKEND-TANKCHN)) DOUBLE LENGTH                     DMT62360
BUFZEROS DC    F'0'                FW OF ZERO FOR CHAINING              DMT62370
BONE     DC    F'1'                FW OF ONE                            DMT62380
BNUMBUFS DC    F'4'                NUMBER OF TP BUFFERS                 DMT62390
TPBUFSIZ DC    F'4060'  1012       Default TP buffer size          *XJE DMT62400
TNUMBUFS DC    F'15'               NUMBER OF TANKS                      DMT62410
*                                                              SML2NJE4 DMT62420
BUFSPAGE DC    F'0'                Page allocated for TP buffs SML2NJE4 DMT62430
TANKPAGE DC    F'0'                Page allocated for tanks    SML2NJE4 DMT62440
         EJECT                                                 SML2NJE4 DMT62450
*---------------------------------------------------------------------* DMT62460
*                                                                     * DMT62470
*                XJEINIT -- Initialization routine             HRC000DT DMT62480
*                    for  D M T X J E  under RSCS              HRC000DT DMT62490
*                                                                     * DMT62500
*---------------------------------------------------------------------* DMT62510
         SPACE 1                                                        DMT62520
PASSMAX  DC    F'8'                Max password length         SML2NJE4 DMT62530
REXNAME  DC    CL4'REX '           MAIN TASK NAME                       DMT62540
AXSNAME  DC    CL4'AXS '           FILE ACCESS MANAGER TASK NAME        DMT62550
XJELINK  DC    A(0)                XJE link table entry        HRC000DT DMT62560
XJELINE  DC    CL8' '              EBCDIC line address         HRC000DT DMT62570
         SPACE 1                                                        DMT62580
PASSWORD DC    CL17' '             USERID/PASSWORD             @VM01162 DMT62590
BUFFER   DC    CL8' '              BUFFER SIZE                          DMT62600
MINBUF   DC    F'300'              Minimum size of a TP buffer SML2NJE4 DMT62610
MAXBUF   DC    F'4060'   1012      Maximum TP buffer length        *XJE DMT62620
         SPACE 1                                                        DMT62630
XJESYS   DC    X'00'               XJE driver status bits      HRC000DT DMT62640
*        Bits defined in XJESYS                                HRC000DT DMT62650
SECONDRY EQU   X'80'               Secondary remote system typ SML2NJE4 DMT62660
PRIMARY  EQU   X'10'               Primary remote system type  SML2NJE4 DMT62670
RESPEND  EQU   X'04'               Secondary response pending  SML2NJE4 DMT62680
PRIMONLY EQU   X'01'               Primary remote system only  SML2NJE4 DMT62690
SGNONREC EQU   X'08'               SIGNON HAS BEEN RECEIVED OR SENT     DMT62700
         SPACE 1                                                        DMT62710
MASTERSW DC    X'00'               PROCESSOR ACTIVE SWITCH              DMT62720
*        BITS DEFINED IN MASTERSW                                       DMT62730
READER   EQU   X'80'               READER ACTIVE                        DMT62740
SYSOUT   EQU   X'40'               SYSOUT PRT/PUN device open  SML2NJE4 DMT62750
JOB      EQU   X'10'               JOB PUNCH ACTIVE                     DMT62760
         SPACE                                                          DMT62770
INITSAV  DS    3F                  TEMP SAVE AREA                       DMT62780
         DS    0F                                                       DMT62790
MSGECB   DC    F'0'                MSG SYNCH LOCK                       DMT62800
CMDECB   DC    F'0'                CMD SYNCH LOCK                       DMT62810
CMDRESP  DC    CL132' '            CMD RESPOSE BUFFER                   DMT62820
         DC    CL16' '             More command element buffer HRC016DT DMT62830
CMDINPGS DC    X'00'               COMMAND IN PROGRESS SWITCH           DMT62840
COMSAVE  DC    18F'0'              COMMON ROUTINE SAVE AREA             DMT62850
ASYNSAVE DC    18F'0'              Dedicated ASYNEXIT savearea SML2NJE4 DMT62860
ECBLIST  DC    A(RDEVSYNC)         SYNCH LOCK LIST                      DMT62870
UACON    DC    X'40',AL3(0)        PUNCH SYNCH LOCK                     DMT62880
JACON    DC    X'40',AL3(0)        JOB PUNCH SYNCH LOCK                 DMT62890
LOKCMDA  DC    A(CMDECB)           COMMAND SYNCH LOCK                   DMT62900
LOKMSGA  DC    A(MSGECB)           MSGS QUEUED SYNCH LOCK               DMT62910
PACON    DC    X'40',AL3(0)        PRINT SYNCH LOCK                     DMT62920
         DC    X'80'               INDICATE LAST IN LIST                DMT62930
LOKADAA  DC    AL3(ADAECB)         ADAPTER SYNCH LOCK                   DMT62940
         SPACE                                                          DMT62950
KRSAV    DC    4F'0'               SAVE AREA                            DMT62960
*                                                                       DMT62970
*                  BEGINNING OF QUEUE CHAINS                            DMT62980
*                                                                       DMT62990
$TEMP    DC    H'0'                GLOBAL TEMPORARY WORK                DMT63000
$BUFPOOL DC    A(0)                BUFFER POOL CHAIN CONTROL WORD       DMT63010
$TANKPOL DC    A(0)                TANK QUEUE CONTROL WORD              DMT63020
$INBUF   DC    A(0)                RECEIVED BUFFER CHAIN CTL WORD       DMT63030
$OUTBUF  DC    A(0)                XMISSION BUFFER CHAIN CTL WORD       DMT63040
$FCSOUT  DS    0H                  OUTGOING FUNCTION CONTROL SEQUENCE   DMT63050
         DC    X'8FCF'             ALL FUNCTIONS PERMITTED              DMT63060
$FCSIN   DC    X'8FCF'             INCOMING FCS                         DMT63070
         SPACE 2                                                        DMT63080
MTANK    DC    A(0)                TANK REG STORAGE                     DMT63090
$USRCMDC DC    H'0'           NUM OF USER COMMANDS             @VA04612 DMT63100
*                                                                       DMT63110
TAGCMD   DC    C'TAG DEV XXX '     TAG COMMAND                          DMT63120
TAGDATA  DC    CL70' '             DATA FIELD                           DMT63130
TAGCMDL  EQU   *-TAGCMD            LENGTH OF TAG COMMAND                DMT63140
*                                                                       DMT63150
VMDESAVE DS    0F                  REGISTER SAVE AREAS            *XJE  DMT63160
XJE2SAVE DS    16F                                                *XJE  DMT63170
XJE3SAVE DS    16F                                                *XJE  DMT63180
*                                                                       DMT63190
AXSLINK  DC    CL8' '              REM LOC LINKID TO BE FILLED IN BY IN DMT63200
AXSCVD   DC    D'0'                TEMP AREA FOR CVD OPERATIONS         DMT63210
AXSFILE  DC    CL4' '              FILE ID                              DMT63220
         DC    CL4' '                                                   DMT63230
AXSRECS  DC    CL8' '              NUM OF RECORDS                       DMT63240
BLANK    DC    CL8' '              MSG FILLER                           DMT63250
LOCATION DC    CL8' '              LOCAL LOCATION                       DMT63260
SYSTYPE  DC    CL8' '              REMOTE SYSTEM TYPE          @VM01105 DMT63270
*                                                                       DMT63280
VMSPANCH DS    F                   CCW ANCHOR                           DMT63290
VMSPNEXT DS    F                   NEXT CCW                             DMT63300
VMSPNUM  DS    F                   NUMBER OF DATA RECORDS IN 4K BUFFER  DMT63310
HDRLINE  EQU   *                   PRINT LINE AND SPACE THREE COMMAND   DMT63320
HDRSGTOP EQU   *                                                        DMT63330
HDRORGID DC    8C'Y'               FILE ORIGIN LOC ID TO BE FILLED IN   DMT63340
         DC    4C' '               FOUR BLANKS                          DMT63350
HDRVMID  DC    8C'X'               FILE ORIGIN VM ID TO BE FILLED IN    DMT63360
         DC    3C' '               THREE MORE BLANKS                    DMT63370
HDRTOD   DC    C' '                BEGINNING OF FIELD TO BE EDITED      DMT63380
         DC    C'XX/XX/XX'         FILE ORIGIN DATE FROM TOD ROUTINE    DMT63390
         DC    4C' '               FOUR MORE BLANKS                     DMT63400
         DC    C'YY:YY:YY'         FILE ORIGIN TIME FROM TOD ROUTINE    DMT63410
         DC    2C' '               TWO MORE BLANKS                      DMT63420
         DC    6C' '          SIX MORE BLANKS                  @VA03113 DMT63430
         DC    C'  WAS THE ORIGIN' ENDING NOTE                          DMT63440
HDRSGLEN EQU   (*-HDRSGTOP)        END OF THE SEGMENT DATA FIELD        DMT63450
HDRCHAR  DC    (80-HDRSGLEN)C' '                                        DMT63460
HDRLEN   EQU   (*-HDRLINE)         END OF HEADER LINE RECORD            DMT63470
         SPACE                                                          DMT63480
TODMASK  DC    AL1(MASKLEN-1)      LENGTH OF REMAINING MASK FIELD       DMT63490
         DC    X'2120',C'/',X'2020',C'/',X'2020' DATE MASK              DMT63500
         DC    3C' '               THREE BLANKS                         DMT63510
         DC    X'22'               RESET SIGNIFICANCE INDICATOR         DMT63520
         DC    X'2120',C':',X'2020',C':',X'2020' TIME MASK              DMT63530
         DC    2C' '          2 BLANKS TO SEP ENDING NOTE      @VA03113 DMT63540
MASKLEN  EQU   (*-TODMASK)         END OF EDIT MASK                     DMT63550
         SPACE                                                          DMT63560
MMDDYYHH DC    D'0'                TO  HOLD NEW HOUR CALCULATION IN DEC DMT63570
         DC    D'0'                FOR APPENDING MMDDYYHH TO MMSSMMMM   DMT63580
MMSSMMMM DC    D'0'                TO RECEIVE DECIMAL MINUTE AND SECOND DMT63590
DAYNUMBR DC    A(0)                TO RECEIVE COMPUTED DAY OF WEEK 0->6 DMT63600
TODEBCON DC    F'-1',A(0+4,TIMEZON+4) SEE BELOW                         DMT63610
*        DC    F'-1' TO HOLD LAST CALCULATION ELAPSED HOURS             DMT63620
*        DC    A(0+4) SWITCH, USED AS AN INDEX, FOR STD VS. DLT TIME    DMT63630
*        DC    A(TIMEZON+4) EXTERNAL ADDRESS OF TIMEZONE DISP TABLE     DMT63640
TODSAVE  DC    11F'0'              TODEBCD ROUTINE SAVE AREA            DMT63650
         SPACE                                                          DMT63660
TODSAVE1 DC    2F'0'               SAVE AREA                            DMT63670
         SPACE                                                          DMT63680
TIMEZON  DC    Y(0),CL6'      ' DONT CONVERT TIME ZONE         @VA03113 DMT63690
         DC    Y(0),CL6'      ' ITS CORRECT AS IT IS           @VA03113 DMT63700
         SPACE 1                                                        DMT63710
WTOMCMD  DC    F'0'                SYNCH LOCK                           DMT63720
         DC    CL4'REX '           COMMAND EXECUTATOR                   DMT63730
WCMDA    DC    A(WTOMBUF)          REQUEST BUFFER                       DMT63740
         DC    A(0)                NO RESPONSE REQUESTED                DMT63750
         SPACE 1                                                        DMT63760
WTOMBUF  DC    AL1(0),X'00',AL2(0) LENGTH,FUNCTION,ZERO                 DMT63770
WTOMNODE DC    CL8' '              Source node of incoming cmd HRC016DT DMT63780
WTOMUSER DC    CL8' '              Source user of incoming cmd HRC016DT DMT63790
WTOBUF   DC    CL120' '            CONSOLE OUTPUT BUFFER                DMT63800
         SPACE 1                                                        DMT63810
WTORJMSG DC    AL2(170),AL2(0)     NUMBER PLUS SPARE                    DMT63820
         DC    CL8' '              LINKID                               DMT63830
WTORJBUF DC    CL120' '            MSG BUFFER                           DMT63840
WACN1    DC    S(WINIT)            RETURN ENTRY POINT                   DMT63850
CMDCMDSV DS    F                   RETURN SAVE                          DMT63860
CMDCVD   DC    D'0'                CONVERT AREA                         DMT63870
CMDFID   DC    CL4' '              COMMAND SPOOLID AREA                 DMT63880
         DC    CL4' '                                                   DMT63890
*                                                                       DMT63900
RDRCMD   DC    X'00'               READER COMMAND BYTE                  DMT63910
*        BITS DEFINED IN RDRCMD                                         DMT63920
RBACKFIL EQU   X'80'               BACKSPACE FILE                       DMT63930
RBACKCNT EQU   X'40'               BACKSPACE COUNT                      DMT63940
RFWDCNT  EQU   X'20'               FORWARD SPACE COUNT                  DMT63950
RFLSHCPY EQU   X'10'               FLUSH COPY                           DMT63960
RFLSHALL EQU   X'08'               FLUSH ALL COPIES                     DMT63970
RFLSHOLD EQU   X'04'               FLUSH AND HOLD                       DMT63980
RHLDIPGS EQU   X'02'               HOLD IN PROGRESS                     DMT63990
         SPACE                                                          DMT64000
HOLD     EQU   X'80'               SUB OPTION ON CLOSE INPUT REQ        DMT64010
ALL      EQU   X'40'               SUB OPTION ON CLOSE INPUT REQ        DMT64020
MULTOPEN EQU   X'80'               SUB OPTION ON OPEN OUTPUT REQ        DMT64030
         SPACE                                                          DMT64040
RDRCMDCT DC    F'0'                FILE SPACE COUNT                     DMT64050
RDRCMDID DC    H'0'                CMD INDICATED SPOOLID                DMT64060
RDRCMDLK DC    CL8' '              CMD RESPONSE LINKID                  DMT64070
HLDCMDLK DC    CL8' '              CMD RESPONSE LINKID                  DMT64080
         DS    0F                                                       DMT64090
MSGREQ   DC    F'0'                SYNCH LOCK                           DMT64100
         DC    CL4'REX '           TASK NAME                            DMT64110
MREQA    DC    A(MSGBLK)           REQUEST BUFFER                       DMT64120
         DC    A(0)                NO RESPONSE                          DMT64130
         SPACE 1                                                        DMT64140
MSGBLK   DC    AL1(0),AL1(2),AL1(0),AL1(0) LENGTH,FUNCTION,ROUTE,SEV    DMT64150
MSGLINK  DC    8X'00'              LINKID                               DMT64160
MSGVMID  DC    CL8' '              VIRTUAL MACHINE ID                   DMT64170
         DC    CL3'XJE',CL1' '     Module ID plus action code  HRC000DT DMT64180
MSGBUF   DC    CL120' '            MSG BUFFER                           DMT64190
         SPACE                                                          DMT64200
MSGSAVE  DC    5F'0'               SAVE AREA                            DMT64210
         EJECT                                                          DMT64220
*---------------------------------------------------------------------* DMT64230
*                                                                     * DMT64240
*                     $TPPUT STORAGE                                  * DMT64250
*                                                                     * DMT64260
*---------------------------------------------------------------------* DMT64270
AXSAVE   DS    F                   AXS SAVE AREA                        DMT64280
         SPACE 1                                                        DMT64290
OSAVR6   DC    A(0)                REG SAVE                             DMT64300
OSAVR5   DC    A(0)                REG SAVE                             DMT64310
OSAVR14  DC    A(0)                RETURN ADDR SAVE                     DMT64320
OINADD   DC    A(0)                INPUT TANK ADDR                      DMT64330
OINEND   DC    A(0)                LAST VALID DATA BYTE IN TANK         DMT64340
OACTBUF  DC    A(0)                ACTIVE BUFFER ADDR                   DMT64350
OBUFPTR  DC    A(0)                CURRENT POINTER IN BUFFER            DMT64360
OBUFCNT  DC    H'0'                REMAING SPACE COUNT IN BUFFER        DMT64370
OTEMP    DS    CL64           COMPRESSION WORK AREA            @VA04175 DMT64380
*                                  DUMMY TANK                           DMT64390
TTANK    DC    A(0)                CHAIN                                DMT64400
         DC    X'90'               RCB FOR FUNCTION CTL RECORD          DMT64410
         DC    X'00'               USER'S SRCB (FUNCTION TYPE)          DMT64420
         DC    H'0'                TANK COUNT                           DMT64430
TSAVA    DC    A(0)                SAVE AREA                            DMT64440
TSAVB    DC    A(0)                SAVE AREA                            DMT64450
TANKCON  DC    A(TTANK)            CONSTANT                             DMT64460
         SPACE                                                          DMT64470
IOERRSV  DS    4F                  SAVE AREA                            DMT64480
IOERRMSG DC    AL2(70),AL2(0)      MSG NUMBER AND SPARE                 DMT64490
IOERRLNE DC    CL8' '              LINE ADDR                            DMT64500
IERRSIO  DC    CL8' '              ADAPTER SIO COND CODE                DMT64510
IERRCSW1 DC    CL8' '              ADAPTER CSW                          DMT64520
IERRCSW2 DC    CL8' '              PART 2 OF CSW                        DMT64530
IERRSENS DC    CL8' '              ADAPTER SENSE BYTE                   DMT64540
IERRCCW1 DC    CL8'00000000'       ADAPTER FAILING CCW                  DMT64550
IERRCCW2 DC    CL8'00000000'       PART 2 OF CCW                        DMT64560
IOERMSGL EQU   *-IOERRMSG          LENGTH OF ERROR MSG                  DMT64570
         DC    CL1' '              GARBAGE BYTE                         DMT64580
         SPACE                                                          DMT64590
TRCVD    DS    D                   CVD AREA                             DMT64600
TRSAVE   DS    4F                  SAVE AREA                            DMT64610
         SPACE                                                          DMT64620
TRMSG    DC    AL2(149),AL2(0)     NUMBER PLUS SPARE                    DMT64630
TRLINK   DC    CL8' '              LINKID                               DMT64640
TRMTRN   DC    CL8' '              TRANSACTION COUNT                    DMT64650
TRMERR   DC    CL8' '              ERROR COUNT                          DMT64660
TRMTO    DC    CL8' '              TIMEOUT COUNT                        DMT64670
TRMSGL   EQU   *-TRMSG             LENGTH OF MSG                        DMT64680
         SPACE                                                          DMT64690
TRASHLD  DC    F'60'               THRESHOLD LEVEL FOR MSG              DMT64700
ERRSHLD  DC    F'20'               THRESHOLD LEVEL FOR MSG              DMT64710
*                                                                       DMT64720
KSAV     DC    6F'0'               SAVE AREA                            DMT64730
KCCW     DC    XL8'0'         SAVED CCW                        @VA04353 DMT64740
MVCBLANK MVC   1(0,R1),0(R1)  EXECUTED MVC                     @VA04353 DMT64750
IOLINE   DC    CL120' '            LOG PRINT LINE                       DMT64760
R        DC    C'R'                READ                                 DMT64770
W        DC    C'W'                WRITE                                DMT64780
         SPACE 1                                                        DMT64790
$LOGSW   DC    X'00'               LOG SWITCH                           DMT64800
*        BITS DEFINED IN $LOGSW                                         DMT64810
LOGON    EQU   X'80'               LOGING SET ON                        DMT64820
LOGOPEN  EQU   X'40'               LOG DEVICE OPEN                      DMT64830
         SPACE 1                                                        DMT64840
         DS    0F                                                       DMT64850
LOGBLK   DC    F'0'                SYNCH LOCK                           DMT64860
         DC    CL4'AXS '           FILE ACCESS TASK NAME                DMT64870
LOGREQA  DC    A(LOGGREQ)          REQUEST BUFFER ADDRESS               DMT64880
LOGREQG  DC    AL1(19),AL3(LOGGREQ) RESPONSE BUFFER ADDRESS             DMT64890
LOGGREQ  DC    AL1(19,0,0,0)       LENGTH,FUNCTION,SPARE,SUBCODE        DMT64900
ALDEVTAG DC    A(LDEVTAG)          Log tag address             SML2NJE4 DMT64910
LOGFIOA  DC    A(0)                FILE I/O AREA ADDRESS                DMT64920
         DC    CL8' '              LINK ID                              DMT64930
         SPACE 1                                                        DMT64940
         DS    0D                                                       DMT64950
LOGCCW   CCW   X'09',IOLINE,SILI,120 WRITE AND SPACE 1                  DMT64960
LOGHDCCW CCW   X'19',LOGHDLNE,SILI,LOGHDRLN WRITE AND SPACE 3           DMT64970
         SPACE 1                                                        DMT64980
LOGHDLNE DC    CL3' '                                                   DMT64990
         DC    C'D M T X J E   LINE TRANSACTION LOG FOR LINK ' HRC000DT DMT65000
LOGLINK  DC    CL8' '                                                   DMT65010
         DC    C' ON '                                                  DMT65020
LOGDTIME DC    CL17' '                                                  DMT65030
LOGHDRLN EQU   *-LOGHDLNE          LENGTH OF HDR LINE                   DMT65040
         DS    0D                                                       DMT65050
LOGTIME  DC    CL32' '             DIAG BUFFER                          DMT65060
CLOSESAV DS    F                   Save area for return addr   SML2NJE4 DMT65070
*                                                                       DMT65080
TERMBLK  DC    F'0',CL4'REX ',A(TERMREQ),A(0) GIVE REQUEST BLOCK        DMT65090
         SPACE 1                                                        DMT65100
TERMREQ  DC    AL1(1),X'03'        LENGTH,FUNCTION                      DMT65110
LONGWAIT DC    F'0'                LONG WAIT SYNCH LOCK                 DMT65120
*                                                                       DMT65130
CBUFFER  DC    A(0)                ACTIVE COMUNICATIONS BUFFER          DMT65140
CFCSOUT  DC    X'8FCF'        LAST FCS TRANSMITTED             @VA04174 DMT65150
CFCSSTD  DC    X'88C1'        STANDARD FCS                     @VA03425 DMT65160
CFCSTEMP DC    AL2(0)         FCS COMPARE AREA                 @VA03301 DMT65170
CTEMP    DC    H'0'                TEMPORARY STORAGE                    DMT65180
CMAXDUP  DC    H'3'                MAX REPEATED BLOCKS                  DMT65190
         DC    AL1(0)              FIRST BYTE OF HALF-WORD              DMT65200
CBCBCNTO DC    AL1(X'80')          BLOCK CHECK COUNT OUT                DMT65210
         DC    AL1(0)              SPACER                               DMT65220
CBCBCNTI DC    AL1(X'80')          BLOCK COUNT CHARACTER EXPECTED       DMT65230
         DC    H'0'                *                                    DMT65240
CBUFLAST DC    10X'00'             SAVE OF START OF LAST BUFFER         DMT65250
CRESP    DC    AL1(0)              RESPONSE CHARACTER RECEIVED          DMT65260
CREGS    DS    3F                  REGISTER SAVE AREA                   DMT65270
         SPACE 1                                                        DMT65280
CRETREGS DS    3F                  SAVE AREA                            DMT65290
$COMEXIT DC    A($START)           COMSUP INITIAL ENTRY POINT           DMT65300
         SPACE 1                                                        DMT65310
CBCB     DC    X'00'               LAST BCB SENT                        DMT65320
CSETBCB  DC    X'00'               HERE TOO..FOR RESET                  DMT65330
         SPACE 1                                                        DMT65340
         DS    0F                  FORCE FULL-WORD ALIGNMENT            DMT65350
CCSW     DC    XL8'00'             TEMP STORAGE FOR CSW                 DMT65360
COLDRCB  DC    X'00'               LAST RCB SENT                        DMT65370
CUNITCMD DC    X'00'               COMMAND CODE STORAGE                 DMT65380
         SPACE 1                                                        DMT65390
CLASTCAW DC    F'0'                CCW ADDR SAVE                        DMT65400
         SPACE 2                                                        DMT65410
BUFSYNSW DC    X'00'               BUFFER SYNCHRONIZATION SWITCH        DMT65420
*        BITS DEFINED IN BUFSYNSW                                       DMT65430
$TPPNONE EQU   X'80'               STOP ALL BUFFERING                   DMT65440
OFLSW    EQU   X'40'               FLUSH BUFFER                         DMT65450
GDQBUFS  EQU   X'20'               STOP DEQUEUING BUFFERS               DMT65460
$COMBUSY EQU   X'10'               COMMUNICATIONS INACTIVE              DMT65470
CUWFAKE  EQU   X'08'               DUMMY READ ON FOR UE RECOVERY        DMT65480
CACKSW   EQU   X'04'               ACK RECEIVED                         DMT65490
*                                                                       DMT65500
ADAECB   DC    F'0'                SYNCH LOCK                           DMT65510
ADACUU   DC    X'0000',AL1(1),AL1(TYP2700)                              DMT65520
ADCCWA   DC    A(CCTCCW)           ADAPTER CCW ADDR                     DMT65530
ADASIOCC EQU   *                   SIO CONDITION CODE                   DMT65540
ADACSW   DC    2F'0'               ADAPTER ENDING CSW                   DMT65550
ADASENSE DC    F'0'                ADAPTER SENSE BYTE                   DMT65560
         SPACE 3                                                        DMT65570
ADSAV    DC    8F'0'               $SIO REGISTER SAVE AREA              DMT65580
RDCOUNT  DC    H'0'           READ BUFFER SIZE                 @VA07451 DMT65590
DUMCOUNT DC    H'0010'                 MAX BUFFER FOR RD COUNT @VA08578 DMT65600
*
WERRCODE DS    AL2                 Error code                  SML2NJE4 DMT27650
         DS    AL2(0)              Spare bytes                 SML2NJE4
WERRLINK DS    CL8                 Link name subject of error  SML2NJE4 DMT27670
*                                                                       DMT65610
*                        CONTROL SEQUENCES                              DMT65620
XSTXSEQ  DC    AL1(XLDR,XSTX)      START-OF-TEXT SEQUENCE               DMT65630
XETBSEQ  DC    AL1(XTRL,XETB)      END-OF-TEXT-BLOCK SEQUENCE           DMT65640
XACKSEQ  DC    AL1(XDLE,XACK0)     POSITIVE ACKNOWLEDGEMENT SEQUENCE    DMT65650
XNAKSEQ  DC    AL1(XSYN,XNAK)      NEGATIVE ACKNOWLEDGEMENT SEQUENCE    DMT65660
XSYNSEQ  DC    AL1(XSYN,XSYN,XSYN,XSYN) SYNCHRONIZATION SEQUENC@VA03340 DMT65670
         SPACE 2                                                        DMT65680
*                        CHANNEL COMMAND WORDS                          DMT65690
         SPACE 1                                                        DMT65700
*                   NORMAL DATA WRITE WITH RETURN DATA READ             DMT65710
         SPACE 1                                                        DMT65720
CCWS     CCW   1,XSYNSEQ,CD+SILI,4 SYNCHRONIZATION SEQUENCE    @VA03340 DMT65730
CCWA     CCW   1,0,CC+SILI,0       WRITE BUFFER                         DMT65740
CCWB     CCW   1,XETBSEQ,CC+SILI,2 WRITE ENDING SEQUENCE                DMT65750
CCWC     CCW   2,0,SILI,0          READ RETURN DATA                     DMT65760
         SPACE 1                                                        DMT65770
*                   DUMMY READ TO TURN OFF LOST DATA SENSE              DMT65780
         SPACE 1                                                        DMT65790
CCWD     CCW   2,0,SILI+SKIP,65000 NON-READ A BUNCH                     DMT65800
         SPACE 1                                                        DMT65810
*                             DISABLE COMMAND                           DMT65820
CCWOFF   CCW   X'2F',0,SILI,1      DISABLE                              DMT65830
         SPACE 1                                                        DMT65840
WRITE    EQU   X'01'               ADAPTER WRITE COMMAND CODE           DMT65850
READ     EQU   X'02'               ADAPTER READ COMMAND CODE            DMT65860
NOP      EQU   X'03'               ADAPTER NOP COMMAND CODE             DMT65870
SENSE    EQU   X'04'               ADAPTER SENSE COMMAND CODE           DMT65880
SETMODE  EQU   X'23'               Adapter set mode command    SML2NJE4 DMT65890
DISABLE  EQU   X'2F'          ADAPTER DISABLE COMMAND          @VA04353 DMT65900
         SPACE 2                                                        DMT65910
*              PROTOTYPE CTL RECORD TO TELL THAT BLOCKS ARE LOST        DMT65920
         SPACE 1                                                        DMT65930
CLOSTBLK DS    0H                  START                                DMT65940
         DC    AL2(CLOSTEND-CLOSTBS) BUFCOUNT                           DMT65950
         DC    AL1(BUFTEXT)        BUFSTAT                              DMT65960
CLOSTBS  DC    AL1(XLDR,XSTX)      BUFSTART                             DMT65970
CLOSTBCB DC    AL1(X'80'+BCBIGNRE) BUFBCB(RECEIVED BLOCK CT ADDED       DMT65980
CLOSTFCS DC    AL2(0)              FCS                                  DMT65990
         DC    AL1(X'E0')          RCB (CTL REC,TYPE=LOST DATA)         DMT66000
CLSTSRCB DC    AL1(X'80')          SRCB(EXPECTED BLK CT ADDED)          DMT66010
         DC    AL1(0)              SCB (NULL RECORD)                    DMT66020
         DC    AL1(0)              RCB (END OF BLOCK)                   DMT66030
CLOSTEND EQU   *                   END OF PROTOTYPE                     DMT66040
         SPACE 1                                                        DMT66050
CDUMMY   DC    A(0)                NO CHAIN                             DMT66060
         DC    AL2(CDUMEND-CDUMSTRT) COUNT                              DMT66070
         DC    AL1(BUFFAKE)        BUFSTAT                              DMT66080
CDUMSTRT DC    AL1(XLDR,XSTX)      BUFSTART                             DMT66090
         DC    AL1(X'80'+BCBIGNRE) BUFBCB                               DMT66100
         DC    AL2(0)              FCS                                  DMT66110
         DC    AL1(0)              RCB (EOB)                            DMT66120
CDUMEND  EQU   *                   END OF DUMMY BUFFER                  DMT66130
         SPACE 1                                                        DMT66140
CUEFAKE  DC    A(0)                BUFCHAIN                             DMT66150
         DC    AL2(0)              BUFCOUNT                             DMT66160
         DC    AL1(BUFFAKE+BUFUCHEK) BUFFER STATUS                      DMT66170
         DC    CL10' '             DUMMY AREA JUST IN CASE              DMT66180
         SPACE 1                                                        DMT66190
ICTLS    DS    0H                  CONTROL INFO FOR BUFFER              DMT66200
         DC    AL2(ICTLE-*-3)      BUFCOUNT                             DMT66210
         DC    X'00'               BUFSTAT                              DMT66220
         DC    AL1(XLDR,XSTX)      BUFSTART                             DMT66230
         DC    AL1(X'80'+BCBRESET) BUFBCB (RESETS EXPECTED BLOCK CT)    DMT66240
         DC    AL2(0)              FCS                                  DMT66250
ICTLB    EQU   *                                               SML2NJE4 DMT66260
*                                                                       DMT66270
NCCRCB   DC    X'F0'               Path manager RCB            SML2NJE4 DMT66280
NCCSRCB  DC    C'I'                Signon record SRCB          SML2NJE4 DMT66290
NCCIDL   DC    AL1(ICTLE-ICTLB)    Length of signon record     SML2NJE4 DMT66300
NCCINODE DC    CL8' '              Name of this node           SML2NJE4 DMT66310
NCCIQUAL DC    AL1(1)              Member number of the node   SML2NJE4 DMT66320
NCCIEVNT DC    AL4(0)              Not used for signon         SML2NJE4 DMT66330
NCCIREST DC    AL2(0)              Partial node-node resistanceSML2NJE4 DMT66340
NCCIBFSZ DC    AL2(0)              Max transmit buffer size    SML2NJE4 DMT66350
NCCILPAS DC    CL8' '              Line password               SML2NJE4 DMT66360
NCCINPAS DC    CL8' '              Node password               SML2NJE4 DMT66370
NCCIFLG  DC    X'00'               Flags - all zero for signon SML2NJE4 DMT66380
NCCIFEAT DC    XL4'10000000'       Features - NCCIPACK only    SML2NJE4 DMT66390
ICTLE    EQU   *                                                        DMT66400
         SPACE                                                          DMT66410
SGNOFCCW CCW   1,SGNOFDTA,CC+SILI,SGNOFEND-SGNOFDTA Send SO recSML2NJE4 DMT66420
SGNCCWA  CCW   1,SGNOFEND,SILI,2   Send TRL ETB after record   SML2NJE4 DMT66430
SGNOFDTA DS    0H                  Signoff record              SML2NJE4 DMT66440
         DC    AL1(XLDR,XSTX)      Buffer start                SML2NJE4 DMT66450
         DC    AL1(X'80'+BCBIGNRE) Ask partner to ignore BCB   SML2NJE4 DMT66460
         DC    AL2(X'8FCF')        FCS                         SML2NJE4 DMT66470
         DC    X'F0'               General control RCB         SML2NJE4 DMT66480
         DC    C'B'                Signoff SRCB                SML2NJE4 DMT66490
SGNOFEND DC    AL1(XTRL,XETB)      End of transmission block   SML2NJE4 DMT66500
AXSTRTAB DC    C'0123456789ABCDEF' EBCDIC TRANSLATE TABLE               DMT66510
*                                                                       DMT66520
GINBUF   DC    A(0)                INPUT BUFFER ADDR                    DMT66530
GBUFPTR  DC    A(0)                INPUT BUFFER POINTER                 DMT66540
GTANK    DC    A(0)                TANK ADDR                            DMT66550
GAST     DC    A(0)                TEMP STORAGE                         DMT66560
GCTL     DC    H'0'                WORK SPACE 1                         DMT66570
GSCBCK   DC    H'0'           SCB CHECK CHAR                   @VA06382 DMT66580
TOCNT    DC    H'0'           CONSECUTIVE TIMEOUT COUNTER      @VA05950 DMT66590
GSCB     DC    X'00'               WORKING STRING CONTROL BYTE          DMT66600
*                                                                       DMT66610
$START   DS    0H                                                       DMT66620
$CCOMM1  NOP   $CONTROL            CONTROL RECORD PROCESSOR             DMT66630
$TPGETCM NOP   $TPGET              INPUT BUFFER MANAGER                 DMT66640
$PCOMM1  NOP   $PCOM1              ENTRY POINT TO PRINT                 DMT66650
$RCOMM1  NOP   $RCOM1              Entry point to read card    SML2NJE4 DMT66660
$JCOMM1  NOP   $JCOM1              ENTRY TO PUNCH JOB                   DMT66670
$WCOMM1  NOP   $WCOM1              TYPE ON CONSOLE                      DMT66680
$CMDCOM  NOP   CMDPROC             COMMAND INPUT                        DMT66690
$MSGCOM  NOP   MSGPROC             MESSAGE READY                        DMT66700
$COMCOM  NOP   $COMSUP             COMMUNICATIONS SUPERVISOR            DMT66710
         NOP   $INTRUPT            INTERRUPT ADDR                       DMT66720
$COMEND  EQU   *                                                        DMT66730
         B     CMDECK                                                   DMT66740
*                                                                       DMT66750
         DS    0F
MSGXNUM  DC    AL2(0),AL2(0)                                      *XJE  DMT66760
MSGXVAL  DC    5CL8' '                                            *XJE  DMT66770
*                                                                 *XJE
*--replacement svectors                                           *XJE
TLINKS   DC    A(0)                                               *XJE
ASYNREQ  DC    A(0)                                               *XJE
POSTREQ  DC    A(0)                                               *XJE
SPLREQ   DC    A(0) (was TCOM)                                    *XJE
IOREQ    DC    A(0)                                               *XJE
WAITREQ  DC    A(0)                                               *XJE
ALERTREQ DC    A(0)                                               *XJE
GIVEREQ  DC    A(0)                                               *XJE
*--replacement comdsect                                           *XJE
PMSGREQ  DC    A(0)                                               *XJE
GPAGEREQ DC    A(0)                                               *XJE
GLINKREQ DC    A(0)                                               *XJE
GROUTREQ DC    A(0)                                               *XJE
GMSGREQ  DC    A(0)                                               *XJE
GTODEBCD DC    A(0)                                               *XJE
SVLEN    EQU   *-TLINKS                                           *XJE
         DS    0D                  Force doubleword size          *XJE  DMT66780
DMTXJEAZ EQU   *-DMTXJEA           Size of storage area           *XJE  DMT66790
*                                                                       DMT66800
         DS    (4096-DMTXJEAZ)X    Fill space to end of page      *XJE  DMT66810
         DROP  R12,R11,R10                                        *XJE  DMT66820
*                                                                       DMT66830
*                                                                       DMT66840
********************                                                    DMT66850
*                  *   Contains NJE header management work areas.       DMT66860
* CSECT DMTXJEB    *   This csect is only used and referenced by        DMT66870
*                  *   the NJE header management routines in            DMT66880
********************   csect DMTXJE3.                                   DMT66890
*                                                                       DMT66900
* --- For proper relocation of adcons in the csect DMTXJEA above ---    DMT66910
* --- this csect must begin exactly 4096 bytes past the start of ---    DMT66920
* --- csect DMTXJEA.                                             ---    DMT66930
*                                                                       DMT66940
*                                                                 *XJE  DMT66950
DMTXJEB  CSECT                                                          DMT66960
*                        BNMADDRS are offsets into NMRODATA       *XJE  DMT66970
BNMADDRS DC    A(33)     Offset to first place colon might be     *XJE  DMT66980
         DC    A(1)                Loop increment              SML2NJE4 DMT66990
         DC    A(51)     Offset to last place colon might be      *XJE  DMT67000
*                                                                       DMT67010
*        Temporary workspace for constructing NMRs             SML2NJE4 DMT67020
NMROTEMP DS    CL8                 Temporary msg source node   SML2NJE4 DMT67030
*        Tank for constructing outgoing NMRs                   SML2NJE4 DMT67040
NMROTANK DC    A(0)                Address of next tank (none) SML2NJE4 DMT67050
         DC    X'9A'               NMR output tank RCB         SML2NJE4 DMT67060
         DC    X'80'               NMR output tank SRCB        SML2NJE4 DMT67070
         DS    H                   NMR output tank count       SML2NJE4 DMT67080
NMRODATA EQU   *                   NMR output tank data        SML2NJE4 DMT67090
         DS    30X                 NMR output header buffer    SML2NJE4 DMT67100
         DS    CL148               NMR output message buffer   SML2NJE4 DMT67110
         DS    CL4                 Compression routine overflowSML2NJE4 DMT67120
         EJECT                                                 SML2NJE4 DMT67130
*        Device tags moved out of range of base registers      SML2NJE4 DMT67140
         SPACE 1                                               SML2NJE4 DMT67150
PDEVTAG  DS    XL108          SYSOUT PUN / PRT device tag      SML2NJE4 DMT67160
JDEVTAG  DS    XL108          SYSIN PUN device tag             SML2NJE4 DMT67170
LDEVTAG  DS    XL108          Log printer tag                  SML2NJE4 DMT67180
         SPACE 1                                               SML2NJE4 DMT67190
*        Buffer space to decode incoming NJE headers           SML2NJE4 DMT67200
         SPACE 1                                               SML2NJE4 DMT67210
MAXNJEH  EQU   1024                Allow up to 1KB of headers  SML2NJE4 DMT67220
         SPACE 1                                               SML2NJE4 DMT67230
RNJEHEAD DS    XL(MAXNJEH)                                     SML2NJE4 DMT67240
RNJEHEND EQU   *                                               SML2NJE4 DMT67250
PNJEHEAD DS    XL(MAXNJEH)                                     SML2NJE4 DMT67260
PNJEHEND EQU   *                                               SML2NJE4 DMT67270
JNJEHEAD DS    XL(MAXNJEH)                                     SML2NJE4 DMT67280
JNJEHEND EQU   *                                               SML2NJE4 DMT67290
         DS    0D                  Force doubleword size          *XJE  DMT67300
DMTXJEBZ EQU   *-DMTXJEB           Size of storage area           *XJE  DMT67310
*                                                                       DMT67320
*                                                                       DMT67330
********************                                                    DMT67340
*                  *                                                    DMT67350
* RSCS DSECTS      *                                                    DMT67360
*                  *                                                    DMT67370
********************                                                    DMT67380
*                                                                       DMT67390
TCTDSECT DSECT                                                          DMT67400
         SPACE 1                                                        DMT67410
***                     TCT  -  TASK CONTROL TABLE                      DMT67420
*                                                                       DMT67430
*          0   +-----------------------+-----------------------+        DMT67440
*              |        TCTSTRT        |        TCTENTY        |        DMT67450
*          4   +-----------------------+-----------------------+        DMT67460
*              |                    TCTRTN                     |        DMT67470
*          8   +-----------+-----------------------------------+        DMT67480
*              |  TCTCCW   |              TCTDATA              |        DMT67490
*          C   +-----------+-----------+-----------------------+        DMT67500
*              | TCTFLAG   | TCTOPCOD  |     TCTCCWCT          |        DMT67510
*         10   +-----------+-----------+-----------+-----------+        DMT67520
*              |  TCTECB   |  TCTSTAT  |  TCTWFB   |           |        DMT67530
*         14   +-----------+-----------+-----------+-----------+        DMT67540
*              |         TCTFCS        |  TCTRCBR  |  TCTRCBT  |        DMT67550
*         18   +-----------------------+-----------+-----------+        DMT67560
*              |                    TCTCOM                     |        DMT67570
*         1C   +-----------------------------------------------+        DMT67580
*              |                   TDEVSYNC                    |        DMT67590
*         20   +-----------------------------------------------+        DMT67600
*              |                   TDEVREQN                    |        DMT67610
*         24   +-----------------------------------------------+        DMT67620
*              |                   TDEVREQ                     |        DMT67630
*         28   +-----------------------------------------------+        DMT67640
*              |                   TDEVRESP                    |        DMT67650
*         2C   +-----------+-----------+-----------+-----------+        DMT67660
*              | TDEVRLEN  |  TDEVFUN  |  TDEVRESV |  TDEVSOPT |        DMT67670
*         30   +-----------+-----------+-----------+-----------+        DMT67680
*              |                   TDEVTAG                     |        DMT67690
*         34   +-----------------------------------------------+        DMT67700
*              |                   TDEVFIOA                    |        DMT67710
*         38   +-----------------------------------------------+        DMT67720
*              |                   TDEVLINK                    |        DMT67730
*         3C   +-----------+-----------+-----------+-----------+        DMT67740
*              |   TSW1    |   TSW2    |   TSW3    |   TSW4    |        DMT67750
*         40   +-----------+-----------+-----------+-----------+        DMT67760
*              |                                               |        DMT67770
*              |                   TCTTOVM                     |        DMT67780
*              |                                               |        DMT67790
*         48   +-----------------------------------------------+        DMT67800
*              |                   TCTTANK                     |        DMT67810
*         4C   +-----------------------------------------------+        DMT67820
*              |                   TCTBUFER                    |        DMT67830
*         50   +-----------+-----------+-----------+-----------+        DMT67840
*              | TCTTNKLM  |  TCTTNKCT |  TCTBUFLM |  TCTBUFCT |        DMT67850
*         54   +-----------+-----------+-----------+-----------+        DMT67860
*                                                                       DMT67870
***                     TCT  -  TASK CONTROL TABLE                      DMT67880
         SPACE 1                                                        DMT67890
TTCT     DS    0H                                                       DMT67900
TCTSTRT  DS    CL2                 B TO PROPER PROCESSOR ENTRY          DMT67910
TCTENTY  DS    CL2                 ADR PORTION ***MODIFIED BY PROCE     DMT67920
TCTRTN   DS    CL4                 B TO NEXT PROCESSOR VIA COMMUTAT     DMT67930
TCTCCW   DS    CL1                 CCW FOR DEVICE OP-CODE               DMT67940
TCTDATA  DS    AL3                 ADDRESS OF DATA TRANSFERRED          DMT67950
TCTFLAG  DS    CL1                 FLAGS ON CCW                         DMT67960
TCTOPCOD DS    CL1                 SAVE AREA FOR CCW OP-CODE            DMT67970
TCTCCWCT DS    AL2                 CCW COUNT OF DATA TRANSFERRED        DMT67980
TCTECB   DS    CL1                 EVENT CONTROL                        DMT67990
TCTSTAT  DS    CL1                 STATUS FLAGS                         DMT68000
TCTWFB   DS    AL1                 WAITING FOR BUFFERS                  DMT68010
TCTSAV1  DS    1F                  SAVE AREA FOR PROCESSOR ROUTINE      DMT68020
TCTNEXT  DS    1F                  NEXT TCT IN CHAIN                    DMT68030
TCTFCS   DS    AL2                 FUNCTION CONTROL SEQUENCE MASK       DMT68040
TCTRCBR  DS    CL1                 RECV RECORD CONTROL BLOCK            DMT68050
TCTRCBT  DS    CL1                 TRANS RECORD CONTROL BLOCK           DMT68060
TCTCOM   DS    1F                  POINTER BACK TO COMMUTATOR           DMT68070
TDEVSYNC DS    1F                  SYNCH LOCK                           DMT68080
TDEVREQN DS    CL4                 FILE ACCESS NAME                     DMT68090
TDEVREQ  DS    1A                  REQUEST BUFFER ADDRESS               DMT68100
TDEVRESP DS    1A                  RESPONSE BUFFER                      DMT68110
TDEVRLEN DS    AL1                 REQUEST LENGTH                       DMT68120
TDEVFUN  DS    AL1                 REQUEST FUNCTION                     DMT68130
TDEVRESV DS    AL1                 RESERVED BYTE                        DMT68140
TDEVSOPT DS    AL1                 SUB OPTION BYTE                      DMT68150
TDEVTAG  DS    1A                  TAG ADDRESS                          DMT68160
TDEVFIOA DS    1A                  FILE I/O AREA                        DMT68170
TDEVLINK DS    CL8                 LINK NAME                            DMT68180
TSW1     DS    AL1                 DEVICE SWITCH 1                      DMT68190
TSW2     DS    AL1                 DEVICE SWITCH 2                      DMT68200
TSW3     DS    AL1                 DEVICE SWITCH 3                      DMT68210
TSW4     DS    AL1                 DEVICE SWITCH 4                      DMT68220
TCTTOVM  DS    CL8                 VM OUTPUT DESTINATION                DMT68230
*                                                                       DMT68240
*        NORMAL DEVICE EXTENTION                                        DMT68250
*                                                                       DMT68260
TCTTANK  DS    1F                  NEXT TANK TO OUTPUT                  DMT68270
TCTBUFER DS    1F                  ADDR OF CURRENT BUFFER               DMT68280
*                                                                       DMT68290
*              TNKLM,TNKCT AND BUFLM,BUFCT MUST APPEAR IN SEQ AND STRT  DMT68300
*                                  ON HALF WORD BOUNDARIES              DMT68310
TCTTNKLM DS    CL1                 MAX NUM OF TANKS ASSIGNABLE TO       DMT68320
TCTTNKCT DS    CL1                 CURRENT NUM ASSIGNED                 DMT68330
TCTBUFLM DS    CL1                 MAX NUM OF BUFFERS ASSIGNABLE        DMT68340
TCTBUFCT DS    CL1                 CURRENT NUM ASSIGNED                 DMT68350
         EJECT                                                          DMT68360
*                                                                       DMT68370
*        TCTSTAT BIT DEFINITIONS                                        DMT68380
*                                                                       DMT68390
TCT1052  EQU   X'10'               TCT STATUS FLAGS FOR 1052            DMT68400
TCTREL   EQU   X'04'               INTERLOCK RELEASE REQ FOR CONSOLE    DMT68410
TCTOPEN  EQU   X'80'               TCT OPEN BIT                         DMT68420
TCTACT   EQU   X'40'               ACTION REQUIRED ON THIS TCT          DMT68430
         SPACE 2                                                        DMT68440
***      TCTECB BIT DEFINITIONS                                         DMT68450
         SPACE 2                                                        DMT68460
TCTBUSY  EQU   X'10'               DEVICE BUSY BIT                      DMT68470
         EJECT                                                          DMT68480
BUFDSECT DSECT                                                          DMT68490
         SPACE 1                                                        DMT68500
***                 BUFFER  -  TELECOMMUNICATIONS BUFFER                DMT68510
*                                                                       DMT68520
*          0   +-----------------------------------------------+        DMT68530
*              |                   BUFCHAIN                    |        DMT68540
*          4   +-----------------------+-----------------------+        DMT68550
*              |      BUFCOUNT         |  BUFSTAT  | BUFSTART  |        DMT68560
*          8   +-----------+-----------+-----------------------+        DMT68570
*              | BUFSTART  |  BUFBCB   |        BUFFCS         |        DMT68580
*          C   +-----------+-----------+-----------------------+        DMT68590
*              |                                               |        DMT68600
*              |                   BUFDATA                     |        DMT68610
*              |                                               |        DMT68620
*              +-----------------------------------------------+        DMT68630
*                                                                       DMT68640
***                 BUFFER  -  TELECOMMUNICATIONS BUFFER                DMT68650
         SPACE 1                                                        DMT68660
BUFBEGIN DS    0F                  BEGINNING OF THE BUFFER              DMT68670
BUFCHAIN DC    A(0)                BUFFER CHAIN FIELD                   DMT68680
BUFCOUNT DS    1H                  COUNT OF BYTES TO TRANSMIT           DMT68690
BUFSTAT  DS    1C                  BUFFER STATUS BYTE                   DMT68700
BUFSTART DS    CL2                 TRANSMISSION CONTROL BYTES           DMT68710
BUFBCB   DS    1C                  BLOCK CONTROL BYTE                   DMT68720
BUFFCS   DS    CL2                 FUNCTION CONTROL SEQUENCE            DMT68730
BUFDATA  DS    0F                  DATA PORTION OF TP BUFFER            DMT68740
         SPACE 1                                                        DMT68750
*        BUFFER STATUS BIT DEFINITIONS                                  DMT68760
BUFFAKE  EQU   X'01'               DUMMY BUFFER INDICATOR               DMT68770
BUFRESP  EQU   X'02'               RESPONSE ONLY IN BUFFER              DMT68780
BUFNAK   EQU   X'04'               NAK RESPONSE BEING SENT              DMT68790
BUFTEXT  EQU   X'08'               BUFFER CONTAINS TEXT INFORMATION     DMT68800
BUFUCHEK EQU   X'10'               UNIT CHECK EXPECTED                  DMT68810
BUFTONAK EQU   X'20'                   T/O ON RD CCW INDICATOR @VA08636 DMT68820
         EJECT                                                          DMT68830
TANKDSEC DSECT                                                          DMT68840
         SPACE 1                                                        DMT68850
***                     TANKDSECT  -  UNIT RECORD TANK                  DMT68860
*                                                                       DMT68870
*          0   +-----------------------------------------------+        DMT68880
*              |                    TANKCHN                    |        DMT68890
*          4   +-----------+-----------+-----------------------+        DMT68900
*              |  TANKRCB  |  TANKSRCB |      TANKCNT          |        DMT68910
*          8   +-----------+-----------+-----------------------+        DMT68920
*              |                                               |        DMT68930
*              |                   TANKDATA                    |        DMT68940
*              |                                               |        DMT68950
*              +-----------------------------------------------+        DMT68960
*                                                                       DMT68970
***                     TANKDSECT  -  UNIT RECORD TANK                  DMT68980
         SPACE 1                                                        DMT68990
TANKCHN  DC    A(0)                TANK CHAIN FIELD                     DMT69000
TANKRCB  DS    1C                  TANK RECORD CONTROL BYTE             DMT69010
TANKSRCB DS    1C                  TANK SUB-RECORD CONTROL BYTE         DMT69020
TANKCNT  DS    1H                  COUNT OF DATA BYTES IN TANK          DMT69030
TANKDATA DS    CL256               Data area in the tank       SML2NJE4 DMT69040
TANKEND  DS    0F                  FORCE NEXT TO WORD BOUNDARY          DMT69050
*
IOTABLE  DSECT                     I/O TABLE
IOSYNCH  DS    1F                  SYNCH LOCK FOR I/O OPERATIONS
DEVCUU   DS    AL2                 CUU ADDRESS
SENSREQ  DS    AL1                 NUM OF SENSE BYTES REQUESTED
DEVCODE  DS    AL1                 VM/370 DEVICE CODE
PROGADDR DS    1F                  ADDR OF STRT CHANNEL PROGRAM
SIOCOND  EQU   *                   SIO CONDITION CODE
ENDCSW   DS    2F                  ENDING CSW WITH COMPOSITE STATUS
ENDSENSE DS    AL1                 REQUESTED RETURN SENSE INFO
*
*
* Part of CP SPOOL COPY, just for assembly purposes; not used.    *XJE
*                                                                 *XJE
SPLINK   DSECT                                                    *XJE
         DS    1F                                                 *XJE
         DS    1F                                                 *XJE
         DS    1F                                                 *XJE
SPRECNUM DS    1F               NUMBER OF DATA RECORDS IN BUFFER  *XJE
*                                                                 *XJE  DMT69060
********************                                                    DMT69070
*                  *                                                    DMT69080
* CSECT EQUATES    *                                                    DMT69090
*                  *                                                    DMT69100
********************                                                    DMT69110
*                                                                       DMT69120
*                                                                       DMT69130
*-- Equates for calls to csect based routines                     *XJE  DMT69140
*                                                                 *XJE  DMT69150
*-- Routines in csect DMTXJE1:                                    *XJE  DMT69160
XJE1ISIO EQU   0                   XJE2 main entry: init complete *XJE  DMT69170
XJE1ERR1 EQU   4                   Display init error msg 901     *XJE  DMT69180
XJE1ERR2 EQU   8                   Display init error msg 906     *XJE  DMT69190
*                                                                 *XJE  DMT69200
*-- Routines in csect DMTXJE2:                                    *XJE  DMT69210
XJE2AXSG EQU   0                   Try to open reader file        *XJE  DMT69220
XJE2AXSP EQU   4                   Purge spool file               *XJE  DMT69230
XJE2VMDB EQU   8                   Generate default NJE header    *XJE  DMT69240
XJE2TOD  EQU   12                  Build NJE job hdr for out file *XJE  DMT69250
*                                                                 *XJE  DMT69260
*-- Routines in csect DMTXJE3:                                    *XJE  DMT69270
XJE3NMRC EQU   0                   Build NJE NMR hdr for cmd      *XJE  DMT69280
XJE3NMRM EQU   4                   Build NJE NMR hdr for msg      *XJE  DMT69290
XJE3JEHD EQU   8                   Generate default NJE header    *XJE  DMT69300
XJE3JEJH EQU   12                  Build NJE job hdr for out file *XJE  DMT69310
XJE3JEDS EQU   16                  Build NJE dataset hdr out file *XJE  DMT69320
XJE3JEJT EQU   20                  Build NJE job trailer out file *XJE  DMT69330
*                                                                       DMT69340
*                                                                       DMT69350
*-- Other equates (was DEVTYPES)                                  *XJE  DMT69350
TYPPRT   EQU   X'40'               PRT dev                        *XJE
TYPPUN   EQU   X'80'               PUN dev                        *XJE
TYP2700  EQU   X'40'               2700 BISYNC LINE               *XJE
TYP3210  EQU   X'00'               3210 CONSOLE                   *XJE
*                                                                       DMT69360
         EJECT                                                          DMT69370
         COPY  NJE                                             SML2NJE4 DMT69380
         EJECT                                                 SML2NJE4 DMT69390
***      COPY  SVECTORS                                           *XJE  DMT69400
         EJECT                                                          DMT69410
***      COPY  TASKE                                              *XJE  DMT69420
         EJECT                                                          DMT69430
         COPY  LINKTABL                                                 DMT69440
         EJECT                                                          DMT69450
         COPY  RTE                                                *XJE  DMT69460
         EJECT                                                 SML2NJE4 DMT69470
***      COPY  IOTABLE                                            *XJE  DMT69480
         SPACE 1                                                        DMT69490
ECBSKIP  EQU   X'40'               SKIP THIS SYNCH LOCK IN LIST         DMT69500
         EJECT                                                          DMT69510
         COPY  TAG                                                      DMT69520
         EJECT                                                          DMT69530
         COPY  RSSEQU                                                   DMT69540
         EJECT                                                          DMT69550
***      COPY  DEVTYPES                                           *XJE  DMT69560
         EJECT                                                          DMT69570
***      COPY  SPOOL                                              *XJE  DMT69580
         END   DMTXJE                                             *XJE  DMT69590
./ ADD NAME=NJ38RECV
*
*
*-- NJE38 - Retrieve a file from the spool
*
*
*   This program retrieves a file from the NETSPOOL dataset that
*   previously arrived there due to an NJE transmission.
*
*
* Change log:
*
* 29 Nov 20 - Use text-based configuration; alternate routes       v211
* 01 Oct 20 - Put ENQ existence check in common module             v210
* 03 Jun 20 - Support a default userid if no security product.     v130
* 18 May 20 - Support FILE= and NOPURGE JCL PARM options           v120
* 18 May 20 - Incorrect R3 ptr to userid if no ACEE                v120
*
*
*
         REGEQU
NJ38RECV CSECT
         NJEVER
         STM   R14,R12,12(R13)        SAVE CMS REGS
         LR    R12,R15                BASE
         USING NJ38RECV,R12           ADDRESS IT
         LR    R8,R1                  Save parm field addr
*
         GETMAIN RU,                  GET LOCAL STG AREA               X
               LV=NJEXSZ
         LR    R10,R1
         LR    R1,R0                   COPY LENGTH
         LR    R2,R0                   COPY LENGTH
         LR    R0,R10                  -> NEW STG AREA
         SR    R15,R15                 SET PAD
         MVCL  R0,R14                  CLEAR THE PAGE
*
         USING NJEXWK,R10
         ST    R13,NJESA+4             SAVE PRV S.A. ADDR
         LA    R1,NJESA                -> MY SAVE AREA
         ST    R1,8(,R13)              PLUG IT INTO PRIOR SA
         LR    R13,R1
*
INIT000  EQU   *
         MVC   NJEEYE,=CL4'NJEX'       Work area eyecatcher
         ST    R2,NJEWKLEN             Save size of area
         MVC   SYSUT2(DMYUT2L),DMYUT2  Set up DCB
         MVC   SYSPRINT(DMYPRTL),DMYPRT Set up DCB
         MVC   LIST,BLANKS             Init print line
         MVC   LCLNODE,=CL8'????????'  Unknown node name
         MVC   OWNER,=CL8'????????'    File destination userid
         SR    R11,R11                 Init tag data ptr
*
         L     R2,PSAAOLD-PSA(0)       -> my ASCB
         L     R2,ASCBASXB-ASCB(,R2)   -> my ASXB
         ICM   R2,15,ASXBSENV-ASXB(R2) -> my ACEE
         BZ    INIT010                 Use default userid if no ACEE
         LA    R3,ACEEUSR-ACEE(,R2)    -> Userid
         MVC   OWNER,0(R3)             Establish the file owner
         OI    FLAGS1,FL1ACEE          Indicate ACEE was available v130
*
INIT010  EQU   *                                                   v120
         MVC   MACLIST(OPENL),OPEN     Move OPEN list
         OPEN  (SYSPRINT,OUTPUT),      Open the print dataset          X
               MF=(E,MACLIST)
*
         MVC   LIST(L'MSG001),MSG001
         BAL   R14,PUT                 Write the line
         BAL   R14,PUT                 Write blank line
*
         BAL   R14,PARM000             Examine the PARM field      v120
         BNZ   ERR013                  Exit if PARM errors         v120
         CLC   MACLIST(17),BLANKS      Were any options specified? v120
         BE    INIT020                 No                          v120
         MVC   LIST(L'MSG015),MSG015   Options specified           v120
         MVC   LIST+19(17),MACLIST     Write them out              v120
         BAL   R14,PUT                 Write the line              v120
         BAL   R14,PUT                 Write blank line            v120
*
INIT020  EQU   *
         BAL   R2,CHK000               Get NETSPOOL DSN            v210
         BNZ   ERR005                  Can't; NJE38 is not active  v210
         BAL   R14,DYN000              Allocate the NETSPOOL dataset
         BNZ   EXIT08                  Exit if dyn alloc fails
*
*-- Establish owner userid or use default userid if no security    v130
*-- product is installed on the system.                            v130
*
INIT030  EQU   *
         TM    FLAGS1,FL1ACEE          Did we have an ACEE?        v130
         BO    INIT040                 Yes.  Use security userid   v130
         MVC   OWNER,DEFUSER           Else use default userid     v130
*
*-- Open the output file
*
INIT040  EQU   *
         MVC   MACLIST(OPENL),OPEN     Move OPEN list
         LA    R7,SYSUT2               -> DCB
         USING IHADCB,R7
*
         OPEN  (SYSUT2,OUTPUT),        Open the SYSUT1 dataset         X
               MF=(E,MACLIST)
         TM    DCBOFLGS,DCBOFOPN       Is DCB open ok?
         BZ    ERR006                  No
         OI    FLAGS1,FL1OPEN          Indicate DCB is open
*
         TM    DCBRECFM,DCBRECU        Is this a RECFM=U file?
         BO    ERR007                  Unsupported type
         CLC   DCBLRECL,=AL2(133)      LRECL > max supported by NJE?
         BH    ERR008                  Yes
         MVC   UT2LRECL,DCBLRECL       Keep copy of LRECL for SYSUT2
         MVC   DBLE(1),DCBRECFM        Get record format byte
         NI    DBLE,X'06'              Keep only DCBRECCA+DCBRECCM bits
         OC    FLAGS1,DBLE             Keep the bits in our flag bits
         DROP  R7
*
*-- Open NETSPOOL
*
OPN000   EQU   *
         SR    R9,R9                   Init record counter
         LA    R8,NCB1                 -> NCB
         USING NCB,R8
*
         LA    R11,TDATA
         USING TAG,R11
*
         NSIO  TYPE=OPEN,                                              x
               NCB=(R8),                                               x
               TAG=(R11),              -> Where tag data will be       x
               EODAD=EOD000
         LTR   R15,R15                 Any errors?
         BZ    OPN010                  No
         BAL   R14,FMT000              Display error
         B     EXIT08                  Exit on VSAM error
*
OPN010   EQU   *
         OI    FLAGS1,FL1NSPL          Indicate NETSPOOL is open
         TM    FLAGS1,FL1SPID          Specific file # specified?  v120
         BO    OPN020                  Yes                         v120
*
*-- Here for 'next' available spool file                           v120
*
         NSIO  TYPE=CONTENTS,          Get list of files               x
               NCB=(R8)
         LTR   R15,R15                 Any errors?
         BZ    OPN030                  No
         CLC   NCBRTNCD(2),=AL1(12,6)  No files in directory?
         BE    ERR004                  Close up and indicate no files
         BAL   R14,FMT000              Display error
         B     EXIT08                  Exit on VSAM error
*
*-- Here for 'specific' spool file number                          v120
*
OPN020   EQU   *                                                   v120
         MVC   TAGID,FILEID            Set file # to find          v120
*                                                                  v120
         NSIO  TYPE=FIND,              get directory entry         v120x
               NCB=(R8),                                           v120x
               TAG=(R11)               Where to place tag data     v120
         LTR   R15,R15                 Any errors?                 v120
         BZ    OPN200                  No, process file            v120
         CLC   NCBRTNCD(2),=AL1(12,4)  Was file id not found?      v120
         BE    ERR014                  Yes                         v120
         BAL   R14,FMT000              Otherwise, display error    v120
         B     EXIT08                  Exit on VSAM error          v120
*
*-- Look for next available in contents directory                  v120
*
OPN030   EQU   *
         L     R2,NCBAREA              Get a list of spool content
         USING NSDIR,R2
         SR    R5,R5
         ICM   R5,3,NCBRECCT           # of returned entries
         SR    R11,R11                 Indicate nothing found yet
*
OPN040   EQU   *
         CLC   LCLNODE,NSTOLOC         Is this file for this link?
         BNE   OPN160                  no, skip this file
         TM    FLAGS1,FL1ACEE          Was security available?     v130
         BZ    OPN150                  No; do not enforce selectionv130
         CLC   OWNER,NSTOVM            Is this file for this userid?
         BNE   OPN160                  no, skip this file
*
OPN150   EQU   *
         LA    R11,TDATA               -> tag data area for file
         USING TAG,R11
         XC    TDATA(TAGLEN),TDATA
         MVC   TAGINLOC(TAGUSELN),NSINLOC  Copy tag datq
         B     OPN170                  Go process the file
*
OPN160   EQU   *
         LA    R2,NSDIRLN(,R2)         Next NETSPOOL dir entry
         BCT   R5,OPN040               Continue thru the contents
         DROP  R2                      NSDIR
*
*
OPN170   EQU   *
         LM    R0,R1,NCBAREAL          Get list length and address
         XC    NCBAREA,NCBAREA         Clear obsolete ptr
         FREEMAIN RU,LV=(0),A=(1)
*
         LTR   R11,R11                 Did we obtain tag data?
         BZ    ERR004                  No, no file available
         B     OPN300                                              v120
*
*-- validate specific file owner                                   v120
*
OPN200   EQU   *                                                   v120
         CLC   LCLNODE,TAGTOLOC        Is this file for this link? v120
         BNE   ERR016                  no, skip this file          v120
         TM    FLAGS1,FL1ACEE          Was security available?     v130
         BZ    OPN300                  No; do not enforce selectionv130
         CLC   OWNER,TAGTOVM           Is file for this userid?    v120
         BNE   ERR016                  no, skip this file          v120
*                                                                  v120
OPN300   EQU   *                                                   v120
         MVC   LIST(L'MSG009),MSG009   Local node name
         MVC   LIST+L'MSG009+1(8),LCLNODE   Move name
         BAL   R14,PUT
*
*-- Retrieve the spool file
*
RD000    EQU   *
         NSIO  TYPE=GET,               TAG data contains file #        x
               NCB=(R8),                                               x
               AREA=REC
         LTR   R15,R15                 Any errors?
         BZ    RD030                   No
         BAL   R14,FMT000              Display error
         B     EXIT08                  Exit on VSAM error
*
RD030    EQU   *
         TM    TAGINDEV,TYPPUN         Is this punch data?
         BO    RD180                   Yes
*
         TM    FLAGS1,FL1CA+FL1CM      Do we have carriage ctrl?
         BNZ   RD050                   Yes, look closer
*
*-- PRT records with no CC bytes
*
         TM    REC,X'03'               Immediate cmd CC in record?
         BO    RD000                   Skip record
         LH    R1,NCBRECLN             Get length of input record
         BCTR  R1,0                    Less one to skip CC byte
         ICM   R1,8,BLANKS             Set pad char
         LA    R0,REC+1                -> spool input record skipping
*                                       the carriage control X'09'
         LA    R14,DATAREC             Where to build output record
         LH    R15,UT2LRECL            Get len of output record area
         MVCL  R14,R0                  Move record and pad excess
         B     RD200                   Go write the line
*
RD050    EQU   *
         TM    FLAGS1,FL1CM            Do we have machine car. ctl?
         BO    RD180                   Yes, no changes required
*
*-- PRT records with RECFM=A carriage control
*
         TM    REC,X'03'               Immediate cmd CC in record?
         BNO   RD070                   No, this one is the data
*
         LA    R0,C'0'                 Space 2 lines
         CLI   REC,X'13'               Is CC character space 2 immed?
         BE    RD060                   Yes
         LA    R0,C'1'                 Skip to channel 1
         CLI   REC,X'8B'               Is CC character ch 1 immed?
         BE    RD060                   Yes
         LA    R0,C'-'                 Space 3 lines
         CLI   REC,X'1B'               Is CC character space 3 immed?
         BE    RD060                   Yes
         LA    R0,C'+'                 Suppress space
         CLI   REC,X'01'               Is CC character write sup imd?
         BE    RD060                   Yes
         LA    R0,X'40'                Otherwise use space 1
*
RD060    EQU   *
         STC   R0,DATAREC              Store in output buffer
         B     RD000                   Get next record from spool
*
RD070    EQU   *
         LH    R1,NCBRECLN             Get length of input record
         BCTR  R1,0                    Less one to skip CC byte
         ICM   R1,8,BLANKS             Set pad char
         LA    R0,REC+1                -> spool input record skipping
*                                       the M carriage control
         LA    R14,DATAREC+1           Where to build output record
         LH    R15,UT2LRECL            Get len of output record area
         BCTR  R15,0                   Less one to skip CC byte
         MVCL  R14,R0                  Move record and pad excess
         B     RD200                   Go write the line
*
*-- PUN records
*-- PRT records using RECFM=M
*
RD180    EQU   *
         LH    R1,NCBRECLN             Get length of input record
         ICM   R1,8,BLANKS             Set pad char
         LA    R0,REC                  -> spool input record
         LA    R14,DATAREC             Where to build output record
         LH    R15,UT2LRECL            Get len of output record area
         MVCL  R14,R0                  Move record and pad excess
*
RD200    EQU   *
         PUT   SYSUT2,DATAREC
*
RD210    EQU   *
         LA    R9,1(,R9)               Count # of records written
         B     RD000                   Read another
*
*-- On end of file, Purge the spool file
*
EOD000   EQU   *
*
*-- Write: xxx records received from node(userid), File(####)
*
CLS020   EQU   *
         CVD   R9,DBLE                 Convert # records written
         MVC   LIST(12),=X'402020206B2020206B202120'  Move edit mask
         ED    LIST(12),DBLE+3         Edit result
         TRT   LIST(12),NONBLANK       Look for start of result
         MVC   LIST(12),0(R1)          Left justify result
         TRT   LIST(13),BLANK          Look for end of result
         LA    R1,1(,R1)               Skip over the blank
         MVC   0(L'MSG010,R1),MSG010   Move records recvd msg
         LA    R1,L'MSG010(,R1)        Bump position
         MVC   0(8,R1),TAGINLOC        Move destination node name
         TRT   0(9,R1),BLANK           Look for end of node name
         MVI   0(R1),C'('              Insert (
         MVC   1(8,R1),TAGINVM         Move destination userid
         TRT   1(9,R1),BLANK           Look for end of userid
         MVC   0(2,R1),=C'),'          Insert )
         MVC   3(11,R1),=C'File (xxxx)'
         LH    R2,TAGID                Get file id from tag
         CVD   R2,DBLE                 Convert
         UNPK  9(4,R1),DBLE            Unpk file #
         OI    12(R1),X'F0'            Fix sign
         BAL   R14,PUT                 Write the line
*
         MVC   LIST,BLANKS             Clear line                  v120
         MVC   LIST(11),=C'File (xxxx)'                            v120
         LH    R2,TAGID                Get file id from tag        v120
         CVD   R2,DBLE                 Convert                     v120
         UNPK  LIST+6(4),DBLE          Unpk file #                 v120
         OI    9(R1),X'F0'             Fix sign                    v120
         MVC   LIST+12(6),=C'purged'   Assume file purged          v120
*                                                                  v120
         TM    FLAGS1,FL1NOPUR         Do not purge file?          v120
         BO    CLS030                  Yes, skip it                v120
*
         NSIO  TYPE=PURGE,             Purge the file                  x
               NCB=(R8)
         LTR   R15,R15                 Any errors?
         BZ    CLS040                  No                          v120
         BAL   R14,FMT000              Display error
         B     EXIT08                  Exit on VSAM error
*
CLS030   EQU   *
         MVC   LIST+12(30),=C'retained due to NOPURGE option'      v120
*
CLS040   EQU   *                                                   v120
         BAL   R14,PUT                 Write the line              v120
         B     EXIT00
*
*-- Error msgs
*
*
ERR004   EQU   *
         BAL   R14,ERROR               Print ERROR line
         MVC   LIST(L'MSG004),MSG004   No files avalable to recv
         BAL   R14,PUT
         B     EXIT08
*
ERR005   EQU   *
         BAL   R14,ERROR               Print ERROR line
         MVC   LIST(L'MSG005),MSG005   No NETSPOOL dsn.
         BAL   R14,PUT
         MVC   LIST(L'MSG005A),MSG005A Code in JCL and resubmit
         BAL   R14,PUT
         B     EXIT08
*
ERR006   EQU   *
         BAL   R14,ERROR               Print ERROR line
         MVC   LIST(L'MSG006),MSG006   Unable to open SYSUT1
         BAL   R14,PUT
         B     EXIT08
*
ERR007   EQU   *
         BAL   R14,ERROR               Print ERROR line
         MVC   LIST(L'MSG007),MSG007   RECFM=U invalid
         BAL   R14,PUT
         B     EXIT08
*
ERR008   EQU   *
         BAL   R14,ERROR               Print ERROR line
         MVC   LIST(L'MSG008),MSG008   LRECL > 133
         BAL   R14,PUT
         MVC   LIST(L'MSG008A),MSG008A LRECL > 133 part 2
         BAL   R14,PUT
         B     EXIT08
*
ERR013   EQU   *                                                   v120
         BAL   R14,ERROR               Print ERROR line            v120
         MVC   LIST(L'MSG013),MSG013   Invalid parm field          v120
         BAL   R14,PUT                                             v120
         B     EXIT08                                              v120
*
ERR014   EQU   *                                                   v120
         BAL   R14,ERROR               Print ERROR line            v120
         MVC   LIST,BLANKS             Clear line                  v120
         MVC   LIST(L'MSG014),MSG014   File does not exist         v120
         LH    R2,FILEID               Get file id                 v120
         CVD   R2,DBLE                 Convert                     v120
         UNPK  LIST+6(4),DBLE          Unpk file #                 v120
         OI    9(R1),X'F0'             Fix sign                    v120
         BAL   R14,PUT                                             v120
         B     EXIT08                                              v120
*
ERR016   EQU   *                                                   v120
         BAL   R14,ERROR               Print ERROR line            v120
         MVC   LIST(L'MSG016),MSG016   Cant recv another users filev120
         BAL   R14,PUT                                             v120
         B     EXIT08                                              v120
*
ERROR    EQU   *
         MVC   LIST(6),=C'ERROR:'
*
PUT      EQU   *
         ST    R14,SV14
         PUT   SYSPRINT,LIST
         MVC   LIST,BLANKS
         L     R14,SV14
         BR    R14
*
*
*-- Examine the PARM field                                         v120
*                                                                  v120
*-- Entry: R8 contains the Register 1 address value from entry.   v120
*-- Exit:  CC=0  PARM field ok; FILE=/NOPURGE are valid.          v120
*--        CC<>0 PARM field missing or otherwise coded incorrectly.v120
*                                                                  v120
*-- Valid PARM field formats:  PARM='FILE=xxxx'                    v120
*--                            PARM='NOPURGE'                      v120
*--                            PARM='FILE=XXXX,NOPURGE'            v120
*                                                                  v120
*                                                                  v120
PARM000  EQU   *                                                   v120
         MVC   MACLIST(20),BLANKS      Init work area              v120
         L     R1,0(,R8)               -> PARM field               v120
         LH    R4,0(,R1)               Get length of PARM field    v120
         LTR   R4,R4                   Check length                v120
         BZR   R14                     No PARM field is OK         v120
         CH    R4,=H'6'                Is the length at least 6 ?  v120
         BL    PARMERR                 Shorter cant be valid       v120
         CH    R4,=H'17'               More than 17 char?          v120
         BH    PARMERR                 Longer cant be valid        v120
*                                                                  v120
         BCTR  R4,0                    Adjust len for execute      v120
         EX    R4,OCPARM               Uppercase and move PARM datav120
*OCPARM  OC    MACLIST(0),2(R1)                                    v120
         LA    R4,1(,R4)               Restore remaining length    v120
*                                                                  v120
         MVC   TRTAB,BLANK             Set up translate table      v120
         MVI   TRTAB+C',',X'FF'        search for ',' chars        v120
         MVI   TRTAB+C' ',X'FF'        search for ' ' chars        v120
*                                                                  v120
         LA    R3,MACLIST              -> start of a parameter     v120
*                                                                  v120
PARM020  EQU   *                                                   v120
         C     R4,=F'5'                Sufficient len remaining?   v120
         BL    PARMERR                 No                          v120
         CLC   =C'PURGE',0(R3)         Purge                       v120
         BE    PARM030                 Yes                         v120
         C     R4,=F'6'                Sufficient len remaining?   v120
         BL    PARMERR                 No                          v120
         CLC   =C'FILE=',0(R3)         File=?                      v120
         BE    PARM040                 Yes                         v120
         C     R4,=F'7'                Sufficient len remaining?   v120
         BL    PARMERR                 No                          v120
         CLC   =C'NOPURGE',0(R3)       Nopurge?                    v120
         BNE   PARMERR                 No                          v120
*                                                                  v120
         OI    FLAGS1,FL1NOPUR         Indic do not purge  file    v120
         LA    R1,7                    Length to skip              v120
         AR    R3,R1                   Skip past NOPURGE           v120
         SR    R4,R1                   Reduce remaining length     v120
         BNP   PARM090                 If zero, we're done         v120
*                                                                  v120
         CLI   0(R3),C','              Another parameter?          v120
         BNE   PARMERR                 Something wrong             v120
         LA    R3,1(,R3)               Skip comma                  v120
         BCTR  R4,0                    Adjust remaining            v120
         B     PARM020                 Look for next parm          v120
*                                                                  v120
PARM030  EQU   *                                                   v120
         NI    FLAGS1,255-FL1NOPUR     Indic purge file            v120
         LA    R1,5                    Length to skip              v120
         AR    R3,R1                   Skip past PURGE             v120
         SR    R4,R1                   Reduce remaining length     v120
         BNP   PARM090                 If zero, we're done         v120
*                                                                  v120
         CLI   0(R3),C','              Another parameter?          v120
         BNE   PARMERR                 Something wrong             v120
         LA    R3,1(,R3)               Skip comma                  v120
         BCTR  R4,0                    Adjust remaining            v120
         B     PARM020                 Look for next parm          v120
*                                                                  v120
PARM040  EQU   *                                                   v120
         LA    R1,5                    Length to skip              v120
         AR    R3,R1                   Skip past FILE=             v120
         SR    R4,R1                   Reduce remaining length     v120
         BNP   PARMERR                 Not good if too short       v120
*                                                                  v120
         TRT   0(5,R3),TRTAB           comma/blank end of # ?      v120
         BZ    PARMERR                 Must be found or error      v120
         SR    R1,R3                   Compute length of #         v120
         LR    R2,R1                   Copy length of #            v120
         BCTR  R2,0                    Adjust for execute          v120
         EX    R2,MVC#                 Copy the #                  v120
         EX    R2,OC#                  Force numeric               v120
         EX    R2,CLC#                 Was it numeric?             v120
         BNE   PARMERR                 No, bad #                   v120
         EX    R2,PACK#                Pack the file id #          v120
         CVB   R2,DBLE                 Get binary                  v120
         STH   R2,FILEID               Set the value here          v120
         OI    FLAGS1,FL1SPID          Indicate file spool id codedv120
*                                                                  v120
         AR    R3,R1                   Skip past file id #         v120
         SR    R4,R1                   Reduce remaining length     v120
         BNP   PARM090                 If zero, we're done         v120
*                                                                  v120
         CLI   0(R3),C','              Another parameter?          v120
         BNE   PARMERR                 Something wrong             v120
         LA    R3,1(,R3)               Skip comma                  v120
         BCTR  R4,0                    Adjust remaining            v120
         B     PARM020                 Look for next parm          v120
*                                                                  v120
PARM090  EQU   *                                                   v120
         CLI   *+1,0                   Set CC=0                    v120
         BR    R14                     Return w/ PARMs ok          v120
*                                                                  v120
PARMERR  EQU   *                                                   v120
         LTR   R12,R12                 Set CC non-zero             v120
         BR    R14                     Errors in PARM field        v120
*                                                                  v120
OCPARM   OC    MACLIST(0),2(R1)        executed instr              v120
MVC#     MVC   DBLE(0),0(R3)           executed instr              v120
OC#      OC    DBLE(0),=5C'0'          executed instr              v120
CLC#     CLC   DBLE(0),0(R3)           executed instr              v120
PACK#    PACK  DBLE(8),0(0,R3)         executed instr              v120
*
*
*
*-- Get status of NJE38
*
*-- Entry: R1=0 (no spool dsn needed), or, R1-> 44-char spool DSN area
*-- Exit:  RC=0  NJE38 is active; R1-> NJE38 CSA block
*--        RC<>0 NJE is not active.
*
CHK000   EQU   *
         LA    R1,NSPLDSN              -> where to place spool DSN v210
         L     R15,=V(NJESYS)          -> ENQ finder               v210
         BALR  R14,R15                 Check if NJE38 already act  v210
         LTR   R15,R15                 Set CC (RC=0 NJE38 active)  v210
         BNZR  R2                      Return if NJE38 inactive    v210
         MVC   LCLNODE,NJ38NODE-NJ38CSA(R1)  Save off lcl node namev210
         MVC   DEFUSER,NJ38DUSR-NJ38CSA(R1)  Save off default user v211
         BR    R2                      Return; NJE38 active        v210
*
*- Dynamically allocate the NETSPOOL dataset when there is no DD
*- statement and when NJE38 is active.
*
DYN000   EQU   *
         MVC   TXT1,TXT1D               INITIALIZE DDNAME TXT UNIT
         MVC   TXT2,TXT2D               INITIALIZE TXT UNIT
         MVC   TXT3,TXT3D               INITIALIZE TXT UNIT
         MVC   TXT4,TXT4D               INITIALIZE TXT UNIT
         LA    R1,TXT1                  POINT TO TEXT UNIT
         ST    R1,MACLIST               SET IN ADDRESS LIST
         LA    R1,TXT2                  POINT TO TEXT UNIT
         ST    R1,MACLIST+4             SET IN ADDRESS LIST
         LA    R1,TXT3                  POINT TO TEXT UNIT
         ST    R1,MACLIST+8             SET IN ADDRESS LIST
         LA    R1,TXT4                  POINT TO TEXT UNIT
         ST    R1,MACLIST+12            SET IN ADDRESS LIST
         OI    MACLIST+12,X'80'         SET VL
*
*-- Issue Dynalloc SVC
*
         ST    R14,DYNR14               SAVE RETURN REG
         MVC   LS99RB,CPS99RB           INIT THE S99RB
         LA    R1,LS99RB                POINT TO BLOCK
         USING S99RB,R1
         OI    S99FLAG1,S99NOCNV        FORCE NEW ALLOCATION
         ST    R1,LS99PTR               SET PARAMETER WORD
         OI    LS99PTR,X'80'            SET VL
         LA    R14,MACLIST              GET ADDRESS OF TEXT UNITS
         ST    R14,S99TXTPP             PUT IN S99RB
*
         LA    R1,LS99PTR               POINTER TO S99 PTR
         SVC   99                       ISSUE DYNALLOC
*
         LTR   R15,R15                  R15 non zero?
         BZ    DYN090                   No
*
         LA    R1,LS99RB
         UNPK  TWRK(9),S99ERROR(5)      Add zones to error code
         DROP  R1
         TR    TWRK(8),HEXTRAN-240
         MVC   LIST(L'MSG012),MSG012    Dyn alloc failure msg
         MVC   LIST+22(8),TWRK          Error codes to line
         MVC   LIST+36(44),NSPLDSN      Move DSNAME
         BAL   R14,PUT                  Write line
         CLI   *,0                      Set CC=non-zero
*
DYN090   EQU   *
         L     R14,DYNR14               Restore return addr
         BR    R14
*
FMT000   EQU   *
         STM   R14,R2,BALRSAVE         Save regs used
         MVC   LIST+0(L'MSG000),MSG000 Move msg text
         MVC   LIST+51(8),5(R12)       Move csect name
         TRT   LIST+51(9),BLANK        Look for end of csect name
         MVI   0(R1),C'+'
*
         LA    R15,0(,R14)  Clear high, Get addr of call to this rtn
         LA    R12,0(,R12)             Clear high byte
         SR    R15,R12                 Compute offset of call
         ST    R15,DBLE                Save to work area
         UNPK  TWRK(5),DBLE+2(3)       Add zones
         TR    TWRK(4),HEXTRAN-240     Display hex
         MVC   1(4,R1),TWRK            Move call offset to msg
*
         LA    R15,NCB1
         UNPK  TWRK(5),NCBRTNCD-NCB(3,R15)  Add zones
         TR    TWRK(4),HEXTRAN-240
         MVC   LIST+31(4),TWRK         Move rtncd/errcd
*
         UNPK  TWRK(3),NCBREQ-NCB(2,R15)  Add zones
         TR    TWRK(2),HEXTRAN-240
         MVC   LIST+41(2),TWRK         Move req code
*
         L     R1,NCBMACAD-NCB(,R15)   Get failing VSAM macro addr
         LA    R1,0(,R1)               Clear high byte
         S     R1,=V(NJESPOOL)         Compute offset into NJESPOOL rtn
         ST    R1,DBLE
         UNPK  TWRK(5),DBLE+2(3)       Add zones
         TR    TWRK(4),HEXTRAN-240     Display hex
         MVC   LIST+46(4),TWRK         Move NJESPOOL offset to msg
*
         PUT   SYSPRINT,LIST
         MVC   LIST,BLANKS
*
FMT090   EQU   *
         LM    R14,R2,BALRSAVE         Restore caller regs
         BR    R14                     Return
*
EXIT00   EQU   *
         SR    R5,R5
         B     QUIT000
*
EXIT08   EQU   *
         LA    R5,8
         B     QUIT000
*
QUIT000  EQU   *
         TM    FLAGS1,FL1OPEN          Is SYSUT2 open?
         BZ    QUIT010                 No
         MVC   MACLIST(CLOSEL),CLOSE   Move close list
         CLOSE (SYSUT2),               Close it                        X
               MF=(E,MACLIST)
*
QUIT010  EQU   *
         TM    FLAGS1,FL1NSPL          Is NETSPOOL open?
         BZ    QUIT020                 No
*
         SR    R11,R11                 Ensure no tag data
         NSIO  TYPE=CLOSE,                                             x
               NCB=(R8)
*
QUIT020  EQU   *
         BAL   R14,PUT                 Write blank line
         MVC   LIST(L'MSG011),MSG011   Move ended RC=x msg
         CVD   R5,DBLE                 Convert RC
         UNPK  LIST+18(1),DBLE
         OI    LIST+18,X'F0'           Fix sign
         BAL   R14,PUT
*
         MVC   MACLIST(CLOSEL),CLOSE   Move close list
         CLOSE (SYSPRINT),                                             X
               MF=(E,MACLIST)
*
         LR    R1,R10                  -> NJEFWK work area
         L     R13,4(,R13)             -> CALLER'S SA
         FREEMAIN RU,                  Free the work area              X
               LV=NJEXSZ,                                              X
               A=(1)
*
         ST    R5,16(,R13)             Save R15 RC
         LM    R14,R12,12(R13)         RELOAD SYSTEM'S REGS
         BR    R14                     Return
*
         LTORG
*
DMYUT2   DCB   DDNAME=SYSUT2,                                          X
               MACRF=(PM),                                             X
               DSORG=PS
DMYUT2L  EQU   *-DMYUT2
*
DMYPRT   DCB   DDNAME=SYSPRINT,                                        X
               MACRF=(PM),                                             X
               DSORG=PS,                                               X
               LRECL=80,                                               X
               RECFM=FB,                                               X
               BLKSIZE=800
DMYPRTL  EQU   *-DMYPRT
*
OPEN     OPEN  0,MF=L
OPENL    EQU   *-OPEN
CLOSE    CLOSE 0,MF=L
CLOSEL   EQU   *-CLOSE
POST     POST  0,ASCB=0,ERRET=0,MF=L
POSTL    EQU   *-POST
*
NJE38Q   DC    CL8'NJE38'              QNAME
NJERCON  DC    CL8'NJEINIT'            RNAME (first 8 bytes)
*
* TEXT UNITS TO SET UP  //NETSPOOL DD DSN=DSNAME,DISP=SHR,FREE=CLOSE
*
TXT1D    DC    Y(DALDDNAM),AL2(1),AL2(8),CL8'NETSPOOL'   DDNAME
TXT2D    DC    Y(DALDSNAM),AL2(1),AL2(44)         DSNAME
TXT3D    DC    Y(DALSTATS),AL2(1),AL2(1),X'08'    DISP=SHR
TXT4D    DC    Y(DALCLOSE),AL2(0)                 FREE=CLOSE
*
         DS    0F
CPS99RB  DS    0XL20                   DEFINE INITIAL S99RB
         DC    AL1(20)                 LENGTH OF REQ BLOCK
         DC    AL1(1)                  VERB CODE:  ALLOCATION
         DC    X'20'                   FLAGS:  NO MOUNTS,OFFLINE VOLS
         DC    X'00'                   FLAGS
         DC    AL2(0)                  ERROR REASON CODE
         DC    AL2(0)                  INFO REASON CODE
         DC    A(0)                    ADDR OF TEXT PTRS
         DC    A(0)                    ADDR OF RBX
         DC    AL4(0)                  MORE FLAGS
*
*                012345678901234567890123456789 01234 56789012345678901
MSG000   DC    C'ERROR:  NETSPOOL RTNCD/ERRCD=X''0000'',REQ=01,O=1234,Mx
               MMMMMMM     '
*
MSG001   DC    C'NJ38RECV - NJE38 File Receive Utility'
*                0123456789012345678901234567890123456789012 345 6789
MSG002   DC    C'Open failed for NETSPOOL, RC=xx,ACBERFLG=X''xx'''
*                012345678901234567890123456789012345678901234567 8901
MSG003   DC    C'PUT failed writing record xxxxxxx, RTNCD-FDBK=X''xxxx'x
               ''
MSG004   DC    C'No files available to receive'
MSG005   DC    C'Unable to determine NETSPOOL dsname'
MSG005A  DC    C'Start NJE38 and resubmit this job'                v211
MSG006   DC    C'Unable to open SYSUT2'
MSG007   DC    C'RECFM=U datasets are not supported'
MSG008   DC    C'LRECL of the SYSUT2 dataset is too large'
MSG008A  DC    C'The maximum allowed LRECL is 133 bytes'
MSG009   DC    C'Local node:'
MSG010   DC    C'records received from '
MSG011   DC    C'NJ38RECV ends; RC=x'
MSG012   DC    C'Dyn. allocation error xxxxxxxx, DSN='
MSG013   DC    C'Invalid or unrecognized parameters in the JCL EXEC PARx
               M field'                                            v120
MSG014   DC    C'File (xxxx) does not exist'                       v120
MSG015   DC    C'Options specified: '                              v120
MSG016   DC    C'Cannot receive file destined for another user'    v120
*                0123456789012345678901234567890123456789012345678901
*
BLANKS   DC    CL80' '
BLANK    DC    64X'00',X'FF',191X'00'
NONBLANK DC    64X'FF',X'00',191X'FF'
HEXTRAN  DC    CL16'0123456789ABCDEF'
*
*
TYPPRT   EQU   X'40'                   PRT dev
TYPPUN   EQU   X'80'                   PUN dev
*
*
*
NJEXWK   DSECT
NJEEYE   DS    CL4'NJEX'               EYECATCHER
NJEWKLEN DS    F                       SIZE OF WORK AREA
*
NJESA    DS    18F
BALRSAVE DS    16F
LCLNODE  DS    CL8                     Local node name
OWNER    DS    CL8                     Owner userid (running this pgm)
DEFUSER  DS    CL8                     Default userid from CONFIG  v130
DBLE     DS    D
TWRK     DS    XL16
MACLIST  DS    XL128
NCB1     DS    XL48
LIST     DS    CL80                    PRINT LINE
DESTNODE DS    CL8                     Destination node name
DESTUSER DS    CL8                     Destination user id
SV14     DS    F                       R14 save area
DYNR14   DS    A                       R14 SAVE AREA
LS99PTR  DS    A                       PTR TO S99RB
LS99RB   DS    XL20                    SPACE FOR S99RB
*
*
TXT1     DS    0XL14,Y,AL2,AL2         SPACE FOR THE DDNAME TEXT UNIT
DDNAME   DS    CL8                      DDNAME
*
TXT2     DS    0XL06,Y,AL2,AL2         DSN=
NSPLDSN  DS    CL44                     NETSPOOL DSNAME
*
TXT3     DS    0XL07,Y,AL2,AL2,X       DISP=SHR
TXT4     DS    0XL04,Y,AL2             FREE=CLOSE
*
UT2LRECL DS    H                       LRECL of SYSUT2 file
SPLLRECL DS    H                       LRECL of selected spool file
FILEID   DS    H                       PARM field spool file id #  v120
*
FLAGS1   DS    X
FL1OPEN  EQU   X'80'      1... ....    SYSUT2 is open
FL1NSPL  EQU   X'40'      .1.. ....    NETSPOOL is open
FL1SPID  EQU   X'20'      ..1. ....    FILE=xxxx coded on PARM fld v120
FL1ACEE  EQU   X'10'      ...1 ....    ACEE was located            v130
FL1CA    EQU   X'04'      .... .1..    Records contain ASA car ctl
FL1CM    EQU   X'02'      .... ..1.    Records contain Mach car ctl
FL1NOPUR EQU   X'01'      .... ...1    Dont purge the spool file   v120
*                         .... x...    available bits              v130
*
FLAGS2   DS    X
*
TDATA    DS    XL108                   TAG data area
SYSUT2   DS    (DMYUT2L)X              SYSUT1 DCB
SYSPRINT DS    (DMYPRTL)X              SYSPRINT DCB
TRTAB    DS    CL256                   Translate table area
REC      DS    CL133                   input spool record area
DATAREC  DS    CL133                   Output record area
         DS    0D                      Force doubleword boundary
NJEXSZ   EQU   *-NJEXWK                Size of work area
*
         CVT   DSECT=YES,LIST=NO
         IHAPSA
         IKJTCB
IEFTIOT  DSECT
         IEFTIOT1
         IEESMCA
         IEFZB4D0
         IEFZB4D2
         IHAASCB
         IHAASXB
*
ACEE     DSECT                         Maps a portion of ACEE in MVS3.8
ACEEEYE  DS    CL4'ACEE'
         DS    16X
ACEEUSRL DS    X                       Length of userid
ACEEUSR  DS    CL8                     Userid
*
         DCBD  DSORG=PS,DEVD=DA
         COPY  NETSPOOL
         COPY  TAG
         COPY  LINKTABL
         END
./ ADD NAME=NJ38XMIT
*
*
*-- NJE38 - Place a file into the spool and queue it for transmission.
*
*
*   This program writes a file or dataset to the NETSPOOL dataset
*   and POSTs NJE38 that it is available for transmission to a node.
*
*
* Change log:
*
* 10 Dec 20 - Support for registered users and message queuing     v220
* 29 Nov 20 - Use text-based configuration; alternate routes       v211
* 01 Oct 20 - Put ENQ existence check in common module             v210
* 30 Jun 20 - ERRET label on POST incorrect; could cause loop.     v200
* 03 Jun 20 - Support a default userid if no security product.     v130
* 14 May 20 - Remove restriction for destination being local node. v110
*
*
         REGEQU
NJ38XMIT CSECT
         NJEVER
         STM   R14,R12,12(R13)        SAVE CMS REGS
         LR    R12,R15                BASE
         USING NJ38XMIT,R12           ADDRESS IT
         LR    R8,R1                  Save parm field addr
*
         GETMAIN RU,                  GET LOCAL STG AREA               X
               LV=NJEXSZ
         LR    R10,R1
         LR    R1,R0                   COPY LENGTH
         LR    R2,R0                   COPY LENGTH
         LR    R0,R10                  -> NEW STG AREA
         SR    R15,R15                 SET PAD
         MVCL  R0,R14                  CLEAR THE PAGE
*
         USING NJEXWK,R10
         ST    R13,NJESA+4             SAVE PRV S.A. ADDR
         LA    R1,NJESA                -> MY SAVE AREA
         ST    R1,8(,R13)              PLUG IT INTO PRIOR SA
         LR    R13,R1
*
INIT000  EQU   *
         MVC   NJEEYE,=CL4'NJEX'       Work area eyecatcher
         ST    R2,NJEWKLEN             Save size of area
         MVC   SYSUT1(DMYUT1L),DMYUT1  Set up DCB
         MVC   SYSPRINT(DMYPRTL),DMYPRT Set up DCB
         MVC   LIST,BLANKS             Init print line
         MVC   LCLNODE,=CL8'????????'  Unknown node name
         SR    R11,R11                 Init tag data ptr
*
         MVC   MACLIST(OPENL),OPEN     Move OPEN list
         OPEN  (SYSPRINT,OUTPUT),      Open the print dataset          X
               MF=(E,MACLIST)
*
         MVC   LIST(L'MSG001),MSG001
         BAL   R14,PUT                 Write the line
         BAL   R14,PUT                 Write blank line
*
INIT020  EQU   *
         BAL   R14,PARM000             Go examine the PARM field
         BNZ   ERR004                  Bad PARM field, print error
         BAL   R2,CHK000               Get NETSPOOL DSN            v210
         BNZ   ERR005                  Can't; NJE38 is not active  v210
         BAL   R14,DYN000              Allocate the NETSPOOL dataset
         BNZ   EXIT08                  Exit if dyn alloc fails
*
INIT040  EQU   *
         MVC   MACLIST(OPENL),OPEN     Move OPEN list
         LA    R7,SYSUT1               -> DCB
         USING IHADCB,R7
*
         OPEN  (SYSUT1,INPUT),         Open the SYSUT1 dataset         X
               MF=(E,MACLIST)
         TM    DCBOFLGS,DCBOFOPN       Is DCB open ok?
         BZ    ERR006                  No
         OI    FLAGS1,FL1OPEN          Indicate DCB is open
*
         MVC   DBLE(1),DCBRECFM        Get record format byte
         NI    DBLE,X'06'              Keep only DCBRECCA+DCBRECCM bits
         OC    FLAGS1,DBLE             Keep the bits in our flag bits
*
         TM    DCBRECFM,DCBRECU        Is this a RECFM=U file?
         BO    ERR007                  Unsupported type
         CLC   DCBLRECL,=AL2(133)      LRECL > max supported by NJE?
         BH    ERR008                  Yes
         MVC   LRECL,DCBLRECL          Save off the LRECL value
*
TYP000   EQU   *
         LA    R6,TYPPUN               Assume this is punch data
         TM    FLAGS1,FL1CA+FL1CM      Do we have carriage ctl?
         BZ    TYP020                  No, possible punch data
         LA    R6,TYPPRT               Y, definitely print data then
         B     TYP030
*
TYP020   EQU   *
         CLC   LRECL,=AL2(80)          Are records <=80?
         BNH   TYP030                  Yes, it is punch data
         LA    R6,TYPPRT               Must be PRT without CC otherwise
         CLC   DCBLRECL,=AL2(132)      LRECL max is 132 without CC
         BH    ERR008                  Yes
*
TYP030   EQU   *
         STC   R6,DATATYPE             Save determined type
*
*-- Open NETSPOOL
*
RD000    EQU   *
         SR    R9,R9                   Init record counter
         LA    R8,NCB1                 -> NCB
         USING NCB,R8
         STC   R6,NCBFL1               Save determined type in NCB too
*
         NSIO  TYPE=OPEN,                                              x
               NCB=(R8)
         LTR   R15,R15                 Any errors?
         BZ    RD010                   No
         BAL   R14,FMT000              Display error
         B     EXIT08                  Exit on VSAM error
*
RD010    EQU   *
         OI    FLAGS1,FL1NSPL          Indicate NETSPOOL is open
*
         MVC   LIST(L'MSG009),MSG009   Local node name
         MVC   LIST+L'MSG009+1(8),LCLNODE   Move name
         BAL   R14,PUT
*
RD020    EQU   *
         GET   SYSUT1                  Get a data record
*
         LR    R3,R1                   Record addr to R3
         LH    R2,DCBLRECL             Get record length from DCB
         TM    DCBRECFM,DCBRECF        RECFM=F data?
         BO    RD030                   Yes, we're good
         SR    R2,R2                   Clear for ICM
         ICM   R2,3,0(R3)              Get the len from RDW
         LA    R3,4(,R3)               -> start of the record data
*
RD030    EQU   *
         TM    DATATYPE,TYPPUN         Is this punch data?
         BO    RD150                   Y, write straight as is
*
         TM    FLAGS1,FL1CA+FL1CM      Do we have carriage ctrl?
         BNZ   RD050                   Yes, look closer
*
*-- PRT records with no CC bytes
*
         BCTR  R2,0                    Get IBM len of input record
         EX    R2,MVCREC1              Move it to our buffer
         MVI   DATABUF,X'09'           Single space carriage ctl char
         LA    R2,2(,R2)               Back to true length + CC byte
         B     RD200                   Go write the line
MVCREC1  MVC   DATABUF+1(0),0(R3)      executed instr
*
RD050    EQU   *
         TM    FLAGS1,FL1CM            Machine carriage control?
         BO    RD100                   Yes
*
*-- PRT records with RECFM=A carriage control
*
         LA    R0,X'13'                Space 2 lines immediate
         CLI   0(R3),C'0'              Is CC character '0'?
         BE    RD060                   Yes
         LA    R0,X'8B'                Skip to channel 1 immediate
         CLI   0(R3),C'1'              Is CC character '1'?
         BE    RD060                   Yes
         LA    R0,X'1B'                Space 3 lines immediate
         CLI   0(R3),C'-'              Is CC character '-'?
         BE    RD060                   Yes
         LA    R0,X'01'                Write, no space
         CLI   0(R3),C'+'              Is CC character '+'?
         BE    RD060                   Yes
         LA    R0,X'0B'                Otherwise use space 1 immed
*
RD060    EQU   *
         STC   R0,DATABUF              Store opcode our buffer
*
         NSIO  TYPE=PUT,               Write the immediate command     x
               NCB=(R8),                                               x
               AREA=DATABUF,                                           x
               RECLEN=1
         LTR   R15,R15                 Any errors?
         BZ    RD070                   No
         BAL   R14,FMT000              Display error
         B     EXIT08                  Exit on VSAM error
*
RD070    EQU   *
         BCTR  R2,0                    Get IBM len of input record
         EX    R2,MVCREC2              Move it to our buffer
         MVI   DATABUF,X'01'           Insert write without space code
         LA    R2,1(,R2)               Back to true length
         B     RD200                   Go write the line
MVCREC2  MVC   DATABUF(0),0(R3)
*
*
*-- PRT records with RECFM=M carriage control
*
RD100    EQU   *
         BCTR  R2,0                    Get IBM len of input record
         EX    R2,MVCREC3              Move it to our buffer
         TR    DATABUF(1),PRTCC        Ensure Mach car ctl valid
         LA    R2,1(,R2)               Back to true length
         B     RD200                   Go write the line
MVCREC3  MVC   DATABUF(0),0(R3)
*
*-- PUN records
*
RD150    EQU   *
         MVC   DATABUF,0(R3)           Move the punch record
*
RD200    EQU   *
         NSIO  TYPE=PUT,                                               x
               NCB=(R8),                                               x
               AREA=DATABUF,                                           x
               RECLEN=(R2)
         LTR   R15,R15                 Any errors?
         BZ    RD210                   No
         BAL   R14,FMT000              Display error
         B     EXIT08                  Exit on VSAM error
*
RD210    EQU   *
         LA    R9,1(,R9)               Count # of records written
         B     RD020                   Read another
         DROP  R7                      IHADCB
*
*-- On end of file, build the tag data and pass it to CLOSE
*
EOD000   EQU   *
         LA    R3,DEFUSER              -> Default userid           v130
         TM    FLAGS1,FL1NACEE         Use NOACEE (debug only)     v130
         BO    EOD010                  Yes, force default userid   v130
*
         L     R2,PSAAOLD-PSA(0)       -> my ASCB
         L     R2,ASCBASXB-ASCB(,R2)   -> my ASXB
         ICM   R2,15,ASXBSENV-ASXB(R2) -> my ACEE
         BZ    EOD010                  Use default userid if no ACEE
         LA    R3,ACEEUSR-ACEE(,R2)    -> Userid
*
EOD010   EQU   *
         L     R5,16                   -> CVT
         L     R5,CVTSMCA-CVT(,R5)     -> SMCA
         LA    R5,SMCASID-SMCABASE(,R5) -> system id
*
EOD020   EQU   *
         LA    R11,TDATA               -> tag data area
         USING TAG,R11
*
         STCK  TAGINTOD                Time of spool file creation
*
         MVC   TAGDEV,=X'000C'         Pseudo card rdr CUU
         MVC   TAGINLOC,LCLNODE        Local node name of origin
         MVC   TAGINVM,0(R3)           Userid of origin
         ST    R9,TAGRECNM             # of records written
         MVC   TAGRECLN,LRECL          Move record length
         MVC   TAGINDEV,DATATYPE       data type coming in (PRT/PUN)
         MVC   TAGCLASS,=C'A'          Spool class
         MVC   TAGCOPY,=H'1'           # copies
         MVC   TAGNAME,BLANKS          Init receiving field
         MVC   TAGNAME(8),0(R3)        Insert userid
         MVC   TAGTYPE,=CL12'OUTPUT'
         MVC   TAGDIST,BLANKS          Init receiving field
         MVC   TAGDIST(4),0(R5)        Insert system id
         MVC   TAGTOLOC,DESTNODE       destination node
         MVC   TAGTOVM,DESTUSER        destination userid
         MVC   TAGPRIOR,=H'1'          priority
*
CLS000   EQU   *
         NSIO  TYPE=CLOSE,             Close NETSPOOL                  x
               NCB=(R8),                                               x
               TAG=(R11)               Pass TAG data
         NI    FLAGS1,255-FL1NSPL      NETSPOOL is closed
*
         BAL   R2,CHK000               See if NJE38 is still activev210
         BNZ   CLS090                  It is not, no POST required v210
         CLC   DESTNODE,LCLNODE        Trying to send file locally?v110
         BE    CLS090                  Y, but skip the POST        v110
*
         LR    R7,R1                   -> NJE38 CSA ptr to R7      v210
         USING NJ38CSA,R7
*
         MODESET MODE=SUP,KEY=ZERO
*
         GETMAIN RU,                   Get CSA for WRE TYPE=WRENEW     x
               LV=WRESIZE,                                         v220x
               SP=241
         XC    0(WRESIZE,R1),0(R1)     Clear stg area              v220
         USING WRE,R1
         MVI   WRESP,241               Save subpool                v220
         MVI   WRETYPE,WRENEW          "New file in spool" WRE
         MVC   WRELINK,DESTNODE        Set destination node
         MVC   WREUSER,DESTUSER        Set destination userid
*
         LM    R2,R3,NJ38SWAP          Get first WRE ptr, sync count
CLS020   EQU   *
         ST    R2,WRENEXT              First WRE becomes next
         LR    R4,R1                   -> WRE to be added as first
         LA    R5,1(,R3)               Incr synchronization count
         CDS   R2,R4,NJ38SWAP          Update CSA WRE anchor, sync
         BC    7,CLS020                Gotta try again
*
         LA    R6,NJ38ECB              -> NJE38 external WRE ECB
         L     R7,NJ38ASCB             -> NJE38 ASCB
         DROP  R7                      NJ38CSA
*
         MVC   MACLIST(POSTL),POST     Move macro model
         POST  (6),                    Wake up NJE38 to new spool file x
               ASCB=(7),                                               x
               ERRET=CLS090,           Exit if can't do the post   v200x
               ECBKEY=0,                                               x
               MF=(E,MACLIST)
*
         MODESET MODE=PROB,KEY=NZERO
*
*-- Write: xxx records queued for node(userid), File(####)
*
CLS090   EQU   *
         CVD   R9,DBLE                 Convert # records written
         MVC   LIST(12),=X'402020206B2020206B202120'  Move edit mask
         ED    LIST(12),DBLE+3         Edit result
         TRT   LIST(12),NONBLANK       Look for start of result
         MVC   LIST(12),0(R1)          Left justify result
         TRT   LIST(13),BLANK          Look for end of result
         LA    R1,1(,R1)               Skip over the blank
         MVC   0(L'MSG010,R1),MSG010   Move records queued msg
         LA    R1,L'MSG010(,R1)        Bump position
         MVC   0(8,R1),DESTNODE        Move destination node name
         TRT   0(9,R1),BLANK           Look for end of node name
         MVI   0(R1),C'('              Insert (
         MVC   1(8,R1),DESTUSER        Move destination userid
         TRT   1(9,R1),BLANK           Look for end of userid
         MVC   0(2,R1),=C'),'          Insert )
         MVC   3(11,R1),=C'File (xxxx)'
         LH    R2,NCBFID               Get file id after close
         CVD   R2,DBLE                 Convert
         UNPK  9(4,R1),DBLE            Unpk file #
         OI    12(R1),X'F0'            Fix sign
         BAL   R14,PUT                 Write the line
         B     EXIT00
*
*-- Error msgs
*
*
ERR004   EQU   *
         BAL   R14,ERROR               Print ERROR line
         MVC   LIST(L'MSG004),MSG004   No parm field
         BAL   R14,PUT
         B     EXIT08
*
ERR005   EQU   *
         BAL   R14,ERROR               Print ERROR line
         MVC   LIST(L'MSG005),MSG005   No NETSPOOL dsn.
         BAL   R14,PUT
         MVC   LIST(L'MSG005A),MSG005A Code in JCL and resubmit
         BAL   R14,PUT
         B     EXIT08
*
ERR006   EQU   *
         BAL   R14,ERROR               Print ERROR line
         MVC   LIST(L'MSG006),MSG006   Unable to open SYSUT1
         BAL   R14,PUT
         B     EXIT08
*
ERR007   EQU   *
         BAL   R14,ERROR               Print ERROR line
         MVC   LIST(L'MSG007),MSG007   RECFM=U invalid
         BAL   R14,PUT
         B     EXIT08
*
ERR008   EQU   *
         BAL   R14,ERROR               Print ERROR line
         MVC   LIST(L'MSG008),MSG008   LRECL > 133
         BAL   R14,PUT
         MVC   LIST(L'MSG008A),MSG008A LRECL > 133 part 2
         BAL   R14,PUT
         MVC   LIST(L'MSG008B),MSG008B LRECL > 133 part 3
         BAL   R14,PUT
         B     EXIT08
*
ERR013   EQU   *
         BAL   R14,ERROR               Print ERROR line
         MVC   LIST(L'MSG013),MSG013   local node destination rejected
         BAL   R14,PUT
         B     EXIT08
*
ERROR    EQU   *
         MVC   LIST(6),=C'ERROR:'
*
PUT      EQU   *
         ST    R14,SV14
         PUT   SYSPRINT,LIST
         MVC   LIST,BLANKS
         L     R14,SV14
         BR    R14
*
*-- Examine the PARM field
*
*-- Entry: R8 contains the Register 1 address value at program entry.
*-- Exit:  CC=0  PARM field ok; DESTNODE & DESTUSER are valid.
*--        CC<>0 PARM field missing or otherwise coded incorrectly.
*
*-- Valid PARM field formats:  PARM=(NODE.USERID)
*--                            PARM=(NODE,USERID)
*--                            PARM='NODE USERID'
*
*-- NODE and USERID must be 1-8 characters.
*-- Apostrophes may be used in lieu of parenthesis in all cases.
*
PARM000  EQU   *
         L     R1,0(,R8)               -> PARM field
         LH    R2,0(,R1)               Get length of PARM field
         LTR   R2,R2                   Check length
         BZ    PARMERR                 No PARM field specified
         CH    R2,=H'3'                Is the length at least 3 char?
         BL    PARMERR                 Shorter cant be valid
         CH    R2,=H'17'               More than 17 char?
         BH    PARMERR                 Longer cant be valid
*
         BCTR  R2,0                    Adjust len for execute
         EX    R2,MVCPARM              Move parm field to work area
*MVCPARM MVC   MACLIST(0),2(R1)
*
         OC    MACLIST(17),BLANKS      Upper case the parm data
         MVC   TRTAB,BLANK             Set up translate table
         MVI   TRTAB+C'.',X'FF'        Also search for '.' chars
         MVI   TRTAB+C',',X'FF'        Also search for ',' chars
*
         LA    R1,0(,R1)               Clear high order byte
         TRT   MACLIST(18),NONBLANK    Look for first char
         BZ    PARMERR                 Invalid
         LR    R3,R1                   -> start of node id
         TRT   0(18,R1),TRTAB          Look for blank or '.' or ','
         BZ    PARMERR                 Invalid
         LA    R2,1(,R1)               -> position just past delimeter
         SR    R1,R3                   Compute node name length
         BNP   PARMERR                 Exit if invalid
         CH    R1,=H'8'                More than 8 char?
         BH    PARMERR                 It is invalid
*
         MVC   DESTNODE,BLANKS         Init receiving field
         BCTR  R1,0                    Adjust for execute
         EX    R1,MVCNODE              Move nodename
*MVCNODE MVC   DESTNODE(0),0(R3)
*
         LR    R3,R2                   -> start of userid
         TRT   0(9,R2),BLANK           Look for blank
         BZ    PARMERR                 Invalid
         SR    R1,R3                   Compute userid length
         BNP   PARMERR                 Exit if invalid
         CH    R1,=H'8'                More than 8 char?
         BH    PARMERR                 It is invalid
*
         MVC   DESTUSER,BLANKS         Init receiving field
         BCTR  R1,0                    Adjust for execute
         EX    R1,MVCUSER              Move nodename
*MVCUSER MVC   DESTUSER(0),0(R3)
*
         CLI   *+1,0                   Set CC=0
         BR    R14                     Return w/ DESTNODE&DESTUSER ok
*
PARMERR  EQU   *
         LTR   R12,R12                 Set CC non-zero
         BR    R14                     Errors in PARM field
*
MVCPARM  MVC   MACLIST(0),2(R1)        executed instr
MVCNODE  MVC   DESTNODE(0),0(R3)       executed instr
MVCUSER  MVC   DESTUSER(0),0(R3)       executed instr
*
*
*-- Look for ENQ QCB from NJE38
*
*-- Entry: None
*-- Exit:  CC=0  NJE38 is not active  (No matching ENQ found)
*--        CC<>0 NJE is active. R15->NJE38 CSA Block
*
CHK000   EQU   *
         LA    R1,NSPLDSN              -> where to place spool DSN v210
         L     R15,=V(NJESYS)          -> ENQ finder               v210
         BALR  R14,R15                 Check if NJE38 already act  v210
         LTR   R15,R15                 Set CC (RC=0 NJE38 active)  v210
         BNZR  R2                      Return if NJE38 inactive    v210
         MVC   LCLNODE,NJ38NODE-NJ38CSA(R1)  Save off lcl node namev210
         MVC   DEFUSER,NJ38DUSR-NJ38CSA(R1)  Save off default user v211
         BR    R2                      Return; NJE38 active        v210
*
*- Dynamically allocate the NETSPOOL dataset when there is no DD
*- statement and when NJE38 is active.
*
DYN000   EQU   *
         MVC   TXT1,TXT1D               INITIALIZE DDNAME TXT UNIT
         MVC   TXT2,TXT2D               INITIALIZE TXT UNIT
         MVC   TXT3,TXT3D               INITIALIZE TXT UNIT
         MVC   TXT4,TXT4D               INITIALIZE TXT UNIT
         LA    R1,TXT1                  POINT TO TEXT UNIT
         ST    R1,MACLIST               SET IN ADDRESS LIST
         LA    R1,TXT2                  POINT TO TEXT UNIT
         ST    R1,MACLIST+4             SET IN ADDRESS LIST
         LA    R1,TXT3                  POINT TO TEXT UNIT
         ST    R1,MACLIST+8             SET IN ADDRESS LIST
         LA    R1,TXT4                  POINT TO TEXT UNIT
         ST    R1,MACLIST+12            SET IN ADDRESS LIST
         OI    MACLIST+12,X'80'         SET VL
*
*-- Issue Dynalloc SVC
*
         ST    R14,DYNR14               SAVE RETURN REG
         MVC   LS99RB,CPS99RB           INIT THE S99RB
         LA    R1,LS99RB                POINT TO BLOCK
         USING S99RB,R1
         OI    S99FLAG1,S99NOCNV        FORCE NEW ALLOCATION
         ST    R1,LS99PTR               SET PARAMETER WORD
         OI    LS99PTR,X'80'            SET VL
         LA    R14,MACLIST              GET ADDRESS OF TEXT UNITS
         ST    R14,S99TXTPP             PUT IN S99RB
*
         LA    R1,LS99PTR               POINTER TO S99 PTR
         SVC   99                       ISSUE DYNALLOC
*
         LTR   R15,R15                  R15 non zero?
         BZ    DYN090                   No
*
         LA    R1,LS99RB
         UNPK  TWRK(9),S99ERROR(5)      Add zones to error code
         DROP  R1
         TR    TWRK(8),HEXTRAN-240
         MVC   LIST(L'MSG012),MSG012    Dyn alloc failure msg
         MVC   LIST+22(8),TWRK          Error codes to line
         MVC   LIST+36(44),NSPLDSN      Move DSNAME
         BAL   R14,PUT                  Write line
         CLI   *,0                      Set CC=non-zero
*
DYN090   EQU   *
         L     R14,DYNR14               Restore return addr
         BR    R14
*
FMT000   EQU   *
         STM   R14,R2,BALRSAVE         Save regs used
         MVC   LIST+0(L'MSG000),MSG000 Move msg text
         MVC   LIST+51(8),5(R12)       Move csect name
         TRT   LIST+51(9),BLANK        Look for end of csect name
         MVI   0(R1),C'+'
*
         LA    R15,0(,R14)  Clear high, Get addr of call to this rtn
         LA    R12,0(,R12)             Clear high byte
         SR    R15,R12                 Compute offset of call
         ST    R15,DBLE                Save to work area
         UNPK  TWRK(5),DBLE+2(3)       Add zones
         TR    TWRK(4),HEXTRAN-240     Display hex
         MVC   1(4,R1),TWRK            Move call offset to msg
*
         LA    R15,NCB1
         UNPK  TWRK(5),NCBRTNCD-NCB(3,R15)  Add zones
         TR    TWRK(4),HEXTRAN-240
         MVC   LIST+31(4),TWRK         Move rtncd/errcd
*
         UNPK  TWRK(3),NCBREQ-NCB(2,R15)  Add zones
         TR    TWRK(2),HEXTRAN-240
         MVC   LIST+41(2),TWRK         Move req code
*
         L     R1,NCBMACAD-NCB(,R15)   Get failing VSAM macro addr
         LA    R1,0(,R1)               Clear high byte
         S     R1,=V(NJESPOOL)         Compute offset into NJESPOOL rtn
         ST    R1,DBLE
         UNPK  TWRK(5),DBLE+2(3)       Add zones
         TR    TWRK(4),HEXTRAN-240     Display hex
         MVC   LIST+46(4),TWRK         Move NJESPOOL offset to msg
*
         PUT   SYSPRINT,LIST
         MVC   LIST,BLANKS
*
FMT090   EQU   *
         LM    R14,R2,BALRSAVE         Restore caller regs
         BR    R14                     Return
*
EXIT00   EQU   *
         SR    R5,R5
         B     QUIT000
*
EXIT08   EQU   *
         LA    R5,8
         B     QUIT000
*
QUIT000  EQU   *
         TM    FLAGS1,FL1OPEN          Is SYSUT1 open?
         BZ    QUIT010                 No
         MVC   MACLIST(CLOSEL),CLOSE   Move close list
         CLOSE (SYSUT1),               Close it                        X
               MF=(E,MACLIST)
*
QUIT010  EQU   *
         TM    FLAGS1,FL1NSPL          Is NETSPOOL open?
         BZ    QUIT020                 No
*                               ** This close is for error exit only **
         SR    R11,R11                 Ensure no tag data
         NSIO  TYPE=CLOSE,                                             x
               NCB=(R8),                                               x
               TAG=(R11)
*
QUIT020  EQU   *
         BAL   R14,PUT                 Write blank line
         MVC   LIST(L'MSG011),MSG011   Move ended RC=x msg
         CVD   R5,DBLE                 Convert RC
         UNPK  LIST+18(1),DBLE
         OI    LIST+18,X'F0'           Fix sign
         BAL   R14,PUT
*
         MVC   MACLIST(CLOSEL),CLOSE   Move close list
         CLOSE (SYSPRINT),                                             X
               MF=(E,MACLIST)
*
         LR    R1,R10                  -> NJEFWK work area
         L     R13,4(,R13)             -> CALLER'S SA
         FREEMAIN RU,                  Free the work area              X
               LV=NJEXSZ,                                              X
               A=(1)
*
         ST    R5,16(,R13)             Save R15 RC
         LM    R14,R12,12(R13)         RELOAD SYSTEM'S REGS
         BR    R14                     Return
*
         LTORG
*
DMYUT1   DCB   DDNAME=SYSUT1,                                          X
               MACRF=(GL),                                             X
               DSORG=PS,                                               X
               EODAD=EOD000
DMYUT1L  EQU   *-DMYUT1
*
DMYPRT   DCB   DDNAME=SYSPRINT,                                        X
               MACRF=(PM),                                             X
               DSORG=PS,                                               X
               LRECL=80,                                               X
               RECFM=FB,                                               X
               BLKSIZE=800
DMYPRTL  EQU   *-DMYPRT
*
OPEN     OPEN  0,MF=L
OPENL    EQU   *-OPEN
CLOSE    CLOSE 0,MF=L
CLOSEL   EQU   *-CLOSE
POST     POST  0,ASCB=0,ERRET=0,MF=L
POSTL    EQU   *-POST
*
NJE38Q   DC    CL8'NJE38'              QNAME
NJERCON  DC    CL8'NJEINIT'            RNAME (first 8 bytes)
*
* TEXT UNITS TO SET UP  //NETSPOOL DD DSN=DSNAME,DISP=SHR,FREE=CLOSE
*
TXT1D    DC    Y(DALDDNAM),AL2(1),AL2(8),CL8'NETSPOOL'   DDNAME
TXT2D    DC    Y(DALDSNAM),AL2(1),AL2(44)         DSNAME
TXT3D    DC    Y(DALSTATS),AL2(1),AL2(1),X'08'    DISP=SHR
TXT4D    DC    Y(DALCLOSE),AL2(0)                 FREE=CLOSE
*
         DS    0F
CPS99RB  DS    0XL20                   DEFINE INITIAL S99RB
         DC    AL1(20)                 LENGTH OF REQ BLOCK
         DC    AL1(1)                  VERB CODE:  ALLOCATION
         DC    X'20'                   FLAGS:  NO MOUNTS,OFFLINE VOLS
         DC    X'00'                   FLAGS
         DC    AL2(0)                  ERROR REASON CODE
         DC    AL2(0)                  INFO REASON CODE
         DC    A(0)                    ADDR OF TEXT PTRS
         DC    A(0)                    ADDR OF RBX
         DC    AL4(0)                  MORE FLAGS
*
*-- Translate table to validate Machine Carriage Control
*-- Any code not in the table will be replaced by single space 09 code
*
PRTCC    EQU   *  0 1 2 3 4 5 6 7 8 9 A B C D E F
         DC    X'09010909090909090909090B09090909' 0  01,09,0b
         DC    X'09110913090909090919091B09090909' 1  11,13,19,1b
         DC    X'09090909090909090909090909090909' 2
         DC    X'09090909090909090909090909090909' 3
         DC    X'09090909090909090909090909090909' 4
         DC    X'09090909090909090909095B09090909' 5  5b
         DC    X'09090909090909090909090909090909' 6
         DC    X'09090909090909090909090909090909' 7
         DC    X'09810983090909090989098B09090909' 8  81,83,89,8b
         DC    X'09910993090909090999099B09090909' 9  91,93,99,9b
         DC    X'09A109A30909090909A909AB09090909' A  a1,a3,a9,ab
         DC    X'09B109B30909090909B909BB09090909' B  b1,b3,b9,bb
         DC    X'09C109C30909090909C909CB09090909' C  c1,c3,c9,cb
         DC    X'09D109D30909090909D909DB09090909' D  d1,d3,d9,db
         DC    X'09E109E3090909090909090909090909' E  e1,e3
         DC    X'09090909090909090909090909090909' F
*
*                012345678901234567890123456789 01234 56789012345678901
MSG000   DC    C'ERROR:  NETSPOOL RTNCD/ERRCD=X''0000'',REQ=01,O=1234,Mx
               MMMMMMM     '
*
MSG001   DC    C'NJ38XMIT - NJE38 File Transmit Utility'
*                0123456789012345678901234567890123456789012 345 6789
MSG002   DC    C'Open failed for NETSPOOL, RC=xx,ACBERFLG=X''xx'''
*                012345678901234567890123456789012345678901234567 8901
MSG003   DC    C'PUT failed writing record xxxxxxx, RTNCD-FDBK=X''xxxx'x
               ''
MSG004   DC    C'Invalid or missing ''NODE.USERID'' in the JCL EXEC PARx
               M field'
MSG005   DC    C'Unable to determine NETSPOOL dsname'
MSG005A  DC    C'Start NJE38 and resubmit this job'                v220
MSG006   DC    C'Unable to open SYSUT1'
MSG007   DC    C'RECFM=U datasets are not supported'
MSG008   DC    C'LRECL of the SYSUT1 dataset is too large for NJE transx
               mission'
MSG008A  DC    C'The maximum allowed LRECL is 133 bytes with a carriagex
                control byte,'
MSG008B  DC    C'or 132 bytes with no carriage control byte'
MSG009   DC    C'Local node:'
MSG010   DC    C'records queued for '
MSG011   DC    C'NJ38XMIT ends; RC=x'
MSG012   DC    C'Dyn. allocation error xxxxxxxx, DSN='
MSG013   DC    C'File destinations to local node rejected'
*                0123456789012345678901234567890123456789012345678901
*
BLANKS   DC    CL80' '
BLANK    DC    64X'00',X'FF',191X'00'
NONBLANK DC    64X'FF',X'00',191X'FF'
HEXTRAN  DC    CL16'0123456789ABCDEF'
*
*
*
*
*
NJEXWK   DSECT
NJEEYE   DS    CL4'NJEX'               EYECATCHER
NJEWKLEN DS    F                       SIZE OF WORK AREA
*
NJESA    DS    18F
BALRSAVE DS    16F
LCLNODE  DS    CL8                     Local node name
DEFUSER  DS    CL8                     Default user if no security v130
DBLE     DS    D
TWRK     DS    XL16
MACLIST  DS    XL128
NCB1     DS    XL48
LIST     DS    CL80                    PRINT LINE
DESTNODE DS    CL8                     Destination node name
DESTUSER DS    CL8                     Destination user id
SV14     DS    F                       R14 save area
DYNR14   DS    A                       R14 SAVE AREA
LS99PTR  DS    A                       PTR TO S99RB
LS99RB   DS    XL20                    SPACE FOR S99RB
*
*
TXT1     DS    0XL14,Y,AL2,AL2         SPACE FOR THE DDNAME TEXT UNIT
DDNAME   DS    CL8                      DDNAME
*
TXT2     DS    0XL06,Y,AL2,AL2         DSN=
NSPLDSN  DS    CL44                     NETSPOOL DSNAME
*
TXT3     DS    0XL07,Y,AL2,AL2,X       DISP=SHR
TXT4     DS    0XL04,Y,AL2             FREE=CLOSE
*
LRECL    DS    H                       LRECL of SYSUT1 file
*
FLAGS1   DS    X
FL1OPEN  EQU   X'80'      1... ....    SYSUT1 is open
FL1NSPL  EQU   X'40'      .1.. ....    NETSPOOL is open
FL1NACEE EQU   X'10'      ...1 ....    NOACEE specified (debug onlyv130
FL1CA    EQU   X'04'      .... .1..    Records contain ASA car ctl
FL1CM    EQU   X'02'      .... ..1.    Records contain Mach car ctl
*                         ..x. x..x    Available                   v130
*
DATATYPE DS    X                       PRT/PUN type
TYPPRT   EQU   X'40'                   PRT dev
TYPPUN   EQU   X'80'                   PUN dev
*
DATABUF  DS    CL133                   Area for a print line
TDATA    DS    XL108                   TAG data area
SYSUT1   DS    (DMYUT1L)X              SYSUT1 DCB
SYSPRINT DS    (DMYPRTL)X              SYSPRINT DCB
TRTAB    DS    CL256                   Translate table area
         DS    0D                      Force doubleword boundary
NJEXSZ   EQU   *-NJEXWK                Size of work area
*
*-- System DSECTs
*
*
         CVT   DSECT=YES,LIST=NO
         IHAPSA
         IKJTCB
IEFTIOT  DSECT
         IEFTIOT1
         IEESMCA
         IEFZB4D0
         IEFZB4D2
         IHAASCB
         IHAASXB
*
ACEE     DSECT                         Maps a portion of ACEE in MVS3.8
ACEEEYE  DS    CL4'ACEE'
         DS    16X
ACEEUSRL DS    X                       Length of userid
ACEEUSR  DS    CL8                     Userid
*
         DCBD  DSORG=PS,DEVD=DA
         COPY  NETSPOOL
         COPY  TAG
         COPY  LINKTABL
*
*-- NJE38 DSECTs
*
         NJEWRE                                                    v220
         END
./ ADD NAME=NJE38
*
*
*-- NJE38 - TSO Command Module
*
*
*   This program is invoked by TSO users wishing to enter commands
*   or messages to NJE38 or remote nodes.
*
*   This module must reside in SYS1.CMDLIB or equivalent and be
*   available to TSO
*
*
* Change log:
*
* 15 Feb 21 - Not picking up jobname when run as an STC.           v221
* 10 Dec 20 - Support for registered users and message queuing     v220
* 01 Oct 20 - Put ENQ existence check in common module             v210
* 10 Jul 20 - Switch to PUTLINE to support batch mode              v200
* 10 Jul 20 - Use default config userid if running batch + no ACEE v200
* 02 Jun 20 - Get TSO userid from TIOT if there is no ACEE.        v130
*
*
         REGEQU
NJE38    CSECT
         NJEVER
         STM   R14,R12,12(R13)         SAVE CMS REGS
         LR    R12,R15                 BASE
         USING NJE38,R12               ADDRESS IT
*
         LR    R8,R1                   Save entry parms            v200
*
         GETMAIN RU,                   GET LOCAL STG AREA              X
               LV=NJEXSZ
         LR    R10,R1
         LR    R1,R0                   COPY LENGTH
         LR    R2,R0                   COPY LENGTH
         LR    R0,R10                  -> NEW STG AREA
         SR    R15,R15                 SET PAD
         MVCL  R0,R14                  CLEAR THE PAGE
*
         USING NJEXWK,R10
         ST    R13,NJESA+4             SAVE PRV S.A. ADDR
         LA    R1,NJESA                -> MY SAVE AREA
         ST    R1,8(,R13)              PLUG IT INTO PRIOR SA
         LR    R13,R1
         ST    R8,CPARMS               Save entry parms
*
INIT000  EQU   *
         MVC   NJEEYE,=CL4'NJEX'       Work area eyecatcher
         ST    R2,NJEWKLEN             Save size of area
         MVI   MTEXT,C' '              Init cmd buffer receiving field
         MVC   MTEXT+1(255),MTEXT      Pad it
*
         TESTAUTH FCTN=1               Are we authorized on entry?
         LTR   R15,R15                 Check result
         BNZ   INIT010                 Branch if not authorized
         OI    FLAGS1,FLG1APF          Indicate authorized on entry
*
INIT010  EQU   *
         L     R2,PSATOLD-PSA(0)       -> my TCB                   v130
         L     R2,TCBTIO-TCB(R2)       -> my TIOT                  v130
         LA    R4,TIOCNJOB-IEFTIOT(R2) -> TIOT jobname             v220
         LR    R3,R4                   Make the TIOT jobname the idv221
*
         L     R2,PSAAOLD-PSA(0)       -> my ASCB
         L     R6,ASCBTSB-ASCB(,R2)    -> TSB (or 0)               v200
         L     R2,ASCBASXB-ASCB(,R2)   -> my ASXB
         ICM   R2,15,ASXBSENV-ASXB(R2) -> my ACEE                  v130
         BZ    INIT015                 Exit if no ACEE             v130
*
         USING ACEE,R2                                             v130
         CLI   ACEEUSRL,X'00'          No userid available?        v130
         BE    INIT015                 Exit if unavail             v130
         CLI   ACEEUSR,X'00'           Userid not formed correctly?v130
         BE    INIT015                 Exit if unavail             v130
         LA    R3,ACEEUSR              -> Userid                   v130
         OI    FLAGS1,FLG1ACEE         Indicate security enabled   v200
         CLC   ACEEUSR,=CL8'STC'       Is this a started task?     v220
         BNE   INIT015                 No, use ACEEUSR id          v220
         LR    R3,R4                   Make the TIOT jobname the idv220
         DROP  R2                      ACEE                        v130
*
INIT015  EQU   *                                                   v130
         MVC   USERID,0(R3)            Respond to userid for commands
         MVC   ORIGID,0(R3)            Origin id of this WRE
         CLC   USERID,=CL8'HERC01'     Special access id?
         BE    INIT020                 Yes
         CLC   USERID,=CL8'HERC02'     Special access id?
         BNE   INIT030                 No
*
INIT020  EQU   *
         OI    FLAGS1,FLG1AUSR         Indicate special authorized usrs
         B     INIT040
*
INIT030  EQU   *
         TM    FLAGS1,FLG1APF          Authorized at entry?
         BZ    ERR006
*
INIT040  EQU   *
         BAL   R2,CHK000               See if NJE38 is active      v210
         BNZ   ERR001                  No                          v210
         ST    R1,CSABLK               Save CSABLK addr            v210
         MVC   LCLNODE,NJ38NODE-NJ38CSA(R1)  Save off lcl node namev210
         MVC   DEFUSER,NJ38DUSR-NJ38CSA(R1)  Save off default id   v210
*
         LA    R6,0(,R6)               Clear high order byte       v200
         LTR   R6,R6                   Was there a TSB address?    v200
         BNZ   PARM000                 Yes. Running in TSO userid  v200
         TM    FLAGS1,FLG1ACEE         Valid ACEE found?           v200
         BO    PARM000                 Yes, userid already set     v200
         MVC   USERID,DEFUSER          No, Use default userid      v200
         MVC   ORIGID,DEFUSER          Origin id of this WRE       v200
*
PARM000  EQU   *
         L     R8,CPARMS               -> entry parms              v200
         L     R8,0(,R8)               -> command buffer           v200
         LH    R1,0(,R8)               Get length of cmd buffer
         LH    R2,2(,R8)               Get offset to params
         SR    R1,R2                   Less offset
         C     R1,=F'5'                Determine if no params entered
         BL    ERR002                  None were entered
*
         S     R1,=F'4'                Adjust for len overhead
         C     R1,=F'120'              Over max size allowed?
         BL    *+8                     No
         LA    R1,120                  Force to len 120
*
         LA    R2,4(R2,R8)             -> first parameter byte
         BCTR  R1,0                    Adjust for execute
         EX    R1,MVPRM                Move it to our buffer
         LA    R5,MTEXT+1(R1)          -> end of cmd buffer
*
         TRT   MTEXT,NONBLANK          Look for first char
         BZ    ERR003                  Invalid command format
         LR    R3,R1                   -> first char
         TRT   0(120,R3),BLANK         Look for end of 1st param
         BZ    ERR003                  Invalid
         LR    R4,R1                   Copy -> to the blank
*
         SR    R1,R3                   Compute 1st parm length
         BNP   ERR003                  Invalid command format
         C     R1,=F'8'                More than 8 char?
         BH    ERR003                  Invalid command format
         MVC   KEYWD,BLANKS            Init receiving field
         BCTR  R1,0                    Adjust for execute
         EX    R1,MVKEY                Save off and upprcase param
*
         MVI   REQTYPE,WRECMD          Assume this is a command request
         MVI   REQCODE,X'B0'           Assume this is a command request
         CLC   KEYWD,=CL8'CMD'         is this the CMD command?
         BE    PARM100                 Y, additional parsing needed
*
         CLC   KEYWD,=CL8'MSG'         is this the MSG command?
         BE    PARM200                 Y, additional parsing needed
         CLC   KEYWD,=CL8'M'           is this the MSG command?
         BE    PARM200                 Y, additional parsing needed
*
*-- Here if command is for the local node
*
         MVC   NODEID,LCLNODE          Use local node id
*
PARM020  EQU   *
         LR    R4,R3                   -> start of cmd txt
         SR    R5,R4                   Compute len of cmd text portion
         B     SND000
*
*-- Here if a specific node name specified
*
PARM100  EQU   *
         TRT   0(120,R4),NONBLANK      Look for first char of nodeid
         BZ    ERR004                  Invalid nodeid
         LR    R3,R1                   -> first char
         TRT   0(120,R3),BLANK         Look for end of param
         BZ    ERR004                  Invalid
         LR    R4,R1                   Copy -> to the blank
*
         SR    R1,R3                   Compute parm length
         BNP   ERR004                  Invalid command format
         C     R1,=F'8'                More than 8 char?
         BH    ERR004                  Invalid command format
         MVC   NODEID,BLANKS           Init receiving field
         BCTR  R1,0                    Adjust for execute
         EX    R1,MVNOD                Save off and upprcase node id
*
         TRT   0(120,R4),NONBLANK      Look for first char of next
         BZ    ERR003                  Something wrong with command txt
         LR    R4,R1                   -> start of remaining cmd txt
         SR    R5,R4                   Compute len of cmd text portion
         B     SND000
*
*-- Here for msg processing
*
PARM200  EQU   *
         TRT   0(120,R4),NONBLANK      Look for first char of nodeid
         BZ    ERR004                  Invalid nodeid
         LR    R3,R1                   -> first char
         TRT   0(120,R3),BLANK         Look for end of param
         BZ    ERR004                  Invalid
         LR    R4,R1                   Copy -> to the blank
*
         SR    R1,R3                   Compute parm length
         BNP   ERR004                  Invalid command format
         C     R1,=F'8'                More than 8 char?
         BH    ERR004                  Invalid command format
         MVC   NODEID,BLANKS           Init receiving field
         BCTR  R1,0                    Adjust for execute
         EX    R1,MVNOD                Save off and upprcase node id
*
         TRT   0(120,R4),NONBLANK      Look for first char of userid
         BZ    ERR005                  Invalid userid
         LR    R3,R1                   -> first char
         TRT   0(120,R3),BLANK         Look for end of param
         BZ    ERR005                  Invalid
         LR    R4,R1                   Copy -> to the blank
*
         SR    R1,R3                   Compute parm length
         BNP   ERR005                  Invalid command format
         C     R1,=F'8'                More than 8 char?
         BH    ERR005                  Invalid command format
         MVC   USERID,BLANKS           Init receiving field
         BCTR  R1,0                    Adjust for execute
         EX    R1,MVUSR                Save off and upprcase user id
*
         TRT   0(120,R4),NONBLANK      Look for first char of next
         BZ    ERR003                  Something wrong with command txt
         LR    R4,R1                   -> start of remaining cmd txt
         SR    R5,R4                   Compute len of cmd text portion
*
         CLC   NODEID,=CL8'*'          Sending msg to local user?
         BE    PARM210                 Yes
         CLC   NODEID,LCLNODE          Sending msg to local user?
         BNE   PARM220                 No
*
PARM210  EQU   *
         LA    R15,USERID              ->
         BAL   R14,USR800              Check if user logged on
*        BZ    ERR007                  He isnt; skip sending msg
   BC    0,ERR007  SPECIAL
*
PARM220  EQU   *
         MVI   REQTYPE,WREMSG          This is a message WRE
         MVI   REQCODE,X'B1'           This is a message request
         B     SND000
*
MVPRM    MVC   MTEXT(0),0(R2)
MVKEY    OC    KEYWD(0),0(R3)
MVNOD    OC    NODEID(0),0(R3)
MVUSR    OC    USERID(0),0(R3)
*
SND000   EQU   *
         CLC   NODEID,=CL8'*'          Using * for node name?
         BNE   SND010                  No
         MVC   NODEID,LCLNODE          Yes, use local node name
*
SND010   EQU   *
         TM    FLAGS1,FLG1APF          Authorized at entry?
         BO    SND020                  Y, Don't need Auth SVC
         SR    0,0                     Use authorization SVC
         LA    1,1                      For HERC01/HERC02 only
         SVC   244                     Get authorized
*
SND020   EQU   *
         MODESET KEY=ZERO,MODE=SUP
*
         GETMAIN RU,LV=WRESIZE,SP=241                              v220
         LR    R8,R1               -> WRE
         USING WRE,R8
         XC    0(WRESIZE,R8),0(R8)                                 v220
         MVI   WRESP,241           Set subpool                     v220
         MVC   WRECODE,REQCODE     Set type of request to NJE hdrs
         MVC   WRETYPE,REQTYPE     CMD or MSG
         MVC   WRELINK,NODEID      Set target node to send CMD/MSG to
         MVC   WREUSER,USERID      CMD: Set userid to recv response
*                                  MSG: Set userid to send msg to
         MVC   WREORIG,ORIGID      MSG: Set userid to receive response
*
         MVC   WRETXT,BLANKS       Init receiving field
         STC   R5,WRETXTLN         Set text portion length
         CLI   WRETYPE,WREMSG      Is this a message?
         BE    SND090              Yes, dont uppercase it
         EX    R5,MVCMD            Move and uppercase cmd text to WRE
         B     PST000
*
SND090   EQU   *
         EX    R5,MVMSG            Move msg text to WRE
         B     PST000
*
MVCMD    OC    WRETXT(0),0(R4)     Executed
MVMSG    MVC   WRETXT(0),0(R4)     Executed
*
*
PST000   EQU   *
         L     R4,CSABLK           Get CSABLK ptr
         USING NJ38CSA,R4
         LM    R0,R1,NJ38SWAP      Get first WRE ptr, sync count
*
PST020   EQU   *
         ST    R0,WRENEXT          First WRE becomes next
         LA    R9,1(,R1)           Incr synchronization count
         CDS   R0,R8,NJ38SWAP      Update LINK WRE anchor, sync
         BC    7,PST020            Gotta try again
*
         L     R7,NJ38ASCB     -> NJE38's ASCB
         LA    R6,NJ38ECB      -> NJE38 external comm ecb
         DROP  R4                  NJ38CSA
         DROP  R8                  WRE
*
         MVC   MACLIST(POSTL),POST    Move macro mode
         POST  (6),            Post NJE38's external ECB               x
               ASCB=(7),                                               x
               ERRET=PST080,                                           x
               ECBKEY=0,                                               x
               MF=(E,MACLIST)
*
PST080   EQU   *
         MODESET KEY=NZERO
*
         TM    FLAGS1,FLG1APF          Authorized at entry?
         BO    PST090                  Y, Don't need Auth SVC
         SR    0,0                     Use authorization SVC
         SR    1,1                      For HERC01/HERC02 only
         SVC   244                     Get un-authorized
*
PST090   EQU   *
         B     EXIT00          Done                                v200
*
*
*-- Get status of NJE38
*
*-- Entry: R1=0 (no spool dsn needed), or, R1-> 44-char spool DSN area
*-- Exit:  RC=0  NJE38 is active; R1-> NJE38 CSA block
*--        RC<>0 NJE is not active.
*
CHK000   EQU   *
         SR    R1,R1                   Dont return spool DSN       v210
         L     R15,=V(NJESYS)          -> ENQ finder               v210
         BALR  R14,R15                 Check if NJE38 already act  v210
         LTR   R15,R15                 Set CC (RC=0 NJE38 active)  v210
         BR    R2                      Return w/ CSA ptr in R1     v210
*
*-- Search CSCB chain to see if TSO user is logged on
*-- Entry:  R15->8-byte padded field containing TSO userid to find
*-- Exit:  CC=0  user was not logged on
*--        CC<>0 user is logged on
*
USR800   EQU   *
         CLC   =CL8'OP',0(R15)     Is the userid the operator?
         BE    USR890              Yes, let it thru
         L     R1,16               Get CVT ptr
         USING CVT,R1
         L     R1,CVTASCBH         -> highest prty ASCB
         USING ASCB,R1
*
USR810   EQU   *
         L     R2,ASCBCSCB         -> CSCB
         USING CSCB,R2
         LTR   R2,R2               Is there a CSCB?
         BZ    USR840              No, get next ASCB
*
USR820   EQU   *
         CLC   CHKEY,=XL8'00'      Jobname zeroed?
         BE    USR830              Y, skip this CSCB
         CLC   CHKEY,=CL8' '       Jobname is blank?
         BE    USR830              Y, skip this CSCB
         CLC   CHKEY,0(R15)        Is this the userid?
         BE    USR890              Yes
USR830   EQU   *
         L     R2,CHPTR            -> next CSCB
         LA    R2,0(,R2)           Clear high order
         LTR   R2,R2               Last CSCB?
         BNZ   USR820              No
         BR    R14                 Return with CC=0 (not found)
*
USR840   EQU   *
         L     R1,ASCBFWDP         -> next ASCB
         LTR   R1,R1               last one?
         BNZ   USR810              No
         BR    R14                 Return with CC=0 (not found)
*
USR890   EQU   *
         LTR   R14,R14             Set CC=non zero (userid found)
         BR    R14                 Return to caller
*
         DROP  R1                  ASCB
         DROP  R2                  CSCB
*
*-- Write a single line to terminal
*
*-- Entry: R2 -> output msg (RDW+msg text)
*-- Exit:  R15 = RC from PUTLINE
*
PUTLINE  EQU   *
         ST    R14,SV14LN              Save return
         XC    PUTECB,PUTECB           Clear PUTLINE ECB
         L     R15,CPARMS              -> command input CPPL
         USING CPPL,R15
         LA    R1,IOPLAREA             -> IOPL
         USING IOPL,R1
         MVC   IOPLUPT,CPPLUPT         Set UPT ptr
         MVC   IOPLECT,CPPLECT         Set ECT ptr
         DROP  R15                     CPPL
*
         MVC   TWRK(PBL),PB            Move macro model
         PUTLINE PARM=TWRK,            Write a line                    x
               ECB=PUTECB,                                             x
               OUTPUT=((R2),TERM,SINGLE,DATA),                         x
               MF=(E,(1))
         DROP  R1                      IOPL
         L     R14,SV14LN              Load return
         BR    R14
*
ERR001   EQU   *
         LA    R2,MSG001                                           v200
         B     ERRPUT
*
ERR002   EQU   *
         LA    R2,MSG002                                           v200
         B     ERRPUT
*
ERR003   EQU   *
         LA    R2,MSG003                                           v200
         B     ERRPUT
*
ERR004   EQU   *
         LA    R2,MSG004                                           v200
         B     ERRPUT
*
ERR005   EQU   *
         LA    R2,MSG005                                           v200
         B     ERRPUT
*
ERR006   EQU   *
         LA    R2,MSG006                                           v200
         B     ERRPUT
*
ERR007   EQU   *
         LA    R2,MSG007                                           v200
*
ERRPUT   EQU   *                                                   v200
         BAL   R14,PUTLINE             Issue msg                   v200
         LA    R15,8                   Set RC                      v200
         B     QUIT000                 And exit                    v200
*
EXIT00   EQU   *                                                   v200
         SR    R15,R15                 RC=0                        v200
*
QUIT000  EQU   *
         LR    R1,R10                  -> NJEFWK work area
         L     R13,4(,R13)             -> CALLER'S SA
         ST    R15,16(,R13)            Set RC                      v200
         FREEMAIN RU,                  Free the work area              X
               LV=NJEXSZ,                                              X
               A=(1)
*
         LM    R14,R12,12(R13)         RELOAD SYSTEM'S REGS
         BR    R14                     Return
*
         LTORG
*
*
NJE38Q   DC    CL8'NJE38'
NJERCON  DC    CL8'NJEINIT'
BLANKS   DC    CL120' '
HEXTRAN  DC    CL16'0123456789ABCDEF'
BLANK    DC    64X'00',X'FF',191X'00'
NONBLANK DC    64X'FF',X'00',191X'FF'
*
MSG001   DC    Y(L'MSG001T+4,0)                                    v200
MSG001T  DC    C'NJE38 is not active'                              v200
*
MSG002   DC    Y(L'MSG002T+4,0)                                    v200
MSG002T  DC    C'No parameters entered'                            v200
*
MSG003   DC    Y(L'MSG003T+4,0)                                    v200
MSG003T  DC    C'Invalid command format or missing text'           v200
*
MSG004   DC    Y(L'MSG004T+4,0)                                    v200
MSG004T  DC    C'Invalid nodeid'                                   v200
*
MSG005   DC    Y(L'MSG005T+4,0)                                    v200
MSG005T  DC    C'Invalid userid'                                   v200
*
MSG006   DC    Y(L'MSG006T+4,0)                                    v200
MSG006T  DC    C'The NJE38 command is not APF-authorized'          v200
*
MSG007   DC    Y(L'MSG007T+4,0)                                    v200
MSG007T  DC    C'User is not logged on'                            v200
*
POST     POST  0,ASCB=0,ERRET=0,MF=L
POSTL    EQU   *-POST
PB       PUTLINE MF=L                                              v200
PBL      EQU   *-PB                                                v200
*
*
NJEXWK   DSECT
NJEEYE   DS    CL4'NJEX'               EYECATCHER
NJEWKLEN DS    F                       SIZE OF WORK AREA
*
NJESA    DS    18F
BALRSAVE DS    16F
LCLNODE  DS    CL8                     Local node name
DEFUSER  DS    CL8                     Default userid from config  v200
NODEID   DS    CL8                     Destination node name
USERID   DS    CL8                     Destination user name
ORIGID   DS    CL8                     Originating user of msg
KEYWD    DS    CL8                     1st parameter keyword
DBLE     DS    D
TWRK     DS    XL16
MACLIST  DS    XL128
IOPLAREA DS    4A                      IOPL for PUTLINE            v200
SV14     DS    F                       R14 save area
SV14LN   DS    F                       R14 save area               v200
PUTECB   DS    F                       ECB for PUTLINE             v200
CSABLK   DS    A                       -> NJE38 CSA block
CPARMS   DS    A                       TSO command entry parms     v200
*
REQTYPE  DS    X                       WRE type (CMD/MSG)
REQCODE  DS    X                       XJE request type (CMD/MSG)
FLAGS1   DS    X
FLG1APF  EQU   X'80'      1... ....    APF authorized on entry
FLG1AUSR EQU   X'40'      .1.. ....    Current user is HERC01 or HERC02
FLG1ACEE EQU   X'20'      ..1. ....    Valid ACEE found            v200
*                         ...x xxxx    Available
*
MTEXT    DS    CL256
         DS    0D                      Force doubleword boundary
NJEXSZ   EQU   *-NJEXWK                Size of work area
*
*
*-- System DSECTs
*
*
         CVT   DSECT=YES,LIST=YES
         IHAPSA
         IHAASCB
         IHAASXB
CSCB     DSECT
         IEECHAIN                      MAP FOR A CSCB
         IKJTCB                                                    v130
IEFTIOT  DSECT                                                     v130
         IEFTIOT1                                                  v130
         IKJUPT                                                    v200
         IKJCPPL                                                   v200
         IKJIOPL                                                   v200
*
ACEE     DSECT                         Maps a portion of ACEE in MVS3.8
ACEEEYE  DS    CL4'ACEE'
         DS    16X
ACEEUSRL DS    X                       Length of userid
ACEEUSR  DS    CL8                     Userid
*
         COPY  NETSPOOL
*
*-- NJE38 DSECTs
*
         NJEWRE                                                    v220
         END   NJE38
./ ADD NAME=NJECMX
*
*
*-- NJE38 - Command Processor
*
*
*   Called by NJEINIT (for commands entered from Console or TSO users)
*   Called by NJEDRV (for commands entered by remote users)
*
*
* Change log:
*
* 10 Dec 20 - Support for registered users and message queuing     v220
* 04 Dec 20 - Expanded internal trace table support                v212
* 02 Dec 20 - New command "D nodeid"                               v211
* 29 Nov 20 - Use text-based configuration; alternate routes       v211
* 02 Oct 20 - Use actual length for MGCR SEND cmds                 v210
* 01 Oct 20 - CPLEVEL clarity                                      v210
* 10 Aug 20 - Use single NJESPOOL load for all STC NJE38 modules.  v210
* 23 Jul 20 - Display spool percentage full after D FILES.         v200
* 21 Jul 20 - Don't execute commands from a non-LINK or ROUTE node.v200
* 21 Jul 20 - D AUTH command now requires authorization.           v200
* 02 Jun 20 - Display of RECFM shows blanks for some VM files.     v130
* 02 Jun 20 - Unable to issue some commands to node names that     v130
*              begin with a numeric digit.                         v130
* 20 May 20 - Add RESET filenum command to change destination.     v120
* 17 May 20 - Error in msg N026F length causes RSCS v1 PIC 5 crash.v110
* 14 May 20 - Add support file D filenum command.                  v110
* 08 May 20 - Assembly date and time to CPQ CPLEVEL response.      v110
* 08 May 20 - Cancel file# causes Abend U0039 if spool empty.      v110
* 07 May 20 - Growing pains: split into CSECTs.                    v110
* 06 May 20 - Node name missing from MSG NJE014I w/ empty spool.   v102
* 06 May 20 - MSG NJE025I not displayed if no AUTH users defined.  v102
* 05 May 20 - Abend SD23 if SVC 34 parmlist >=130 bytes.           v102
* 05 May 20 - Incorrect handling of TSO userids with 7-characters. v102
*
*
         GBLC  &VERS
         REGEQU
NJECMX   CSECT
         NJEVER
         STM   R14,R12,12(R13)         Save Regs
         LR    R12,R15                 Base
         USING NJECMX,R12
         LR    R7,R0                   Save input code
         LR    R8,R1                   Save input parm list addr
*
         GETMAIN RU,                   Get local stg area              X
               LV=4096,                                                X
               BNDRY=PAGE
         LR    R10,R1
         LR    R1,R0                   Copy length
         LR    R2,R0                   Copy length
         LR    R0,R10                  -> new stg area
         SR    R15,R15                 set pad
         MVCL  R0,R14                  Clear the page
*
         USING NJEWK,R10
         ST    R13,NJESA+4             SAVE prv S.A. ADDR
         LA    R1,NJESA                -> my save area
         ST    R1,8(,R13)              Plug it into prior SA
         LR    R13,R1
*
         MVC   NJEEYE,=CL4'NJEC'       Work area eyecatcher
         ST    R2,NJEWKLEN             Save size of area in area
         L     R11,=A(NJECOM)          -> common csect
         USING NJECOM,R11
*
         MVC   INITPARM,0(R8)          Copy passed parameters
         STC   R7,TARGET               Sav 'who gets the response' code
         L     R8,ACMDBLOK             -> CMDBLOK
         USING CMDBLOK,R8
*
         L     R15,=A(NJECMC)          -> control cmds processing
         BALR  R14,R15
         LTR   R15,R15                 Any RC returned?
         BZ    QUIT                    No, we're done here
*
         L     R15,=A(NJECMG)          -> general commands processing
         BALR  R14,R15
*
QUIT     EQU   *
         LR    R1,R10                  -> NJEWK main work area page
         L     R13,4(,R13)             -> caller's sa
         FREEMAIN RU,                                                  x
               LV=4096,                                                x
               A=(1)
         LM    R14,R12,12(R13)         Reload system's regs
         XR    R15,R15                 RC=0
         BR    R14                     Return
         DROP  R12
         LTORG ,
*
*********************
*  N J E C O M      *               NJECOM hosts small routines and
*                   *               frequently used constants that
*  Common routines  *               are available to all NJECxx csects
*  and constants    *               via base register 11
*                   *
*********************
*
NJECOM   CSECT
         DC    A(0)                 No branch around constants
         DC    AL1(23)                LENGTH OF EYECATCHERS
         DC    CL9'NJECOM'
         DC    CL9'&SYSDATE'
         DC    CL5'&SYSTIME'
         USING NJECOM,R11
         USING CMDBLOK,R8
*
*-- Check userid/nodeid in authorization table
*    Entry:  None
*    Exit:   CC = 0  User not in AUTH list
*            CC<>0   User in AUTH list and may execute command
*
CHKAUTH  EQU   *
         CLC   CMDLINK,LCLNODE      Checking against local user?   v211
         BNE   CHKA010              No, do full auth check
         CLC   CMDVMID,=CL8'OP'     Local operator?
         BE    CHKA030              Yes, always authorized
*
CHKA010  EQU   *
         L     R1,AAUTHS            -> AUTHLIST chain anchor       v211
         ICM   R1,15,0(R1)          -> AUTHLIST chain              v211
         BZR   R14                  If 0, no authorization
         USING AUTHLIST,R1                                         v211
         CLC   CMDVMID,BLANKS       Null user (RSCS console) ?     v211
         BNE   CHKA020              No                             v211
         MVC   CMDVMID,=CL8'$RSCS'  Look for this name in AUTH listv211
*
*
CHKA020  EQU   *
         CLC   CMDVMID,AUTHUSER     Is userid in auth list?        v211
         BNE   CHKA090              No, scan next
         CLC   CMDLINK,AUTHNODE     Is nodeid in auth list?        v211
         BNE   CHKA090              No, scan next
*
CHKA030  EQU   *
         CLI   *,1                  Set CC to non-zero:  AUTHORIZED
         BR    R14                  Return with CC set
*
CHKA090  EQU   *
         ICM   R1,15,AUTHPTR        -> next auth entry             v211
         BNZ   CHKA020              Go check the next one          v211
         BR    R14                  CC=0: NOT AUTHORIZED           v211
         DROP  R1
*
*
*-- Stack a message on a chain for DMTXJE to transmit to a remote
*-- user over a link. (Messages are unstacked by NJEGMQ when DMTXJE
*-- requests that function).
*
* On entry:
*
*    R1 contains true length of message text to stack.
*    MTEXT contains the message text.
*
ISSUE000 EQU   *
         ST    R14,SVR14I          Save return addr                v220
         STM   R2,R3,SV23          Save across function
         LR    R3,R1               Message text length to R3
         CLI   TARGET,TGTCONS      Is response destined for console?
         BE    ISSUE100            Yes
*
ISSUE010 EQU   *
         L     R0,RQENUM           Get # of RQEs                   v210
         L     R1,ARQESTG          Get ptr to first RQE            v210
         USING RQE,R1
*
ISSUE020 EQU   *
         CLC   RQEOWN,=A(0)        Look for empty RQE
         BE    ISSUE030            Got one
         LA    R1,RQESZ(,R1)       -> next RQE
         BCT   R0,ISSUE020
U0045    ABEND 45,DUMP,STEP
*
ISSUE030 EQU   *
         L     R2,XJELINK          -> this task's LINKTABL entry
         SR    R0,R0               Look for owner word value of 0
         CS    R0,R2,RQEOWN        Set owner to LINKTABL addr
         BC    4,ISSUE010          CC=1; owner non-zero, look again
*
         XC    RQEDATA(256),RQEDATA       Init area
         XC    RQEDATA+256(4),RQEDATA+4   Init area
*
         USING STACKMSG,R1
         MVC   STKNODE,CMDLINK     Move node name to respond to
         MVC   STKID,CMDVMID       Move user name to respond to
         MVC   STKMSG(120),MTEXT   Move msg to stacked stg area
         LA    R3,L'STKNODE+L'STKID(R3) Compute stacked length
         STC   R3,STKLEN           Store in block
         DROP  R1                  STACKMSG
*
         LA    R2,MSGQ-(STKNEXT-STACKMSG)  -> 0th stacked msg
         USING STACKMSG,R2
*
ISSUE040 EQU   *
         ICM   R15,15,STKNEXT      -> next stacked message
         BZ    ISSUE050            Found the end
         LR    R2,R15              stacked msg ptr to R2
         B     ISSUE040
*
ISSUE050 EQU   *
         ST    R1,STKNEXT          Add new stacked msg to the end
         LM    R2,R3,SV23          Restore
         L     R14,SVR14I          Load return addr                v220
         BR    R14
*
         DROP  R2                  STACKMSG
*
*--Issue the msg response to the system console or to a TSO user
*
ISSUE100 EQU   *
         CLC   CMDVMID,=CL8'OP'    Responding to operator?
         BNE   ISSUE200            No, send to TSO
*
*-- Response to console
*
         MVC   WTOMSG(4),WTO       Move dummy
         MVC   WTOMSG+4(120),MTEXT
*
         WTO   ,MF=(E,WTOMSG)
*
         LM    R2,R3,SV23          Restore
         L     R14,SVR14I          Load return addr                v220
         BR    R14
*
*
*-- Send the msg response to a local TSO user
*
ISSUE200 EQU   *
         LA    R15,CMDVMID         -> userid to locate             v220
         BAL   R14,REG000          Is TSO user registered?         v220
         BNZ   ISSUE290            Y; we queued it. just exit      v220
         BAL   R14,ISSUE800        Is TSO user logged on?
         BZ    ISSUE290            No.  Skip the message
         MVC   WTOMSG+4(4),=C'SE '''
         MVC   WTOMSG+8(104),MTEXT                                 v102
         LA    R2,WTOMSG+111       -> last byte from MTEXT area    v210
         LA    R0,32               # char to check backwards       v210
*
ISSUE220 EQU   *                   Only look backwards to col 80   v210
         CLI   0(R2),C' '          Try to find last non-blank      v210
         BNE   ISSUE230            Found it                        v210
         BCTR  R2,0                -> prev char                    v210
         BCT   R0,ISSUE220         Keep scanning                   v210
*
ISSUE230 EQU   *                                                   v210
         LA    R2,1(,R2)           -> first blank after last char  v210
         MVC   0(8,R2),=C''',USER=('                               v210
         MVC   8(12,R2),BLANKS      Ensure trailer initted         v210
         MVC   8(7,R2),CMDVMID      Max for TSO userid is 7        v210
         LA    R1,8+7(,R2)          -> max end of trt              v210
         TRT   8(7,R2),BLANK        Look for end of userid         v210
         MVI   0(R1),C')'           Move closing                   v210
         MVI   1(R1),C' '           Plus 1 blank                   v210
         LA    R0,WTOMSG            -> start of msg area           v210
         SR    R1,R0                Compute length of msg          v210
         LA    R1,1(,R1)            Account for blank at end       v210
         XC    WTOMSG(4),WTOMSG     Clear len, flags               v210
         STH   R1,WTOMSG            Insert the msg length          v210
*
         SPKA  0
         LA    R1,WTOMSG
         SR    R0,R0
         SVC   34                  Issue MGCR SVC
         SPKA  X'80'
*
ISSUE290 EQU   *
         LM    R2,R3,SV23          Restore
         L     R14,SVR14I          Load return addr                v220
         BR    R14
*
*-- Search CSCB chain to see if TSO user is logged on
*-- Exit:  CC=0  user was not logged on
*--        CC<>0 user is logged on
*
ISSUE800 EQU   *
         L     R1,16               Get CVT ptr
         USING CVT,R1
         L     R1,CVTASCBH         -> highest prty ASCB
         USING ASCB,R1
*
ISSUE810 EQU   *
         L     R2,ASCBCSCB         -> CSCB
         USING CSCB,R2
         LTR   R2,R2               Is there a CSCB?
         BZ    ISSUE840            No, get next ASCB
*
ISSUE820 EQU   *
         CLC   CHKEY,=XL8'00'      Jobname zeroed?
         BE    ISSUE830            Y, skip this CSCB
         CLC   CHKEY,=CL8' '       Jobname is blank?
         BE    ISSUE830            Y, skip this CSCB
         CLC   CMDVMID,CHKEY       Is this the userid?
         BE    ISSUE890            Yes
*
ISSUE830 EQU   *
         L     R2,CHPTR            -> next CSCB
         LA    R2,0(,R2)           Clear high order
         LTR   R2,R2               Last CSCB?
         BNZ   ISSUE820            No
         BR    R14                 Return with CC=0 (not found)
*
ISSUE840 EQU   *
         L     R1,ASCBFWDP         -> next ASCB
         LTR   R1,R1               last one?
         BNZ   ISSUE810            No
         BR    R14                 Return with CC=0 (not found)
*
ISSUE890 EQU   *
         LTR   R14,R14             Set CC=non zero (userid found)
         BR    R14                 Return to caller
*
         DROP  R1                  ASCB
         DROP  R2                  CSCB
*
*
*-- Special code to intercept messages destined for                v220
*-- registered users                                               v220
*
*
REG000   EQU   *                                                   v220
         L     R2,AREGUSER         -> registered user anchor word  v220
         ICM   R2,15,0(R2)         -> registered user queue        v220
         BZR   R14                 No registered users             v220
*
         USING REGUSERB,R2                                         v220
REG010   EQU   *                                                   v220
         CLC   REGUSRID,0(R15)     Find a matching registered user v220
         BE    REG020              Found it                        v220
         ICM   R2,15,REGNEXT       -> next REGUSER entry           v220
         BNZ   REG010              Keep looking                    v220
         BR    R14                 Userid was not registered       v220
*
REG020   EQU   *                                                   v220
         STM   R0,R14,BALRSAVE     Save regs                       v220
         BAL   R14,GTW000          Get a WRE                       v220
         LR    R4,R1                                               v220
         USING WRE,R4                                              v220
         MVI   WRETYPE,WREQRM      Queue registered msg WRE        v220
*
         MVC   WRELINK,LCLNODE     Target WRE to local node task   v220
         MVC   WREUSER,REGUSRID    Dest= registered user id        v220
         MVC   WREORIG,BLANKS      No originating node             v220
         MVC   WRETXT(104),MTEXT   Plug in the msg to be queued    v220
         MVC   WRETXT+104(12),BLANKS  Clear the rest               v220
         MVI   WRETXTLN,L'WRETXT   Set the max possible len        v220
*
*
         SPKA  0                                                   v220
         L     R15,CSABLK          -> NJE38 CSA block              v220
         USING NJ38CSA,R15                                         v220
         LM    R0,R1,NJ38SWAP      Get first WRE ptr, sync count   v220
*
REG030   EQU   *                                                   v220
         ST    R0,WRENEXT          First WRE becomes next          v220
         LA    R5,1(,R1)           Incr synchronization count      v220
         CDS   R0,R4,NJ38SWAP      Update LINK WRE anchor, sync    v220
         BC    7,REG030            Gotta try again                 v220
*
         LA    R1,NJ38ECB          -> main task notification ECB   v220
         POST  (1)                 Wake him up                     v220
*
         SPKA  X'80'                                               v220
*
         DROP  R2,R4,R15           REGUSERB,WRE,NJ38CSA            v220
*
REG090   EQU   *                                                   v220
         LM    R0,R14,BALRSAVE     Load return addr and regs       v220
         LTR   R14,R14             Set non-zero CC                 v220
         BR    R14                 Ret w/CC non-zero (msg queued)  v220
*
*
* FLNK000 - Locate a link table entry by link name
*
*  Entry:  R1 -> Link name to find (CL8 field padded with blanks)
*  Exit:   CC=0 link was not found
*          CC<>0 link table entry address is in R2
*
*
*
FLNK000  EQU   *
         L     R2,ALINKS               -> LINKS anchor word        v211
         L     R2,0(,R2)               -> LOCAL LINKTABL entry     v211
         USING LINKTABL,R2
         ICM   R2,15,LNEXT             -> first LINKTABL entry     v211
         BZR   R14                     Doesnt exist                v211
*
FLNK010  EQU   *
         CLC   LINKID,0(R1)            Find the link entry by name
         BE    FLNK020                 Got it
         ICM   R2,15,LNEXT             -> next LINKTABL entry
         BZR   R14                     Exit CC=0 if not found
         B     FLNK010                 Keep searching
         DROP  R2                      LINKTABL
*
FLNK020  EQU   *
         LTR   R2,R2                   Set CC non-zero
         BR    R14                     Return w/LINKTABL entry -> R2
*
* RLNK000 - Locate a name in the route table
*
*  Entry:  R1 -> Routed name to find (CL8 field padded with blanks)
*  Exit:   CC=0 link was not found
*          CC<>0 Associated link name address is in R1
*          CC<>0 Named route address is in R15
*
*-- First determine if the route name we are looking up is actually
*-- a link name.
*
RLNK000  EQU   *
         L     R15,AROUTES         -> RTE anchor word              v211
         ICM   R15,15,0(R15)       -> RTE list                     v211
         BZR   R14                 Exit CC=0 if no RTE list        v211
         USING RTE,R15                                             v211
*
         L     R2,ALINKS           -> LINKS anchor word            v211
         L     R2,0(,R2)           1st entry (LOCAL entry)         v211
         USING LINKTABL,R2
         ICM   R2,15,LNEXT         Skip over local entry           v211
         BZR   R14                 Fail the request if none        v211
         SR    R0,R0               R0=0 assume name not a link     v211
*
RLNK010  EQU   *                                                   v211
         CLC   LINKID,0(R1)        Find the link entry by name     v211
         BE    RLNK020             Got it                          v211
         ICM   R2,15,LNEXT         -> next LINKTABL entry          v211
         BNZ   RLNK010             Keep looking                    v211
         B     RLNK030             Didn't find a matching link     v211
         DROP  R2                  LINKTABL                        v211
*
*-- Here if route we want is a link name too (dont use wildcards)  v211
*
RLNK020  EQU   *                                                   v211
         BCTR  R0,0                Indic route is explicit link nm v211
*                                                                  v211
*-- Search the RTEs for the route name                             v211
*                                                                  v211
RLNK030  EQU   *
         STM   R4,R7,12(R13)       Save work regs                  v211
*
RLNK040  EQU   *                                                   v211
         LA    R4,ROUTNAME         -> name from route list         v211
         LA    R5,8                max length                      v211
         LR    R6,R1               -> selected name to locate      v211
         LR    R7,R5               copy length                     v211
         CLCL  R4,R6               Did we locate the name?         v211
         BE    RLNK400             Yes, exact match                v211
         LTR   R0,R0               Must be explicit link name?     v211
         BNZ   RLNK050             Yes, no wildcard checking       v211
         CLI   0(R4),C'*'          Wildcard was in the name?       v211
         BE    RLNK400             Then we matched to that point   v211
*
RLNK050  EQU   *
         ICM   R15,15,ROUTPTR      -> Next route entry             v211
         BNZ   RLNK040             Keep looking                    v211
         LM    R4,R7,12(R13)       Restore work regs               v211
         BR    R14                 No matching route               v211
*
*-- Found the RTE with a matching name, now determine what link    v211
*-- to route to.                                                   v211
*
RLNK400  EQU   *                                                   v211
         LM    R4,R7,12(R13)       Restore work regs               v211
         LA    R0,4                # possible routed-to names      v211
         LA    R1,ROUTNEXT         -> first possible name          v211
*
RLNK410  EQU   *                                                   v211
         L     R2,ALINKS           -> LINKS anchor word            v211
         L     R2,0(,R2)           1st entry (LOCAL entry)         v211
         USING LINKTABL,R2                                         v211
         ICM   R2,15,LNEXT         Skip over local entry           v211
         BZR   R14                 Fail the request if none        v211
*
RLNK420  EQU   *                                                   v211
         CLC   0(8,R1),BLANKS      No route-to name?               v211
         BE    RLNK499             Fail the request                v211
         CLC   0(8,R1),LINKID      Look for destination link       v211
         BE    RLNK440             Found it                        v211
         ICM   R2,15,LNEXT         -> next LINKTABL entry          v211
         BNZ   RLNK420             Keep searching                  v211
*
RLNK430  EQU   *                                                   v211
         LA    R1,8(,R1)           Next alternate route-to         v211
         BCT   R0,RLNK410          Rescan for matching link        v211
         B     RLNK499             None found, fail the request    v211
*
RLNK440  EQU   *                                                   v211
         TM    LFLAG,LCONNECT      Is the link active?             v211
         BZ    RLNK430             N, try next route-to link       v211
         DROP  R2,R15              LINKTABL, RTE                   v211
*
RLNK490  EQU   *                                                   v211
         CLI   *,0                 Set CC to non-zero              v211
         BR    R14                 Return with link name -> R1     v211
*
RLNK499  EQU   *                                                   v211
         CLI   *+1,0               Set CC to 0                     v211
         BR    R14                 No matching route/act link foundv211
*
*-- Get a new command type WRE
*
*-- Entry:  None
*   Exit:   R1 -> WRE
*
*
GTW000   EQU   *
         ST    R14,SV14            Save return addr
         GETMAIN RU,               Get CSA for WRE TYPE=WRECMD         x
               LV=WRESIZE,                                         v220x
               SP=2                                                v220
         XC    0(WRESIZE,R1),0(R1)    Clear stg area               v220
         USING WRE,R1
         MVI   WRESP,2             Set WRE subspool                v220
         MVI   WRETYPE,WRECMD      CMD/MSG WRE
*
         NJETRACE TYPE=TRCGWRE
         STCM  R10,7,1(R14)        Identify trace entry            v220
         MVC   5(3,R14),SV14+1     Addr of GTW000 caller           v220
         STM   R0,R1,8(R14)        Len, stg addr to trace          v220
         MVI   8(R14),2            Trace subpool #                 v220
         DROP  R1
         L     R14,SV14            Load return addr
         BR    R14
*
*-- Queue the WRE on the Link and post link's ECB
*
*-- Entry:  R2 -> LINKTABL entry
*--         R4 -> WRE
*-- Exit:   None
*
PST000   EQU   *
         USING LINKTABL,R2
         USING WRE,R4
         ST    R14,SV14            Save return addr
         LM    R0,R1,LWRESWAP      Get first WRE ptr, sync count
*
PST020   EQU   *
         ST    R0,WRENEXT          First WRE becomes next
         LA    R5,1(,R1)           Incr synchronization count
         CDS   R0,R4,LWRESWAP      Update LINK WRE anchor, sync
         BC    7,PST020            Gotta try again
*
         LA    R1,LECB             -> link task notification ECB
         POST  (1)                 Tell subtask to quit
         L     R14,SV14            Load return addr
         BR    R14
*
         DROP  R2                  LINKTABL
         DROP  R4                  WRE
*
*
*-- Format VSAM error msg
*
*
FMT000   EQU   *
         STM   R14,R2,BALRSAVE         Save regs used
         MVC   WTOMSG(WTOL),WTO
         MVC   WTOMSG+4(L'NJE079I),NJE079I    Move msg text
         MVC   WTOMSG+55(8),5(R12)     Move csect name
         TRT   WTOMSG+55(9),BLANK      Look for end of csect name
         MVI   0(R1),C'+'
*
         LA    R15,0(,R14)  Clear high, Get addr of call to this rtn
         LA    R12,0(,R12)             Clear high byte
         SR    R15,R12                 Compute offset of call
         ST    R15,DBLE                Save to work area
         UNPK  TWRK(5),DBLE+2(3)       Add zones
         TR    TWRK(4),HEXTRAN-240     Display hex
         MVC   1(4,R1),TWRK            Move call offset to msg
*
         LA    R15,NCB1
         UNPK  TWRK(5),NCBRTNCD-NCB(3,R15)  Add zones
         TR    TWRK(4),HEXTRAN-240
         MVC   WTOMSG+35(4),TWRK       Move rtncd/errcd
*
         UNPK  TWRK(3),NCBREQ-NCB(2,R15)  Add zones
         TR    TWRK(2),HEXTRAN-240
         MVC   WTOMSG+45(2),TWRK       Move req code
*
         L     R1,NCBMACAD-NCB(,R15)   Get failing VSAM macro addr
         LA    R1,0(,R1)               Clear high byte
         S     R1,ANJESPL              Comp offset into NJESPOOL   v210
         ST    R1,DBLE
         UNPK  TWRK(5),DBLE+2(3)       Add zones
         TR    TWRK(4),HEXTRAN-240     Display hex
         MVC   WTOMSG+50(4),TWRK       Move NJESPOOL offset to msg
*
         OI    NJFL1,NJF1VSER          Indicate VSAM error occurred
*
         WTO   ,MF=(E,WTOMSG)
*
FMT090   EQU   *
         LM    R14,R2,BALRSAVE         Restore caller regs
         BR    R14                     Exit with CC set
*
U0039    ABEND 39,DUMP,STEP            Abend on NETSPOOL VSAM error
*
*
*-- Common Error Messaging --
*
CMDE030  EQU   *                                                   v200
         MVC   MTEXT(L'NJE030E),NJE030E                            v200
         MVI   TARGET,TGTCONS      Respond to console              v200
         MVC   CMDVMID,=CL8'OP'    Respond to console              v200
         LA    R1,L'NJE030E        Length                          v200
         BAL   R14,ISSUE000        Respond to console only         v200
         B     XITCXX00            Exit from active csect          v200
*
CMDE033  EQU   *                                                   v211
         MVC   MTEXT(L'NJE033E),NJE033E                            v211
         MVI   TARGET,TGTCONS      Respond to console              v211
         MVC   CMDVMID,=CL8'OP'    Respond to console              v211
         LA    R1,L'NJE033E        Length                          v211
         BAL   R14,ISSUE000        Respond to console only         v211
         B     XITCXX00            Exit from active csect          v211
*
CMDE041  EQU   *
         MVC   MTEXT(L'NJE041E),NJE041E
         MVC   MTEXT+33(8),CMDNODE Move link name to msg
         LA    R1,L'NJE041E
         BAL   R14,ISSUE000        Respond to user or operator
         B     XITCXX00            Exit from active csect
*
CMDE047  EQU   *                                                   v211
         MVC   MTEXT(L'NJE047E),NJE047E                            v211
         MVC   MTEXT+45(8),LINKID-LINKTABL(R15) node name to msg   v211
         UNPK  DBLE(4),LDEFLINE-LINKTABL(3,R15) Convert CUU of linev211
         TR    DBLE(3),HEXTRAN-240                                 v211
         MVC   MTEXT+26(3),DBLE    move CUU to line                v211
         LA    R1,L'NJE047E+8      Add len plus node name          v211
         BAL   R14,ISSUE000        Respond to user or operator     v211
         B     XITCXX00            Exit from active csect          v211
*                                                                  v211
CMDE056  EQU   *
         MVC   MTEXT(L'NJE056I),NJE056I
         LA    R1,L'NJE056I
         BAL   R14,ISSUE000        Respond to user or operator
         B     XITCXX00            Exit from active csect
*
CMDE057  EQU   *
         MVC   MTEXT(L'NJE057I),NJE057I
         LA    R1,L'NJE057I
         BAL   R14,ISSUE000        Respond to user or operator
         B     XITCXX00            Exit from active csect
*
CMDE058  EQU   *
         MVC   MTEXT(L'NJE058I),NJE058I
         LA    R1,L'NJE058I
         BAL   R14,ISSUE000        Respond to user or operator
         B     XITCXX00            Exit from active csect
*
CMDE059  EQU   *
         MVC   MTEXT(L'NJE059E),NJE059E                            v211
         MVC   MTEXT+21(8),CMDNODE Move link name to msg
         LA    R1,L'NJE059E                                        v211
         BAL   R14,ISSUE000        Respond to user or operator
         B     XITCXX00            Exit from active csect
*
CMDE060  EQU   *
         MVC   MTEXT(L'NJE060I),NJE060I
         MVC   MTEXT+13(8),CMDNODE Move link name to msg
         LA    R1,L'NJE060I
         BAL   R14,ISSUE000        Respond to user or operator
         B     XITCXX00            Exit from active csect
*
CMDE061  EQU   *
         MVC   MTEXT(L'NJE061I),NJE061I
         MVC   MTEXT+13(8),CMDNODE Move link name to msg
         LA    R1,L'NJE061I
         BAL   R14,ISSUE000        Respond to user or operator
         B     XITCXX00            Exit from active csect
*
CMDE062  EQU   *
         MVC   MTEXT(L'NJE062I),NJE062I
         MVC   MTEXT+13(8),CMDNODE Move link name to msg
         LA    R1,L'NJE062I
         BAL   R14,ISSUE000        Respond to user or operator
         B     XITCXX00            Exit from active csect
*
CMDE071  EQU   *                                                   v200
         MVC   MTEXT(L'NJE071I),NJE071I                            v200
         LA    R1,L'NJE071I                                        v200
         BAL   R14,ISSUE000        Respond to user or operator     v200
         SPKA  X'80'               Exit in user key                v200
         B     XITCXX00            Exit from active csect          v200
*
NOTAUTH  EQU   *
         MVC   MTEXT(L'NJE023E),NJE023E  Move in msg text
         LA    R1,L'NJE023E        Compute length of text
         BAL   R14,ISSUE000        Go stack the message
*
         MVI   TARGET,TGTCONS      Send it to console              v200
         MVC   CMDVMID,=CL8'OP'    Respond to operator too         v200
         LA    R1,L'NJE023E        Compute length of text          v200
         BAL   R14,ISSUE000        Go stack the message            v200
         B     XITCXX00            Exit command processing
*
*
*-- This exit point will allow an exit from whatever active csect
*-- was in control when a common routine was invoked. Control will be
*-- returned to the caller of the active csect (NJECMC or NJECMG).
*
XITCXX00 EQU   *
         SR    R15,R15             Set RC=0
         L     R13,4(,R13)         -> prev s.a.
         ST    R15,16(,R13)        Set RC
         LM    R14,R12,12(R13)     Reload callers regs
         BR    R14                 Return with RC
*
         LTORG
*
*                0123456789012345678901234567890123456789012345678901
NJE023E  DC    C'NJE023E Not authorized for command'
NJE030E  DC    C'NJE030E Command not executed: user from unknown node' x
                                                                   v200
NJE033E  DC    C'NJE033E Command not executed: no return path'     v211
NJE041E  DC    C'NJE041E No active route paths to ' nodeid         v211
NJE047E  DC    C'NJE047E Not started; line xxx in use by link '    v211
NJE056I  DC    C'NJE056I Unrecognized command'
NJE057I  DC    C'NJE057I Invalid command syntax'
NJE058I  DC    C'NJE058I Invalid link or userid specification'
NJE059E  DC    C'NJE059I Unknown link xxxxxxxx'                    v211
NJE060I  DC    C'NJE060I Link xxxxxxxx already started'
NJE061I  DC    C'NJE061I Link xxxxxxxx is not active'
NJE062I  DC    C'NJE062I Link xxxxxxxx is draining'
NJE071I  DC    C'NJE071I Chained CMD commands are not supported by NJE3x
               8'                                                  v200
*
*                456789012345678901234567890123 45678 90123456789012345
NJE079I  DC    C'NJE079I NETSPOOL RTNCD/ERRCD=X''0000'',REQ=01,O=1234,Mx
               MMMMMMM     '
*
*               1234567890123456789012345678901234567890123456789012345
WTO      WTO   '                                                       x
                                                                       x
                        ',MF=L
*              67890123456789012345678901234567890123456789012345678901
WTOL     EQU   *-WTO
*
ATTACH   ATTACH SF=L
ATTACHL  EQU   *-ATTACH
*
BLANKS   DC    CL120' '
NONBLANK DC    64X'FF',X'00',191X'FF'  TR Table to locate nonblank
BLANK    DC    64X'00',X'FF',191X'00'  TR Table to locate blanks
HEXTRAN  DC    CL16'0123456789ABCDEF'  Translate table
         DROP  R8                      CMDBLOK
*
*
*
***********************
*  N J E C M C        *             NJECMC examines the command and
*                     *             processes control-oriented
*  Command processor  *             commands.  Commands not handled
*  for control cmds   *             here result in an exit with RC 4
*                     *             so the general command processing
***********************             routine NJECMG can be called.
*
NJECMC   CSECT
         B     28(,R15)               BRANCH AROUND EYECATCHERS
         DC    AL1(23)                LENGTH OF EYECATCHERS
         DC    CL9'NJECMC'
         DC    CL9'&SYSDATE'
         DC    CL5'&SYSTIME'
*
         STM   R14,R12,12(R13)         Save Regs
         LR    R12,R15                 Base
         USING NJECMC,R12
         USING NJEWK,R10
         ST    R13,CMCSA+4             SAVE prv S.A. ADDR
         LA    R1,CMCSA                -> my save area
         ST    R1,8(,R13)              Plug it into prior SA
         LR    R13,R1
*
         USING CMDBLOK,R8
         USING NJECOM,R11
*
*-- Ensure command came from a valid named link or route           v200
*
VLD000   EQU   *                                                   v200
         CLC   CMDLINK,LCLNODE      Command from local node?       v211
         BE    CMD000               Yes                            v200
*
         LA    R1,CMDLINK          -> originating node of cmd      v200
         SR    R3,R3               R3=0 assume not a link origin   v211
         BAL   R14,FLNK000         Check if it is a link           v211
         BZ    VLD020              Not a link, check routes        v211
         TM    LFLAG-LINKTABL(R2),LCONNECT Is link connected?      v211
         BO    CMD000                  Yes, use it                 v211
         LA    R3,4                R3=4 Link origin (not connected)v211
*
VLD020   EQU   *                                                   v211
         BAL   R14,RLNK000         Check if it is a route          v211
         BNZ   CMD000              Route found, do command         v211
*
         LTR   R3,R3               Origin from known link?
         BZ    CMDE030         00  No, disallow command            v211
         B     CMDE033         04  Yes, ignore cmd (no return path)v211
*
*-- Examine and process a command
*
CMD000   EQU   *
         MVC   CMDAREA,BLANKS      Init receiving field
         SR    R1,R1               Clear for IC
         IC    R1,CMDBLEN          Get command text length
         EX    R1,MVCMD2           Create local copy of cmd text
*MVCMD2  MVC   CMDAREA(0),CMDTEXT
*
         BAL   R14,CHKAUTH         Check for user authorization
         BZ    CMD010              Not auth for sensitive commands
         OI    NJFL1,NJF1AUTH      Indicate user is cmd authorized
*
CMD010   EQU   *
         LA    R1,CMDAREA          -> start of cmd image
         CLI   0(R1),X'7D'         Is cmd inside apostrophes?
         BNE   CMD020              No
         LA    R1,1(,R1)
*
*-- Parse the first field (should be the command, START, DRAIN, etc)
*
CMD020   EQU   *
         TRT   0(120,R1),NONBLANK  Look for 1st char
         BZ    CMDE056             Something wrong
         LR    R3,R1               -> first char
         TRT   0(120,R3),BLANK     Look for end of 1st "word"
         BZ    CMDE056             Something wrong
*
         LR    R5,R1               Save addr at end of word
         SR    R1,R3               Compute length of command
         BNP   CMDE056             Unknown command
         C     R1,=F'8'            text too long?
         BH    CMDE056             unknown cmmand
*
         MVC   COMMAND,BLANKS      Init receiving field
         BCTR  R1,0                Adjust length for execute
         EX    R1,MVCMD1           Move and uppercase the command
*MVCMD1  OC    COMMAND(0),0(R3)
*
*-- The following commands are parsed by NJESCN config scanner     v211
*
         CLC   =C'AUTH ',COMMAND   AUTH cmd?                       v211
         BE    CMDSCAN             Yes                             v211
         CLC   =C'ROUTE ',COMMAND  ROUTE cmd?                      v211
         BE    CMDSCAN             Yes                             v211
         CLC   =C'LINK ',COMMAND   LINK cmd?                       v211
         BE    CMDSCAN             Yes                             v211
*
*-- The following commands require a link name
*-- Parse the second field (should be a link name)
*
         TRT   0(120,R5),NONBLANK  Look for next word
         BZ    CMDE057             Something wrong, inv syntax
         LR    R3,R1               -> start of word
         TRT   0(120,R3),BLANK     Look for end of word
         BZ    CMDE057             Something wrong, inv syntax
*
*v130    CLI   0(R3),X'EF'         Is link name a number?          v120
*v130    BH    XITCMC04            Go direct to general commands   v120
*
         LR    R5,R1               Save addr at end of word
         SR    R1,R3               Compute length of link id
         BNP   CMDE058             invalid link name
         C     R1,=F'8'            Name too long?
         BH    XITCMC04            Y; pass to general commands     v130
*v130    BH    CMDE058             invalid link name
*
         MVC   CMDNODE,BLANKS      Init receiving field
         BCTR  R1,0                Adjust length for execute
         EX    R1,MVLNK1           Move and uppercase the lnk id
*MVLNK1  OC    CMDNODE(0),0(R3)
*
* For the most part, this section processes commands that affect
* a link, or specify a link name (with an exception or two).
*
* R5 -> blank after 2nd parameter of command, if addt'l fields needed.
*
*
CMD030   EQU   *
         MVC   MTEXT,BLANKS        Clear work area
         CLC   =C'CMD ',COMMAND    CMD   cmd?
         BE    CCD000              Yes
         CLC   =C'MSG ',COMMAND    MSG   cmd?
         BE    MCD000              Yes
         CLC   =C'M ',COMMAND      MSG   cmd?
         BE    MCD000              Yes
         CLC   =C'S ',COMMAND      Start cmd?
         BE    STR000              Yes
         CLC   =C'START ',COMMAND  Start cmd?
         BE    STR000              Yes
         CLC   =C'P ',COMMAND      Stop cmd?
         BE    DRN000              Yes
         CLC   =C'STOP ',COMMAND   Stop cmd?
         BE    DRN000              Yes
         CLC   =C'ABEND ',COMMAND  Abend cmd?
         BE    ABD000              Yes
*
         B     XITCMC04            Otherwise, general cmd processing
*
ABD000   ABEND 99,DUMP,STEP
*
*
*-- START command
*
STR000   EQU   *
         TM    NJFL1,NJF1AUTH      Is user cmd authorized?
         BZ    NOTAUTH             Not auth for command
         LA    R1,CMDNODE          -> Link name to find
         BAL   R14,FLNK000         Find the link name in link table
         BZ    CMDE059             Link name not found
*
         USING LINKTABL,R2
         CLC   LTCBA,=A(0)         TCB addr present for link?
         BNE   CMDE060             Y, link already started
*
         L     R15,ALINKS          -> LINKS anchor word            v211
         L     R15,0(,R15)         -> LOCAL LINKTABL entry         v211
         L     R15,LNEXT-LINKTABL(,R15) -> first LINKTABL entry    v211
*
STR010   EQU   *                                                   v211
         CR    R2,R15              Looking at same link entry?     v211
         BE    STR020              Yes, skip this one              v211
         CLC   LDEFLINE,LDEFLINE-LINKTABL(R15) Look for same line #v211
         BE    STR030              Hmm, someone else use same line v211
*
STR020   EQU   *
         ICM   R15,15,LNEXT-LINKTABL(R15) -> next LINKTABL entry   v211
         BZ    STR060              Exit loop if no line dups found v211
         B     STR010              Keep searching                  v211
*
STR030   EQU   *               **  Check if line has activity      v211
         TM    LFLAG-LINKTABL(R15),LCONNECT+LACTIVE+LDRAIN  busy?  v211
         BNZ   CMDE047             Can't start; line in use        v211
*
STR060   EQU   *                                                   v211
         BAL   R14,GTW000          Get WRE                         v220
         LR    R4,R1               -> WRE
         USING WRE,R4
         MVI   WRESP,2             Save subspool                   v220
         MVI   WRETYPE,WRESTAR     This is a START cmd WRE
         ST    R2,WREUSER          Set A(LINKTABL) for link in user fld
         MVC   WRELINK,LCLNODE     Assign WRE to local node        v211
         DROP  R2                  LINKTABL
*
         SPKA  0                                                   v220
         L     R6,CSABLK           -> CSA comm area                v211
         USING NJ38CSA,R6
*
         LM    R0,R1,NJ38SWAP      Get first WRE ptr, sync count
STR090   EQU   *                                                   v210
         ST    R0,WRENEXT          First WRE becomes next
         LA    R5,1(,R1)           Incr synchronization count
         CDS   R0,R4,NJ38SWAP      Update CSA WRE anchor, sync
         BC    7,STR090            Gotta try again                 v210
*
         LA    R7,NJ38ECB          -> NJE38 external WRE ECB
         DROP  R6                  NJ38CSA
         DROP  R4                  WRE
*                                  WRE will be queued to main task
         POST  (7)                 Post the main task WRE ECB
*
         SPKA  X'80'               Back to user key
         B     XITCMC00            Exit
*
*
*
*-- Handle CMD command
*
CCD000   EQU   *
         CLC   CMDNODE,LCLNODE     Was CMD for local node?         v211
         BE    CCD100              Yes
*
*---------------------------------------------------------------------
*-
*- 16 July 2020
*-
*- Starting in NJE38 v2.0.0, chained commands have been disallowed
*- due to security reasons.  This is because the original issuer node
*- is not being propagated through each node correctly (or at all),
*- and the last node to forward the command becomes the "issuer".
*- But the original issuer userid is passed through intact. For example
*-
*- User XYZ on Node ABC issues this chained CMD command:
*-
*- CMD MVSA CMD MVSB C 123
*-
*- The console on MVSB will show 'Location MVSA(XYZ) issuing C 123'
*- when the command originated from node ABC!  If user MVSA(XYZ) was
*- also an actual user and authorized to issue Cancel commands on
*- MVSB, then user ABC(XYZ) just obtained cancel authority in error.
*- Further, user MVSA(XYZ) receives any command responses, not
*- ABC(XYZ).
*-
*-
*---------------------------------------------------------------------
*
         CLC   CMDLINK,LCLNODE     CMD origin from this local node?v211
         BNE   CMDE071             no CMD cmds allowed from remote v200
         SR    R1,R1               Clear for TRT                   v200
         TRT   0(120,R5),NONBLANK  Find 1st char of cmd text       v200
         BZ    CMDE057             None, inv syntax                v200
         CLC   0(4,R1),=C'CMD '    OP gets 1 CMD, err on 2nd one   v200
         BE    CMDE071                                             v200
*
         BAL   R14,CHKN000         Find and validate link task
         LR    R7,R2               LINKTABL entry to R7
         BAL   R14,GTW000          Get WRE
         LR    R4,R1               -> WRE
         USING WRE,R4
         MVI   WRECODE,X'B0'       CMD for remote node
         MVC   WRELINK,CMDNODE     Set target to receive cmd
         MVC   WREUSER,CMDVMID     Set userid of issuer
         MVC   WREORIG,CMDLINK     Set nodeid of issuer (not used) v200
*
         SR    R1,R1               Clear for TRT
         TRT   0(120,R5),NONBLANK  Find 1st char of cmd text
         BZ    CMDE057             None, inv syntax
         LA    R5,CMDAREA          -> start of CIB entered text
         LR    R0,R1               Copy current position
         SR    R0,R5               Compute length we've skipped
         SR    R5,R5               Clear for IC
         IC    R5,CMDBLEN          Get total cmd text length
         SR    R5,R0               Less len skipped = text portion len
         MVC   WRETXT,BLANKS       Init receiving field
         EX    R5,CPYTXT           Copy text portion into WRE
*CPYTXT  MVC   WRETXT(0),0(R1)
         STC   R5,WRETXTLN         Set text portion length
*
         LR    R2,R7               LINKTABL entry back to R2
         BAL   R14,PST000          Queue WRE to link task
         B     XITCMC00            Exit
*
*-- Here if the console operator issued F NJE38,CMD lclnode command
*
CCD100   EQU   *
         LR    R2,R5               Copy current position
         LA    R0,CMDAREA          -> start of cmd text area
         LA    R1,L'CMDAREA        Length of entire area
         SR    R2,R0               Compute length consumed
         SR    R15,R15             Clear for IC
         IC    R15,CMDBLEN         Get original length
         SR    R15,R2              Adjust length for new size
         STC   R15,CMDBLEN         Put back
         LA    R15,1(,R15)         Make actual length for move
         LR    R14,R5              Copy current position
         ICM   R15,8,=X'40'        Set pad char
         MVCL  R0,R14              Shift remaining text and pad
         B     CMD010              And restart cmd processing
*
CPYTXT   MVC   WRETXT(0),0(R1)     Executed instr
*
*
*
*
*
*-- Handle MSG
*
MCD000   EQU   *
*
*-- Parse the third field (should be a userid)
*
         TRT   0(120,R5),NONBLANK  Look for next word
         BZ    CMDE057             Something wrong, inv syntax
         LR    R3,R1               -> start of word
         TRT   0(120,R3),BLANK     Look for end of word
         BZ    CMDE057             Something wrong, inv syntax
*
         LR    R5,R1               Save addr at end of word
         SR    R1,R3               Compute length of user id
         BNP   CMDE058             invalid user name
         C     R1,=F'8'            Name too long?
         BH    CMDE058             invalid user name
*
         MVC   CMDUID,BLANKS       Init receiving field
         BCTR  R1,0                Adjust length for execute
         EX    R1,MVLNK2           Move and uppercase the user id
*MVLNK2  OC    CMDUID(0),0(R3)
*
MCD010   EQU   *
         BAL   R14,CHKN000         Find and validate link task
         LR    R7,R2               LINKTABL entry to R7
         BAL   R14,GTW000          Get WRE
         LR    R4,R1               -> WRE
         USING WRE,R4
         MVI   WRETYPE,WREMSG      MSG type wre
         MVI   WRECODE,X'B1'       MSG for remote node
         MVC   WRELINK,CMDNODE     Set target to receive msg
         MVC   WREUSER,CMDUID      Set target to receive msg
         MVC   WREORIG,=CL8'OP'    Set origin id
*
*-- R5 -> rest of msg text
*
         LA    R1,8(,R5)           Limit if TRT fails (send blanks)
         TRT   0(120,R5),NONBLANK  Find 1st char of msg text
         LA    R5,CMDAREA          -> start of text
         LR    R0,R1               Copy current position
         SR    R0,R5               Compute length we've skipped
         SR    R5,R5               Clear for IC
         IC    R5,CMDBLEN          Get total cmd text length
         SR    R5,R0               Less len skipped = text portion len
         MVC   WRETXT,BLANKS       Init receiving field
         EX    R5,CPYTXT           Copy text portion into WRE
*CPYTXT  MVC   WRETXT(0),0(R1)
         STC   R5,WRETXTLN         Set text portion length
*
         LR    R2,R7               LINKTABL entry back to R2
         BAL   R14,PST000          Queue WRE to link task
         B     XITCMC00            Exit
*
*
*
*-- STOP command
*
DRN000   EQU   *
         TM    NJFL1,NJF1AUTH      Is user cmd authorized?
         BZ    NOTAUTH             Not auth for command
         LA    R1,CMDNODE          -> link to drain
         BAL   R14,FLNK000         Find the via name in link table
         BZ    CMDE059             Not found
*
         USING LINKTABL,R2
         CLC   LTCBA,=A(0)         Is link active?
         BE    CMDE061             No
         TM    LFLAG,LDRAIN        Drain already issued?
         BO    CMDE062             Drain in progress
         DROP  R2
*
         BAL   R14,GTW000          Get WRE
         LR    R4,R1               -> WRE
         USING WRE,R4
         MVI   WRECODE,X'81'       Code for drain link
         BAL   R14,PST000          Queue wre to link task
*
         B     XITCMC00            Exit
         DROP  R4                  WRE
*
MVCMD1   OC    COMMAND(0),0(R3)    executed instr
MVCMD2   MVC   CMDAREA(0),CMDTEXT  executed instr
MVLNK1   OC    CMDNODE(0),0(R3)    executed instr
MVLNK2   OC    CMDUID(0),0(R3)     executed instr
*
*
*-- Dynamic Configuration Commands  (handled by NJESCN)            v211
*
*
*-- LINK command                                                   v211
*-- 1. LINK  xxxxx LINE cuu BUFF nnnn AUTO aaa                     v211
*-- 2. LINK  xxxxx OFF                                             v211
*
*-- ROUTE command                                                  v211
*-- 1. ROUTE xxxxx TO yyyyy                                        v211
*-- 2. ROUTE xxxxx OFF                                             v211
*
*-- AUTH command                                                   v211
*-- 1. AUTH userid AT nodeid                                       v211
*-- 2. AUTH userid AT nodeid OFF                                   v211
*
CMDSCAN  EQU   *                                                   v211
         TM    NJFL1,NJF1AUTH      Is user cmd authorized?         v211
         BZ    NOTAUTH             Not auth for command            v211
*
         LA    R0,4                R0=4: scan a configuration cmd  v211
         LA    R1,INITPARM         -> pass parm area               v211
         LA    R2,MTEXT            -> area to return msg text      v211
         L     15,=V(NJESCN)       -> config scan                  v211
         BALR  R14,R15             Scan the command                v211
         LR    R1,R0               Returned msg length to R1       v211
         BAL   R14,ISSUE000        Respond to user or operator     v211
         B     XITCMC00            Done with command               v211
*
*
*
*
*-- Find and validate a link task (ensure it is active) so it can
*-- be posted with a new command to execute.
*
*-- Entry:  CMDNODE contains LINK ID
*   Exit:   R2 -> LINKTABL entry for LINK ID
*           Exit to error msgs if error.
*
*
*
CHKN000  EQU   *
         ST    R14,SV14            Save return addr
         LA    R1,CMDNODE          -> Link name to find
         BAL   R14,FLNK000         Find the link name in link table
         BNZ   CHKN010             Got it
         BAL   R14,RLNK000         Check for matching route
         BZ    CMDE041             No match, no route paths
         BAL   R14,FLNK000         Find the via name in link table
         BZ    CMDE059             Not found again
*
CHKN010  EQU   *
         USING LINKTABL,R2
         CLC   LTCBA,=A(0)         Is link active?
         BE    CHKN020             No, try a route
         TM    LFLAG,LDRAIN        Drain already issued?
         BO    CMDE062             Drain in progress
         L     R14,SV14            Load return addr
         BR    R14                 Return
*
CHKN020  EQU   *
         MVC   CMDNODE,0(R1)       Switch to route-via name
         BAL   R14,RLNK000         Check for matching route
         BZ    CMDE061             Couldnt; report primary link inact
         BAL   R14,FLNK000         Find the via name in link table
         BZ    CMDE061             Couldnt; report primary as inact
         CLC   LTCBA,=A(0)         Is link active?
         BE    CMDE061             No, primary is inact
         TM    LFLAG,LDRAIN        Drain already issued?
         BO    CMDE061             Primary is inact
         DROP  R2
         L     R14,SV14            Load return addr
         BR    R14                 Return
*
*
*
XITCMC00 EQU   *
         SR    R15,R15             Set RC=0
         B     XITCMC              And exit
*
XITCMC04 EQU   *
         LA    R15,4               Set RC=4: do general commands
*
XITCMC   EQU   *
         L     R13,4(,R13)         -> prev s.a.
         ST    R15,16(,R13)        Set RC
         LM    R14,R12,12(R13)     Reload callers regs
         BR    R14                 Return with RC
*
         LTORG ,
*
*
*********************
*  N J E C M G      *               NJECMG handles general command
*                   *               processing.  These are mostly
*  General commands *               display commands frequently
*  processing       *               by remote users.
*                   *
*********************
*
NJECMG   CSECT
         B     28(,R15)               BRANCH AROUND EYECATCHERS
         DC    AL1(23)                LENGTH OF EYECATCHERS
         DC    CL9'NJECMG'
         DC    CL9'&SYSDATE'
         DC    CL5'&SYSTIME'
*
         STM   R14,R12,12(R13)         Save Regs
         LR    R12,R15                 Base
         USING NJECMG,R12
         USING NJEWK,R10
         ST    R13,CMGSA+4             SAVE prv S.A. ADDR
         LA    R1,CMGSA                -> my save area
         ST    R1,8(,R13)              Plug it into prior SA
         LR    R13,R1
*
         USING CMDBLOK,R8
         USING NJECOM,R11
*
*-- General command processing
*
*
CMD100   EQU   *
         MVC   MTEXT,BLANKS        Clear work area
         MVC   MWORK,BLANKS        Clear work area
         SR    R5,R5               Clear
         IC    R5,CMDBLEN          Get cmd text IBM len
         LA    R2,CMDAREA          -> original cmd text image
         LA    R1,MTEXT
         EX    R5,MVCCMD2          Move and upper to msg area      v200
*MVCCMD2 OC    0(0,R1),0(R2)                                       v200
*
         LA    R3,MTEXT            -> command text
         TRT   0(096,R3),NONBLANK  Look for text start
         BZ    CMD700              Unknown or invalid command
         CLC   =C'Q ',0(R1)        Is this a query   command?
         BE    CMD110              Yes
         CLC   =C'D ',0(R1)        Is this a display command?
         BE    CMD120              Yes
         CLC   =C'C ',0(R1)        Is this a cancel command?
         BE    CMD300              Yes
         CLC   =C'E ',0(R1)        Is this a RESET command?        v120
         BE    CMD230              Yes                             v120
         CLC   =C'RESET ',0(R1)    Is this a RESET command?        v120
         BE    CMD230              Yes                             v120
         CLC   =C'CPQ ',0(R1)      Is this a CPQ     command?
         BE    CMD130              Yes
         B     CMD700              Otherwise invalid command
*
* Q
CMD110   EQU   *
         TRT   0(096,R1),BLANK     Look for end of string
         BZ    CMD700              Invalid
         TRT   0(096,R1),NONBLANK  Look for 2nd string in cmd text
         BZ    CMD700              Not found, inv command
         CLC   =C'SY ',0(R1)       Is this a Q SYS command?
         BE    CMD200              Yes
         CLC   =C'SYS ',0(R1)      Is this a Q SYS command?
         BE    CMD200              Yes
         CLC   =C'SYSTEM ',0(R1)   Is this a Q SYS command?
         BE    CMD200              Yes
         CLC   =C'F ',0(R1)        Is this a files command?
         BE    CMD250              Yes
         CLC   =C'FILES ',0(R1)    Is this a files command?
         BE    CMD250              Yes
         B     CMD500              Treat as "Q nodeid"             v211
* D
CMD120   EQU   *
         TRT   0(096,R1),BLANK     Look for end of string
         BZ    CMD700              Invalid
         TRT   0(096,R1),NONBLANK  Look for 2nd string in cmd text
         BZ    CMD700              Not found, inv command
         CLC   =C'T ',0(R1)        Is this a time command?
         BE    CMD140              Yes
         CLC   =C'TIME ',0(R1)     Is this a time command?
         BE    CMD140              Yes
         CLC   =C'F ',0(R1)        Is this a files command?
         BE    CMD250              Yes
         CLC   =C'FILES ',0(R1)    Is this a files command?
         BE    CMD250              Yes
         CLC   =C'NODES ',0(R1)    Is this a NODES command?
         BE    CMD205              Yes
         CLC   =C'ROUTES ',0(R1)   Is this a ROUTES command?
         BE    CMD400              Yes
         CLC   =C'AUTH ',0(R1)     Is this a AUTH command?
         BE    CMD450              Yes
         CLC   =C'A ',0(R1)        Is this a active command?
         BE    CMD160              Yes
         CLC   =C'ACTIVE ',0(R1)   Is this a active command?
         BE    CMD160              Yes
         CLI   0(R1),X'EF'         Possible numeric file number?   v110
         BH    CMD240              Y,use microscope to check closerv110
         B     CMD500              Otherwise treat as "D nodeid"   v211
* CPQ
CMD130   EQU   *
         TRT   0(096,R1),BLANK     Look for end of string
         BZ    CMD700              Invalid
         TRT   0(096,R1),NONBLANK  Look for 2nd string in cmd text
         BZ    CMD700              Not found, inv command
         CLC   =C'T ',0(R1)        Is this a time command?
         BE    CMD140              Yes
         CLC   =C'TIME ',0(R1)     Is this a time command?
         BE    CMD140              Yes
         CLC   =C'N ',0(R1)        Is this a name command?
         BE    CMD160              Yes
         CLC   =C'NAMES ',0(R1)    Is this a name command?
         BE    CMD160              Yes
         CLC   =C'CPLEVEL ',0(R1)  Is this a CPLEVEL command?
         BE    CMD190              Yes
         B     CMD700              Otherwise invalid command
* TIME
CMD140   EQU   *
         MVC   MTEXT,BLANKS        Clear work area
*
         TIME  DEC                 Get the time and date
         ST    R1,DBLE             Store date 00YYDDDF
         UNPK  TWRK(9),DBLE(5)     Add zones
         MVC   MTEXT(L'CMSG2),CMSG2  Move model time response
         MVC   MTEXT+28(2),TWRK+2  Move YY to msg
         MVC   MTEXT+31(3),TWRK+4  Move DDD to msg
         ST    R0,DBLE             Store time HHMMSSTH
         UNPK  TWRK(9),DBLE(5)     Add zones
         MVC   MTEXT+14(2),TWRK+0  Move HH to msg
         MVC   MTEXT+17(2),TWRK+2  Move MM to msg
         MVC   MTEXT+20(2),TWRK+4  Move SS to msg
         LA    R1,L'CMSG2          Length of time message
         BAL   R14,ISSUE000        Go stack the message
         B     XITCMG00            And exit command processing
*
* ACTIVE
CMD160   EQU   *
         BAL   R14,DACT000         Prepare display active results
*
         MVC   MTEXT(L'CMSG6),CMSG6  Move msg
         MVC   MTEXT+L'CMSG6(8),LCLNODE Plug local node name to msgv211
         LA    R1,L'CMSG6+8        Length of message
         BAL   R14,ISSUE000        Go stack the message
*
         MVC   MTEXT,BLANKS        Clear work area
         MVC   MTEXT(L'CMSG7),CMSG7  Move msg
         LA    R1,L'CMSG7          Length of message
         BAL   R14,ISSUE000        Go stack the message
*
         MVC   MTEXT,BLANKS        Clear work area
         LA    R6,ASIDTAB
         LA    R5,24
*
CMD170   EQU   *
         CLC   0(24,R6),BLANKS
         BE    CMD180
         MVC   MTEXT(24),0(R6)
         LA    R1,24
         BAL   R14,ISSUE000
*
CMD180   EQU   *
         LA    R6,24(,R6)
         BCT   R5,CMD170
         B     XITCMG00            And exit command processing
*
* CPLEVEL
CMD190   EQU   *
         MVC   MTEXT,BLANKS        Clear work area
         LA    R1,CPUID            -> CPUID info                   v211
         UNPK  TWRK(13),0(7,R1)    Make part of CPI displayable
         TR    TWRK(12),HEXTRAN-240 Make char hex
*
         MVC   MTEXT(L'CMSG8),CMSG8  Move msg model
         MVC   MTEXT+30(4),TWRK+8  Move CPU model
         MVC   MTEXT+38(8),TWRK    Move CPU ID
         L     R1,16               -> CVT
         L     R2,CVTSMCA-CVT(,R1) -> SMCA                         v210
         MVC   MTEXT+52(4),SMCASID-SMCABASE(R2)  Move system id    v210
         S     R1,=F'40'           Back up into CVT prefix area    v210
         CLI   0(R1),C' '          Is anything there?              v210
         BNH   CMD195              Blank or zeros...no             v210
         MVC   MTEXT+9(15),0(R1)   Report whatever you find        v210
*
CMD195   EQU   *                                                   v210
         LA    R1,L'CMSG8          Length of message
         BAL   R14,ISSUE000        Go stack the message
*
         MVC   MTEXT,BLANKS        Clear work area
         MVC   MTEXT(L'CMSG8A),CMSG8A  Move msg model
         LA    R1,L'CMSG8A         Length of message
         BAL   R14,ISSUE000        Go stack the message
         B     XITCMG00            And exit command processing
*
* Q SYS
CMD200   EQU   *
         TRT   0(096,R1),BLANK     Look for end of string
         TRT   0(096,R1),NONBLANK  Look for 4nd string in cmd text
         BZ    CMD205              Not found, its just Q SYstem
* Possible Q SYS RO?
         CLC   =C'RO',0(R1)        Is this a Q SYS ROutes?
         BE    CMD400              Yes
         B     CMD700              Nope, whatever it is disallow it
* NODES
CMD205   EQU   *
         MVC   MTEXT,BLANKS        Clear work area
         L     R6,ALINKS           -> LINKS anchor word            v211
         L     R6,0(,R6)           -> first LINKTABL entry         v211
         USING LINKTABL,R6
         ICM   R6,15,LNEXT         Skip over local entry           v211
         BZ    CMD225              Exit if no links defined        v211
*
         MVC   MTEXT(L'CMSG3),CMSG3  Move msg
         MVC   MTEXT+L'CMSG3(8),LCLNODE Plug local node name to msgv211
         LA    R1,L'CMSG3+8        Length of message
         BAL   R14,ISSUE000        Go stack the message
*
         MVC   MTEXT,BLANKS        Clear work area
         MVC   MTEXT(L'CMSG4),CMSG4  Move msg
         LA    R1,L'CMSG4          Length of message
         BAL   R14,ISSUE000        Go stack the message
*
*
CMD210   EQU   *
         MVC   MTEXT,BLANKS        Clear work area
         MVC   MTEXT(L'CMSG5),CMSG5  Move msg
         MVC   MTEXT(8),LINKID     Move link id
         UNPK  DBLE(4),LDEFLINE(3) Convert CUU of line             v211
         TR    DBLE(3),HEXTRAN-240
         MVC   MTEXT+29(3),DBLE
         TM    LFLAG,LACTIVE       Is line in active status?
         BZ    *+10                No
         MVC   MTEXT+9(8),=CL8'Active'
         TM    LFLAG,LDRAIN        Is line in drain status?
         BZ    *+10                No
         MVC   MTEXT+9(8),=CL8'Draining'
         TM    LFLAG,LCONNECT      Is line in connect status?
         BZ    *+10                No
         MVC   MTEXT+9(8),=CL8'Connect'
*
         LH    R1,LBUFF            Get defined max buffer size     v211
         TM    LFLAG,LCONNECT      Is line in connect status?      v211
         BZ    CMD220              No                              v211
         LH    R1,LNEGO            Connected: show negotiated size v211
*
CMD220   EQU   *                                                   v211
         CVD   R1,DBLE             Convert
         MVC   MTEXT+34(6),=X'402020202120'  Mask
         ED    MTEXT+34(6),DBLE+5  Edit size
*
         LA    R1,L'CMSG5          Length of message
         BAL   R14,ISSUE000        Go stack the message
*
         ICM   R6,15,LNEXT         -> next LINKTABL entry
         BNZ   CMD210              Keep searching
         DROP  R6                  LINKTABL
         B     XITCMG00            And exit command processing
*
CMD225   EQU   *                                                   v211
         MVC   MTEXT,BLANKS        Clear work area                 v211
         MVC   MTEXT(L'CMSG43),CMSG43 No links defined             v211
         LA    R1,L'CMSG43         Length of message               v211
         BAL   R14,ISSUE000        Go stack the message            v211
         B     XITCMG00            And exit command processing     v211
*
* RESET ###                        Check for possible file number  v120
*                                                                  v120
CMD230   EQU   *                                                   v120
         TRT   0(096,R1),BLANK     Look for end of command name    v120
         BZ    CMD700              Invalid                         v120
         TRT   0(096,R1),NONBLANK  Look for 2nd string in cmd text v120
         BZ    CMD700              Not found, inv command          v120
*
         LR    R4,R1               Save start of possible file #   v120
         XC    TRTAB,TRTAB         Init translate table            v120
         MVI   TRTAB+C',',X'FF'    Search for ',' chars            v120
         TRT   0(096,R1),TRTAB     Look for end of numerics        v120
         BZ    CMD700              Not found, inv command          v120
*                                                                  v120
         LR    R2,R1               Save position of comma          v110
         SR    R1,R4               Compute length of string        v120
         C     R1,=F'4'            4-char or less?                 v120
         BH    CMD390              No, not valid file #            v120
         BCTR  R1,0                Adjust for execute              v120
         EX    R1,CMDMV1           Make a copy of specified #      v120
         EX    R1,CMDOC1           Force copy numeric              v120
         EX    R1,CMDCL1           Was original numeric?           v120
         BNE   CMD390              No, invalid file number         v120
         EX    R1,CMDPK1           Pack the number                 v120
         CVB   R1,DBLE             Convert file #                  v120
*                                                                  v120
*                                  r1 = file num                   v120
*                                  r2 -> comma at end of file num  v120
         LA    R0,E####            Load E filenum function code    v120
         L     R15,=A(NJECMH)      -> extended general commands rtnv120
         BALR  R14,R15             Go handle the command           v120
         B     XITCMG00            Done with command               v120
*
* DISPLAY ###                      Check for possible file number  v110
*                                                                  v110
CMD240   EQU   *                                                   v110
         LR    R4,R1               Save start of possible file #   v110
         TRT   0(096,R1),BLANK     Look for end of numerics        v110
         BZ    CMD700              Not found, inv command          v110
*                                                                  v110
         SR    R1,R4               Compute length of string        v110
         C     R1,=F'4'            4-char or less?                 v110
         BH    CMD390              No, not valid file #            v110
         BCTR  R1,0                Adjust for execute              v110
         EX    R1,CMDMV1           Make a copy of specified #      v110
         EX    R1,CMDOC1           Force copy numeric              v110
         EX    R1,CMDCL1           Was original numeric?           v110
         BNE   CMD390              No, invalid file number         v110
         EX    R1,CMDPK1           Pack the number                 v110
         CVB   R1,DBLE             Convert file #                  v110
*                                                                  v110
*                                  r1 = file num                   v120
         LA    R0,D####            Load D filenum function code    v110
         L     R15,=A(NJECMH)      -> extended general commands rtnv110
         BALR  R14,R15             Go handle the command           v110
         B     XITCMG00            Done with command               v110
*
* FILES
CMD250   EQU   *
         XC    NCB1,NCB1           Init NCB
         LA    R2,NCB1             -> NCB area
         USING NCB,R2
*
         NSIO  TYPE=OPEN,          Open dataset                        x
               NCB=(R2),                                           v210x
               ENTRY=ANJESPL                                       v210
         LTR   R15,R15             Any errors?
         BZ    CMD255              No
         BAL   R14,FMT000          Display error
         B     U0039               Abend on VSAM error
*
CMD255   EQU   *
         NSIO  TYPE=CONTENTS,      get directory contents              x
               NCB=(R2),                                           v210x
               ENTRY=ANJESPL                                       v210
         LTR   R15,R15             Any errors?
         BZ    CMD260
         ICM   R5,3,NCBRTNCD       Save error codes for now
*
CMD260   EQU   *
         NSIO  TYPE=CLOSE,         Close dataet                        x
               NCB=(R2),                                           v210x
               ENTRY=ANJESPL                                       v210
*
         CLM   R5,3,=AL1(12,6)     Were no directory entries returned?
         BE    CMD280              Correct
         CLM   R5,2,=AL1(0)        Were there any error codes?
         BZ    CMD265              No
         STCM  R5,3,NCBRTNCD       Restore codes for formatting    v110
         BAL   R14,FMT000          Display error
         B     U0039               Abend on VSAM error
*
CMD265   EQU   *
         MVC   MTEXT,BLANKS        Clear work area
         MVC   MTEXT(L'CMSG9),CMSG9  Move msg
         MVC   MTEXT+L'CMSG9(8),LCLNODE Plug local node name to msgv211
         LA    R1,L'CMSG9+8        Length of message
         BAL   R14,ISSUE000        Go stack the message
*
         MVC   MTEXT,BLANKS        Clear work area
         MVC   MTEXT(L'CMSG10),CMSG10 Move msg
         LA    R1,L'CMSG10         Length of message
         BAL   R14,ISSUE000        Go stack the message
*
         MVC   MTEXT,BLANKS        Clear work area
         MVC   MTEXT(L'CMSG11),CMSG11 Move msg
         LA    R1,L'CMSG11         Length of message
         BAL   R14,ISSUE000        Go stack the message
*
         MVC   MTEXT,BLANKS        Clear work area
         MVC   MTEXT(L'CMSG12),CMSG12 Move msg
*
         L     R6,NCBAREA          -> returned directory entries
         USING NSDIR,R6
         SR    R5,R5
         ICM   R5,3,NCBRECCT       # of returned entries
*
CMD270   EQU   *
         MVC   MTEXT,BLANKS        Clear work area
         LH    R1,NSID             Get file id number
         CVD   R1,DBLE             Convert
         UNPK  MTEXT(4),DBLE
         OI    MTEXT+3,X'F0'
         MVC   MTEXT+06(8),NSINLOC  Origin node
         MVC   MTEXT+15(8),NSINVM   Origin userid
         MVC   MTEXT+25(8),NSTOLOC  Destination node
         MVC   MTEXT+34(8),NSTOVM   Destination userid
         MVC   MTEXT+44(1),NSCLASS  Class
*
         MVC   MTEXT+45(10),=X'40206B2020206B202120'
         L     R1,NSRECNM          Get # of records in file
         CVD   R1,DBLE             Convert
         ED    MTEXT+45(10),DBLE+4 Edit result
*
         LA    R1,L'CMSG12         Length of msg
         BAL   R14,ISSUE000        Stack it
*
         AH    R6,NCBRECLN         -> next directory entry
         BCT   R5,CMD270           Loop through entries
         DROP  R6                  NSDIR
*
         LM    R0,R1,NCBAREAL      Get list length and address
         XC    NCBAREA,NCBAREA     Clear obsolete ptr
         FREEMAIN RU,LV=(0),A=(1)
         B     CMD290              Display % full                  v200
*
CMD280   EQU   *                   No files queued
         MVC   MTEXT,BLANKS        Clear work area
         MVC   MTEXT(L'CMSG9),CMSG9  Move msg
         MVC   MTEXT+L'CMSG9(8),LCLNODE Plug local node name to msgv211
         LA    R1,L'CMSG9+8        Length of message               v102
         BAL   R14,ISSUE000        Go stack the message
         MVC   MTEXT,BLANKS        Clear work area
         MVC   MTEXT(L'CMSG13),CMSG13  Move msg
         LA    R1,L'CMSG13         Length of message
         BAL   R14,ISSUE000        Go stack the message
*
CMD290   EQU   *                                                   v200
         MVC   MTEXT,BLANKS        Clear work area                 v200
         MVC   MTEXT(L'CMSG26),CMSG26  Move msg                    v200
         LH    R3,NCBPCT           Get spool full %                v200
         CVD   R3,DBLE             Convert % full                  v200
         UNPK  MTEXT+6(2),DBLE     Unpk                            v200
         OI    MTEXT+7,X'F0'       Fix sign                        v200
         LA    R1,L'CMSG26         Length of message               v200
         BAL   R14,ISSUE000        Go stack the message            v200
         B     XITCMG00            Exit command function completed v200
*
* CANCEL #
CMD300   EQU   *
         TRT   0(096,R1),BLANK     Look for end of string
         BZ    CMD700              Invalid
         TRT   0(096,R1),NONBLANK  Look for 2nd string in cmd text
         BZ    CMD700              Not found, inv command
*
         XC    BLNKDASH,BLNKDASH   Set up special translate table
         MVI   BLNKDASH+C' ',X'04' Code 4 for a blank
         MVI   BLNKDASH+C'-',X'08' Code 8 for a dash
*
         LR    R4,R1               Save start of possible file #
         SR    R2,R2               Clear for TRT
         TRT   0(096,R1),BLNKDASH  Look for end of 1st number
         BZ    CMD700              Invalid
         LR    R0,R1               Save position of blank or dash char
         SR    R1,R4               Compute length of string
         C     R1,=F'4'            4-char or less?
         BH    CMD390              No, not valid file #
         BCTR  R1,0                Adjust for execute
         EX    R1,CMDMV1           Make a copy of specified #
         EX    R1,CMDOC1           Force copy numeric
         EX    R1,CMDCL1           Was original numeric?
         BNE   CMD390              No, invalid file number
         EX    R1,CMDPK1           Pack the number
         CVB   R5,DBLE             Convert starting file #
         LR    R6,R5               Ending file # is the same
*
         CLM   R2,1,=X'08'         Was a dash char the delimiter?
         BNE   CMD310              No, just delete one file
*
         LR    R1,R0               -> to the delimiting dash char
         LA    R4,1(,R1)           -> next char (presumably a digit)
         TRT   0(096,R1),BLANK     Look for end of string
         BZ    CMD700              Invalid
         SR    R1,R4               Compute length of string
         C     R1,=F'4'            4-char or less?
         BH    CMD390              No, not valid file #
         BCTR  R1,0                Adjust for execute
         EX    R1,CMDMV1           Make a copy of specified #
         EX    R1,CMDOC1           Force copy numeric
         EX    R1,CMDCL1           Was original numeric?
         BNE   CMD390              No, invalid file number
         EX    R1,CMDPK1           Pack the number
         CVB   R6,DBLE             Convert ending file #
         OI    NJFL1,NJF1MULT      Indicate multi-file cancel
         B     CMD310
*
CMDMV1   MVC   DBLE(0),0(R4)       executed instr
CMDOC1   OC    DBLE(0),=4C'0'      executed instr
CMDCL1   CLC   DBLE(0),0(R4)       executed instr
CMDPK1   PACK  DBLE(8),0(0,R4)     executed instr
*
CMD310   EQU   *
         XC    NCB1,NCB1           Init NCB
         LA    R2,NCB1             -> NCB area
         USING NCB,R2
*
         NSIO  TYPE=OPEN,          Open dataset                        x
               NCB=(R2),                                           v210x
               ENTRY=ANJESPL                                       v210
         LTR   R15,R15             Any errors?
         BZ    CMD320              No
         BAL   R14,FMT000          Display error
         B     U0039               Abend on VSAM error
*
CMD320   EQU   *
         NSIO  TYPE=CONTENTS,      get directory contents              x
               NCB=(R2),                                           v210x
               ENTRY=ANJESPL                                       v210
         LTR   R15,R15             Any errors?
         BZ    CMD330              No
         CLC   NCBRTNCD(2),=AL1(12,6) No files in spool?           v110
         BE    CMD370              True                            v110
         BAL   R14,FMT000          Display error
         B     U0039               Abend on VSAM error
*
CMD330   EQU   *
         L     R3,NCBAREA          -> returned directory entries
         USING NSDIR,R3
         SR    R4,R4
         ICM   R4,3,NCBRECCT       # of returned entries
*
CMD340   EQU   *
         LH    R14,NSID            Get a file number
         CR    R14,R5              Is file number in cancel range?
         BL    CMD360              N, get next
         CR    R14,R6              Is file number in cancel range?
         BH    CMD360              N, get next
*
         TM    NJFL1,NJF1AUTH      Is issuing user cmd authorized?
         BO    CMD348              Yes, continue
*
*-- See if file originated from command issuing user. YES=ALLOW
         CLC   CMDLINK,NSINLOC     Is file here on issuer's node?
         BNE   CMD344              Nope cant cncl files on other nodes
         CLC   CMDVMID,NSINVM      Does userid match issuer's ?
         BE    CMD348              Yes, allow the cancel
*
*-- See if file was destined for command issuing user.  YES=ALLOW
CMD344   EQU   *
         CLC   CMDLINK,NSTOLOC     Was file dest = cmd issuer's node?
         BNE   CMD360              Nope cant cncl files on other nodes
         CLC   CMDVMID,NSTOVM      Does userid match issuer's ?
         BNE   CMD360              No, disallow the cancel
*
CMD348   EQU   *
         LA    R15,TDATA           -> tag data area
         USING TAG,R15
         STH   R14,TAGID           Save file id in tag data
         DROP  R15                 TAG
*
         NSIO  TYPE=PURGE,         Purge the file by file #            x
               NCB=(R2),                                               x
               TAG=(R15),                                          v210x
               ENTRY=ANJESPL                                       v210
         LTR   R15,R15             Any errors?
         BZ    CMD350              No
         CLC   NCBRTNCD(2),=AL1(12,4) Was file # not found in NETSPOOL?
         BE    CMD360              True
         BAL   R14,FMT000          Display other error
         B     U0039               Abend on VSAM error
*
CMD350   EQU   *
         OI    NJFL1,NJF1CNCL      Indic at least one file purged
         LH    R1,NSID             Get the file number
         CVD   R1,DBLE             Convert file #
         UNPK  TWRK(4),DBLE        Add zones
         OI    TWRK+3,X'F0'        Fix sign
         MVC   MTEXT,BLANKS        Clear work area
         MVC   MTEXT(L'CMSG14),CMSG14  Move msg
         MVC   MTEXT+14(4),TWRK    Insert file number
         LA    R1,L'CMSG14         Length of message
         BAL   R14,ISSUE000        Go stack the message
*
CMD360   EQU   *
         LA    R3,NSDIRLN(,R3)     -> next dir entry
         BCT   R4,CMD340           Keep scanning for files to purge
         DROP  R3                  NSDIR
*
CMD370   EQU   *
         NSIO  TYPE=CLOSE,         Done with dataset                   x
               NCB=(R2),                                           v210x
               ENTRY=ANJESPL                                       v210
*
         LM    R0,R1,NCBAREAL      Get list length and address
         LTR   R1,R1               Was an area returned?           v110
         BZ    CMD380              No; avoid freemain              v110
         XC    NCBAREA,NCBAREA     Clear obsolete ptr
         FREEMAIN RU,LV=(0),A=(1)
         DROP  R2                  NCB
*
         TM    NJFL1,NJF1CNCL      Were any files successfully purged?
         BO    XITCMG00            Yes, done with command
*
CMD380   EQU   *                   File was not found
         MVC   MTEXT,BLANKS        Clear work area
         MVC   MTEXT(L'CMSG15),CMSG15  Move msg
         LA    R1,L'CMSG15         Length of message
         BAL   R14,ISSUE000        Go stack the message
         B     XITCMG00            Exit command function completed
*
CMD390   EQU   *                   Invalid file # specified
         MVC   MTEXT,BLANKS        Clear work area
         MVC   MTEXT(L'CMSG16),CMSG16  Move msg
         LA    R1,L'CMSG16         Length of message
         BAL   R14,ISSUE000        Go stack the message
         B     XITCMG00            Exit command function completed
*
* D ROUTES / Q SYS ROUTES
CMD400   EQU   *
         MVC   MTEXT,BLANKS        Clear work area
*
         MVC   MTEXT(L'CMSG20),CMSG20  Move msg
         MVC   MTEXT+L'CMSG20(8),LCLNODE Plug local node nm to msg v211
         LA    R1,L'CMSG20+8       Length of message
         BAL   R14,ISSUE000        Go stack the message
*
         L     R5,AROUTES          -> ROUTES anchor word           v211
         ICM   R5,15,0(R5)         -> RTE chain                    v211
         BZ    CMD430              If 0, no routes found
         USING RTE,R5                                              v211
*
         MVC   MTEXT,BLANKS        Clear work area                 v211
         MVC   MTEXT(L'CMSG22),CMSG22  Move header                 v211
         LA    R1,L'CMSG22         Length of message               v211
         BAL   R14,ISSUE000        Go stack the message            v211
*
CMD410   EQU   *
         MVC   MTEXT,BLANKS        Clear work area
         MVC   MTEXT+00(8),ROUTNAME Move node name                 v211
         MVC   MTEXT+10(8),ROUTNEXT Move route-to name             v211
         MVC   MTEXT+22(8),ROUTALT1 Move alternate name            v211
         MVC   MTEXT+31(8),ROUTALT2                                v211
         MVC   MTEXT+40(8),ROUTALT3                                v211
*  ST R5,DBLE
*  UNPK TWRK(9),DBLE(5)
*  TR TWRK(8),HEXTRAN-240
*  MVC MTEXT+40(8),TWRK
         LA    R1,48               Max Length of message           v211
         BAL   R14,ISSUE000        Go stack the message
*
CMD420   EQU   *
         ICM   R5,15,ROUTPTR       -> next RTE                     v211
         BNZ   CMD410              Keep looking                    v211
         DROP  R5                  RTE                             v211
         B     XITCMG00            All done
*
CMD430   EQU   *
         MVC   MTEXT,BLANKS        Clear work area                 v102
         MVC   MTEXT(L'CMSG21),CMSG21  Move msg, no routes defined
         LA    R1,L'CMSG21         Length of message
         BAL   R14,ISSUE000        Go stack the message
         B     XITCMG00            Exit command function completed
*
* D AUTH
CMD450   EQU   *
         TM    NJFL1,NJF1AUTH      Is user cmd authorized?         v200
         BZ    NOTAUTH             Not auth for command            v200
         MVC   MTEXT,BLANKS        Clear work area
*
         MVC   MTEXT(L'CMSG24),CMSG24  Move msg
         MVC   MTEXT+L'CMSG24(8),LCLNODE Plug local node nm to msg v211
         LA    R1,L'CMSG24+8       Length of message
         BAL   R14,ISSUE000        Go stack the message
*
         NI    NJFL1,255-NJF1DATH  Init flag bit                   v102
         L     R5,AAUTHS           -> AUTHLIST chain anchor        v211
         ICM   R5,15,0(R5)         -> AUTHLIST chain               v211
         BZ    CMD480              No authorized users             v211
         USING AUTHLIST,R5                                         v211
*
CMD460   EQU   *
         OI    NJFL1,NJF1DATH      Indicate auth user displayed    v102
         MVC   MTEXT,BLANKS        Clear work area
         MVC   MTEXT(4),=C'User'
         MVC   MTEXT+5(8),AUTHUSER Move user name                  v211
         TRT   MTEXT+5(9),BLANK    Look for end
         MVC   1(2,R1),=C'at'
         MVC   4(8,R1),AUTHNODE    Move link name                  v211
         LA    R1,25               Max Length of message
         BAL   R14,ISSUE000        Go stack the message
*
CMD470   EQU   *
         ICM   R5,15,AUTHPTR       Next auth entry                 v211
         BNZ   CMD460              Keep looking                    v211
         DROP  R5                  AUTHLIST                        v211
         TM    NJFL1,NJF1DATH      Were any users displayed?       v102
         BO    XITCMG00            Yes, all done                   v102
*
CMD480   EQU   *
         MVC   MTEXT,BLANKS        Clear work area                 v102
         MVC   MTEXT(L'CMSG25),CMSG25  Move msg, no auth users
         LA    R1,L'CMSG25         Length of message
         BAL   R14,ISSUE000        Go stack the message
         B     XITCMG00            Exit command function completed
*
*
*-- Handle "D nodeid"
*
CMD500   EQU   *                   Handle unknown command
         LR    R3,R1               -> start of possible nodeid
         TRT   0(9,R1),BLANK       Look for end of nodeid
         BZ    CMD700              Not valid, unknown
         SR    R1,R3               Compute length of nodeid
         BCTR  R1,0                Adjust for execute
         MVC   TWRK,BLANKS         Init receiving field
         EX    R1,TMPMVC           Move in the nodeid
*TMPMVC  MVC   TWRK(0),0(R3)
         SR    R6,R6               R6=0 assume nodeid not found
*
         LA    R1,TWRK             -> node id
         BAL   R14,FLNK000         Try to find the link
         BZ    CMD540              Its not a link name. Try route
*
*-- Show link status for this 'nodeid'
*
         LA    R6,1                Indicate nodeid was found
         USING LINKTABL,R2
         MVC   MTEXT,BLANKS        Clear work area
         MVC   MTEXT(4),=C'Link'
         LA    R1,4                Length of message
         BAL   R14,ISSUE000        Go stack the message
         MVC   MTEXT(L'CMSG4),CMSG4  Move msg hdr
         LA    R1,L'CMSG4          Length of message
         BAL   R14,ISSUE000        Go stack the message
*
         MVC   MTEXT,BLANKS        Clear work area
         MVC   MTEXT(L'CMSG5),CMSG5  Move msg
         MVC   MTEXT(8),LINKID     Move link id
         UNPK  DBLE(4),LDEFLINE(3) Convert CUU of line             v211
         TR    DBLE(3),HEXTRAN-240
         MVC   MTEXT+29(3),DBLE
         TM    LFLAG,LACTIVE       Is line in active status?
         BZ    *+10                No
         MVC   MTEXT+9(8),=CL8'Active'
         TM    LFLAG,LDRAIN        Is line in drain status?
         BZ    *+10                No
         MVC   MTEXT+9(8),=CL8'Draining'
         TM    LFLAG,LCONNECT      Is line in connect status?
         BZ    *+10                No
         MVC   MTEXT+9(8),=CL8'Connect'
*
         LH    R1,LBUFF            Get defined max buffer size     v211
         TM    LFLAG,LCONNECT      Is line in connect status?      v211
         BZ    CMD520              No                              v211
         LH    R1,LNEGO            Connected: show negotiated size v211
*
CMD520   EQU   *                                                   v211
         CVD   R1,DBLE             Convert
         MVC   MTEXT+34(6),=X'402020202120'  Mask
         ED    MTEXT+34(6),DBLE+5  Edit size
*
         LA    R1,L'CMSG5          Length of message
         BAL   R14,ISSUE000        Go stack the message
*
CMD540   EQU   *
         L     R5,AROUTES              -> ROUTES anchor word       v211
         ICM   R5,15,0(R5)             -> RTE list chain           v211
         BZ    CMD570                  Exit if no RTE list         v211
         USING RTE,R5                                              v211
*
CMD550   EQU   *
         LA    R14,ROUTNAME        -> name from route list         v211
         LA    R15,8               max length                      v211
         LA    R6,TWRK             -> selected name to locate      v211
         LR    R7,R15              copy length                     v211
         CLCL  R14,R6              Did we locate the name?         v211
         BE    CMD560              Yes                             v211
         CLI   0(R14),C'*'         Wildcard was in the name?       v211
         BE    CMD560              Then we matched to that point   v211
******   CLC   ROUTNAME,TWRK       Is name in route list?          v211
******   BE    CMD560              Found it                        v211
         ICM   R5,15,ROUTPTR       -> Next route entry             v211
         BNZ   CMD550              Keep looking                    v211
         B     CMD570              No matching route               v211
*
*-- Show route status for this 'nodeid'
*
CMD560   EQU   *
         LA    R6,1                Indicate nodeid was found
*
         MVC   MTEXT,BLANKS        Clear work area
         MVC   MTEXT(5),=C'Route'
         LA    R1,5                Length of message
         BAL   R14,ISSUE000        Go stack the message
         MVC   MTEXT(L'CMSG22),CMSG22  Move header                 v211
         LA    R1,L'CMSG22         Length of message               v211
         BAL   R14,ISSUE000        Go stack the message            v211
*
         MVC   MTEXT,BLANKS        Clear work area
         MVC   MTEXT+00(8),ROUTNAME Move node name                 v211
         MVC   MTEXT+10(8),ROUTNEXT Move route-to name             v211
         MVC   MTEXT+22(8),ROUTALT1 Move alternate name            v211
         MVC   MTEXT+31(8),ROUTALT2                                v211
         MVC   MTEXT+40(8),ROUTALT3                                v211
         DROP  R5                  RTE
         LA    R1,48               Max Length of message           v211
         BAL   R14,ISSUE000        Go stack the message
         B     XITCMG00            Exit command function completed
*
CMD570   EQU   *
         LTR   R6,R6               Was nodeid found as link/route?
         BNZ   XITCMG00            Yes, our work is done here
*
         MVC   MTEXT,BLANKS        Clear work area                 v211
         MVC   MTEXT(L'CMSG40),CMSG40  Move msg                    v211
         MVC   MTEXT+13(8),TWRK    Insert node name
         TRT   MTEXT+13(9),BLANK   Look for end
         MVC   1(14,R1),=C'is not defined'
         LA    R1,13+8+15          Length if msg
         BAL   R14,ISSUE000        Go stack the message
         B     XITCMG00            Exit command function completed
*
TMPMVC   MVC   TWRK(0),0(R3)       executed instr
*
*
*
*-- Handle "unknown command"
*
CMD700   EQU   *                   Handle unknown command
         MVC   MTEXT,BLANKS                                        v200
         MVC   MTEXT(L'CMSG1),CMSG1  Move in msg text
         SR    R5,R5               Clear
         IC    R5,CMDBLEN          Get cmd text IBM len
         LA    R2,CMDAREA          -> original cmd text image
         LA    R1,MTEXT+L'CMSG1+1  Where to place orig cmd text
         EX    R5,MVCCMD2          Move and uppercase              v200
*MVCCMD2 OC    0(0,R1),0(R2)                                       v200
         LA    R1,1(R5,R1)         -> end of built msg text
         LA    R2,MTEXT            -> start of built msg
         SR    R1,R2               Compute length of text
         BAL   R14,ISSUE000        Go stack the message
         B     XITCMG00            Exit command processing
*
MVCCMD2  OC    0(0,R1),0(R2)          executed instr               v200
*
*-- Exit command processing
*
*
XITCMG00 EQU   *
         SR    R15,R15             Set RC=0
*        B     XITCMG              And exit
*
*ITCMG04 EQU   *
*        LA    R15,4               Set RC=4
*
XITCMG   EQU   *
         L     R13,4(,R13)         -> prev s.a.
         ST    R15,16(,R13)        Set RC
         LM    R14,R12,12(R13)     Reload callers regs
         BR    R14                 Return with RC
*
*-- Build the display table of address spaces on behalf of the
*-- D ACTIVE command.
*
* On entry:
*
*    None.
*
* On exit:
*
*    ASIDTAB contains information about up to 24 address spaces.
*    Each ASIDTAB element is mapped by dsect ACTLINE.
*
DACT000  EQU   *
         LA    R0,ASIDTAB          Init formatted region display tab
         LA    R1,24*24            Length
         L     R15,=X'40000000'    Set pad
         MVCL  R0,R14              Clear it
*
         L     R1,16               Get CVT ptr
         USING CVT,R1
*
         L     R3,CVTASVT          -> ASVT
         USING ASVT,R3
*
         L     R4,CVTASCBH         -> highest prty ASCB
         USING ASCB,R4
         DROP  R1
*
GETCSCB  EQU   *
         L     R9,ASCBCSCB         -> CSCB
         USING CSCB,R9
         LTR   R9,R9               Is there a CSCB?
         BZ    NEXTASCB            No, get next ASCB
*
CHKCSCB  EQU   *
         CLC   CHKEY,=XL8'00'      Jobname zeroed?
         BE    NEXTCSCB            Y, skip this CSCB
         CLC   CHKEY,=CL8' '       Jobname is blank?
         BE    NEXTCSCB            Y, skip this CSCB
*
         LH    R6,CHASID           Get ASID from CSCB
         C     R6,=F'23'           Highest ASID we can display
         BH    DACT090             Done formatting table
*
         LR    R2,R6               Copy ASID
         MH    R2,=Y(L'ASIDTAB)    Make into table index
         LA    R2,ASIDTAB(R2)      -> slot in ASID line table
         USING ACTLINE,R2
*
         CVD   R6,DBLE             Convert to display
         UNPK  REGION(4),DBLE      Unpk for display
         OI    REGION+3,X'F0'      Fix sign
*
         CLC   CHKEY,=CL8'STARTING' Is this a starting task?
         BE    STARTING             Yes
         MVC   JOBNAME(8),CHKEY     Use that name for job
         CLC   CHPROCSN,=CL8' '     Is PROCSTEP blank?
         BE    PROCSTEP             Yes
         CLC   CHPROCSN,=XL8'00'    PROCSTEP zero?
         BE    PROCSTEP             Yes
*
         MVC   STEPNAME(8),CHPROCSN Use PROCSTEP name
         B     REGINIT
*
STARTING EQU   *
         MVC   JOBNAME(8),CHCLS     Set job name
         MVC   STEPNAME(8),=CL8'STARTING'  Set to Starting
         B     REGINIT
*
PROCSTEP EQU   *
         MVC   STEPNAME(8),CHCLS    Else use PROCSTEP
*
REGINIT  EQU   *
*        LH    R6,CHASID            Get ASID
         SLL   R6,2                 Get ASID times 4 - make index
         L     R4,ASVTFRST(R6)      ->  ASCB for this ASID
*
*        L     R6,ASCBTSB           Is there a TSB for this ASCB?
*        LA    R6,0(,R6)            Clear high order
*        LTR   R6,R6                Check if address present?
*        BNZ   TSOUSER              Yes, this is a TSO user
*
         B     NEXTCSCB
*
*
*SOUSER  EQU   *
*        MVC   REGION(3),=CL3' '    DONT DISPLAY TSO USERS
*
NEXTCSCB EQU   *
         L     R9,CHPTR             -> next CSCB
         LA    R9,0(,R9)            Clear high order
         LTR   R9,R9                Last CSCB?
         BNZ   CHKCSCB              No
         B     DACT090              Done
*
NEXTASCB EQU   *
         L     R4,ASCBFWDP          -> next ASCB
         LTR   R4,R4                last one?
         BNZ   GETCSCB              No
*
DACT090  EQU   *
         BR    R14                  Return to caller
*
         DROP  R2                   ACTLINE
         DROP  R3                   ASCB
         DROP  R4                   ASVT
         DROP  R9                   CSCB
*
         LTORG ,
*
*-- Error response:
CMSG1    DC    C'NJE011E Unrecognized command'
*
*-- D TIME response model:
CMSG2    DC    C'NJE163I  TIME=xx.xx.xx DATE=xx.xxx'
*
*-- D NODES response models:
CMSG43   DC    C'NJE043E No links defined'                         v211
CMSG3    DC    C'NJE012I  Node status for node '
CMSG4    DC    C'Name     Status    Type     Addr    Buff'
CMSG5    DC    C'xxxxxxxx Inactive  NJE       cuu    xxxx'
*                012345678901234567890123456789012345678901234567
*
*-- D ACTIVE response models:
CMSG6    DC    C'NJE013I  Active status for node '
CMSG7    DC    C'ASID  Jobname   Procstep'
*
*-- CPQ CPLEVEL response model:
CMSG8  DC C'NJE018I  OS/VS2 038 JES2, CPU=xxxx ID=xxxxxxxx  SYS=xxxx'
CMSG8A DC C'NJE019I  NJE38  &VERS   &SYSDATE &SYSTIME'             v210
*
*-- D FILES response models:
CMSG9  DC C'NJE014I  File status for node '
CMSG10 DC C'File  Origin   Origin    Dest     Dest'
CMSG11 DC C' ID   Node     Userid    Node     Userid    CL  Records'
CMSG12 DC C'xxxx  xxxxxxxx xxxxxxxx  xxxxxxxx xxxxxxxx  A x,xxx,xxx'
CMSG13 DC C'No files queued'
CMSG26 DC C'Spool xx% full'                                        v200
*           012345678901234567890123456789012345678901234567890123456
*
*                012345678901234567890123456789012345678901
*-- C #### response models:
CMSG14   DC    C'NJE015I  File(xxxx) purged'
CMSG15   DC    C'NJE016E  No eligible files found'
CMSG16   DC    C'NJE017E  Invalid file number specified'
*
*-- D ROUTES response models:
CMSG20   DC    C'NJE020I  Routes status for node '
CMSG21   DC    C'NJE021I  No routes defined'
CMSG22   DC    C'Node      Primary     Alternates'                 v211
*              C'ROUTNODE  ROUTNEXT    ROUTALT1 ROUTALT2 ROUTALT3' v211
CMSG40   DC    C'NJE040E Node x' is not defined                    v211
*
*CMSG23 available
*
*-- D AUTH  response models:
CMSG24   DC    C'NJE024I  Authorized users for node '
CMSG25   DC    C'NJE025I  No users authorized'
*
*
*-- Documentation:
*-- Example of stacked message format required by DMTXJE
*SAMPLE  DC    AL1(56,0)           length of stacked msg+node/user
*        DC    CL8'MVSA'           node name
*        DC    CL8'TSOUSER'        userid
*        DC    CL40'NJE163I  TIME=18.11.00 DATE=19.352'
*
*
*
*********************
*  N J E C M H      *               NJECMH handles additional
*                   *               general command processing
*  More general     *
*  commands         *
*                   *
*********************               Entire CSECT added             v110
*
NJECMH   CSECT
         B     28(,R15)               BRANCH AROUND EYECATCHERS
         DC    AL1(23)                LENGTH OF EYECATCHERS
         DC    CL9'NJECMH'
         DC    CL9'&SYSDATE'
         DC    CL5'&SYSTIME'
*
         STM   R14,R12,12(R13)         Save Regs
         LR    R12,R15                 Base
         USING NJECMH,R12
         USING NJEWK,R10
         LR    R3,R1                   Copy input parameter
         ST    R13,CMHSA+4             SAVE prv S.A. ADDR
         LA    R1,CMHSA                -> my save area
         ST    R1,8(,R13)              Plug it into prior SA
         LR    R13,R1
*
D####    EQU   0                   00 - Handle D filenum
E####    EQU   4                   04 - Handle E filenum           v120
*
         USING CMDBLOK,R8
         USING NJECOM,R11
*
*-- Additional general command processing
*
*-- R3 = file number                                               v120
*-- R2 -> character after last digit of file number in cmd image   v120
*
*
         LR    R15,R0              Copy input function code        v120
         B     FUNC000(R15)        Branch into table               v120
*
FUNC000  B     DNUM000             00 - handle D filenum
         B     ENUM000             04 - handle E filenum           v120
*
*
*-- Display filenum
*     Entry:  R3 = file number
*
DNUM000  EQU   *
         XC    NCB1,NCB1           Init NCB
         LA    R2,NCB1             -> NCB area
         USING NCB,R2
*
         NSIO  TYPE=OPEN,          Open dataset                        x
               NCB=(R2),                                           v210x
               ENTRY=ANJESPL                                       v210
         LTR   R15,R15             Any errors?
         BZ    DNUM020             No
         BAL   R14,FMT000          Display error
         B     U0039               Abend on VSAM error
*
DNUM020  EQU   *
         LA    R6,TDATA            -> tag data area
         USING TAG,R6
         STH   R3,TAGID            Set file # to find
*
         NSIO  TYPE=FIND,          get directory entry                 x
               NCB=(R2),                                               x
               TAG=(R6),           Where to place tag data         v210x
               ENTRY=ANJESPL                                       v210
         LTR   R15,R15             Any errors?
         BZ    DNUM040
         CLC   NCBRTNCD(2),=AL1(12,4) Was specified file id not found?
         BE    DNUM900             Yes
         BAL   R14,FMT000          Otherwise, display error
         B     U0039               Abend on VSAM error
*
DNUM040  EQU   *
         MVC   MTEXT,BLANKS        Clear work area
         MVC   MTEXT(L'NJE026I),NJE026I Move msg
         MVC   MTEXT+L'NJE026I(8),LCLNODE Plug local node nm to msgv211
         LA    R1,L'NJE026I+8      Length of message
         BAL   R14,ISSUE000        Go stack the message
*
         MVC   MTEXT,BLANKS        Clear work area
         MVC   MTEXT(L'N026A),N026A Move msg
         LA    R1,L'N026A          Length of message
         BAL   R14,ISSUE000        Go stack the message
*
         MVC   MTEXT,BLANKS        Clear work area
         MVC   MTEXT(L'N026B),N026B Move msg
         LA    R1,L'N026B          Length of message
         BAL   R14,ISSUE000        Go stack the message
*
         MVC   MTEXT,BLANKS        Clear work area
         MVC   MTEXT(L'N026C),N026C Move msg
*
DNUM050  EQU   *
         MVC   MTEXT,BLANKS        Clear work area
         LH    R1,TAGID            Get file id number
         CVD   R1,DBLE             Convert
         UNPK  MTEXT(4),DBLE
         OI    MTEXT+3,X'F0'
         MVC   MTEXT+06(8),TAGINLOC  Origin node
         MVC   MTEXT+15(8),TAGINVM   Origin userid
         MVC   MTEXT+25(8),TAGTOLOC  Destination node
         MVC   MTEXT+34(8),TAGTOVM   Destination userid
         MVC   MTEXT+44(1),TAGCLASS  Class
*
         MVC   MTEXT+45(10),=X'40206B2020206B202120'
         L     R1,TAGRECNM         Get # of records in file
         CVD   R1,DBLE             Convert
         ED    MTEXT+45(10),DBLE+4 Edit result
*
         LA    R1,L'N026C          Length of msg
         BAL   R14,ISSUE000        Stack it
*
         TM    TAGINDEV,TYPPRT     Is it PRINT data?
         BO    DNUM060             Y, don't need to check for NETDATA
*
         L     R15,=A(NJECME)      NETDATA examination routine
         BALR  R14,R15             Go look for NETDATA
         LTR   R15,R15             Check RC
         BZ    DNUM070             All is well, we have NETDATA
*
DNUM060  EQU   *
         OI    NJFL1,NJF1NYET      No NETDATA or PRINT file
*
DNUM070  EQU   *
         MVC   MTEXT,BLANKS        Clear work area
         MVC   MTEXT(L'N026D),N026D  Move model msg
         LA    R1,MTEXT+L'N026D    -> end of model
         MVC   0(12,R1),TAGNAME    Move file name
*
         TRT   0(13,R1),BLANK      Look for end of file name
         LA    R1,1(,R1)           Skip blank
         MVC   0(12,R1),TAGTYPE    Move file type
*
         TRT   0(13,R1),BLANK      Look for end of file type
         LA    R1,3(,R1)           Skip 3 blanks
         MVC   0(11,R1),=C'Type: PRINT'  Assume print data
         LA    R1,6(,R1)           -> where to put format type
         TM    TAGINDEV,TYPPRT     Was it actually PRINT type?
         BO    DNUM080             Yes, display PRINT attr
*
         MVC   0(5,R1),=C'PUNCH'   Assume PUNCH unless its NETDATA
         TM    NJFL1,NJF1NYET      Was it NETDATA or PRINT file
         BO    DNUM100             No, display PUNCH attr
         MVC   0(7,R1),=C'NETDATA' Yes
         B     DNUM200             Display NETDATA attr
*
*-- Display for flat PRINT type file
*
DNUM080  EQU   *
         LA    R1,7(,R1)           -> end of message
         LA    R0,MTEXT            -> Start
         SR    R1,R0               compute length of msg
         BAL   R14,ISSUE000        Stack msg N026D
*
         MVC   MTEXT,BLANKS        Clear work area
         MVC   MTEXT(L'N026E),N026E  Move model msg
         LA    R1,MTEXT+L'N026E    -> end of model
         MVC   0(8,R1),=C'132/F/PS' Display all we know
         LA    R1,8(,R1)           Bump length
         BAL   R14,ISSUE000        Stack msg N026E
         B     DNUM990             Command function completed
*
*-- Display for flat PUNCH type file
*
DNUM100  EQU   *
         LA    R1,7(,R1)           -> end of message
         LA    R0,MTEXT            -> Start
         SR    R1,R0               compute length of msg
         BAL   R14,ISSUE000        Stack msg N026D
*
         MVC   MTEXT,BLANKS        Clear work area
         MVC   MTEXT(L'N026E),N026E  Move model msg
         LA    R1,MTEXT+L'N026E    -> end of model
         MVC   0(7,R1),=C'80/F/PS' Display all we know
         LA    R1,7(,R1)           Bump length
         BAL   R14,ISSUE000        Stack msg N026E
         B     DNUM990             Command function completed
*
*-- Display for NETDATA files
*
DNUM200  EQU   *
         LA    R1,7(,R1)           -> end of message
         LA    R0,MTEXT            -> Start
         SR    R1,R0               compute length of msg
         BAL   R14,ISSUE000        Stack msg N026D
*
         CLI   FFM,X'00'           Was a file mode present?
         BE    DNUM300             Its 0, so this is OS NETDATA
*
*-- Display for VM-based NETDATA files
*
DNUM210  EQU   *
         MVC   MTEXT,BLANKS        Clear work area
         MVC   MTEXT(L'N026E),N026E  Move model msg
         LA    R1,MTEXT+L'N026E    -> end of model
*
*-- Dont display BLKSIZE for VM files; it is meaningless
*        L     R4,BLKSIZE          Get the blocksize  value
*        CVD   R4,DBLE             Convert
*        BAL   R14,DSPNUM          Make number displayable
*        MVI   0(R1),C'/'
*        LA    R1,1(,R1)
*
         L     R4,LRECL            Get the lrecl value
         CVD   R4,DBLE             Convert
         BAL   R14,DSPNUM          Make number displayable
         MVI   0(R1),C'/'
         LA    R1,1(,R1)
*
         BAL   R14,DSPRECFM        Format the RECFM value
         MVI   0(R1),C'/'
         LA    R1,1(,R1)
*
         BAL   R14,DSPORG          Format the DSORG value
*
         LA    R1,4(,R1)           Skip some space in msg
         MVC   0(10,R1),=C'File size:'
         LA    R1,11(,R1)
         LM    R4,R5,FILESIZE      Get approx file size
         LA    R3,8                Max length of file size value
         LH    R0,FSIZELEN         Get length from NETDATA key
         SR    R3,R0               Compute # bytes of shift
         SLA   R3,3                Turn # bytes into # bits
         SRDL  R4,0(R3)            Right justify the filesize
         SRL   R5,10               divide by 1024 to get kilobytes
         LA    R5,1(,R5)           Always round up
         CVD   R5,DBLE             Convert
         BAL   R14,DSPNUM          Make number displayable
         MVC   1(2,R1),=C'KB'
         LA    R1,3(,R1)           -> end of msg
*
         LA    R0,MTEXT            -> Start
         SR    R1,R0               compute length of msg
         BAL   R14,ISSUE000        Stack msg N026E
         B     DNUM990
*
*-- Display for OS-based NETDATA files
*
DNUM300  EQU   *
         MVC   MTEXT,BLANKS        Clear work area
         MVC   MTEXT(L'N026E),N026E  Move model msg
         LA    R1,MTEXT+L'N026E    -> end of model
*
         L     R4,BLKSIZE          Get the blocksize  value
         CVD   R4,DBLE             Convert
         BAL   R14,DSPNUM          Make number displayable
         MVI   0(R1),C'/'
         LA    R1,1(,R1)
*
         TM    RECFM,DCBRECU       Is this a RECFM=U dataset?
         BO    DNUM310             Y, don't format LRECL
*
         L     R4,LRECL            Get the lrecl value
         CVD   R4,DBLE             Convert
         BAL   R14,DSPNUM          Make number displayable
         MVI   0(R1),C'/'
         LA    R1,1(,R1)
*
DNUM310  EQU   *
         BAL   R14,DSPRECFM        Format the RECFM value
         MVI   0(R1),C'/'
         LA    R1,1(,R1)
*
         BAL   R14,DSPORG          Format the DSORG value
*
         CLI   DSORG,X'02'         Is this DSORG=PO?
         BNE   DNUM330             No, skip dir blks
         LA    R1,3(,R1)           Skip some space in msg
         MVC   0(8,R1),=C'DIRBLKS:'
         LA    R1,9(,R1)
         LM    R4,R5,DIRBLKS       Get approx file size
         LA    R3,8                Max length of value
         LH    R0,DIRBLKLN         Get length from NETDATA key
         SR    R3,R0               Compute # bytes of shift
         SLA   R3,3                Turn # bytes into # bits
         SRDL  R4,0(R3)            Right justify the # dir blks
         CVD   R5,DBLE             Convert
         BAL   R14,DSPNUM          Make number displayable
*
DNUM330  EQU   *
         LA    R1,3(,R1)           Skip some space in msg
         MVC   0(10,R1),=C'File size:'
         LA    R1,11(,R1)
         LM    R4,R5,FILESIZE      Get approx file size
         LA    R3,8                Max length of file size value
         LH    R0,FSIZELEN         Get length from NETDATA key
         SR    R3,R0               Compute # bytes of shift
         SLA   R3,3                Turn # bytes into # bits
         SRDL  R4,0(R3)            Right justify the filesize
         SRL   R5,10               divide by 1024 to get kilobytes
         LA    R5,1(,R5)           Always round up
         CVD   R5,DBLE             Convert
         BAL   R14,DSPNUM          Make number displayable
         MVC   1(2,R1),=C'KB'
         LA    R1,3(,R1)           -> end of msg
*
         LA    R0,MTEXT            -> Start
         SR    R1,R0               compute length of msg
         BAL   R14,ISSUE000        Stack msg N026E
*
DNUM350  EQU   *
         MVC   MTEXT,BLANKS        Clear work area
         MVC   MTEXT(L'N026F),N026F  Move model msg
         LA    R1,MTEXT+L'N026F    -> end of model
         MVC   0(44,R1),DSNAME     Move DSNAME to msg
         LA    R1,L'N026F+44       Length of MSG + DSNAME          V110
         BAL   R14,ISSUE000        Stack msg N026F
         B     DNUM990
*
*-- Format a number to remove leading blanks and insert into msg line
*   Entry:  R1 -> where to place result
*   Exit :  R1 -> next available byte after result
*
DSPNUM   EQU   *
         LR    R15,R1              Save msg line position
         MVC   TWRK(8),=X'4020202020202120'
         LA    R1,TWRK+7           -> last digit area
         LR    R3,R1               Save a copy
         EDMK  TWRK(8),DBLE+4      Edit the number
         SR    R3,R1               Compute number's length
         EX    R3,DSPMVC           Move number to msg line
         LA    R1,1(R3,R15)        Compute next msg line byte
         BR    R14
DSPMVC   MVC   0(0,R15),0(R1)      executed instr
*
*-- Format the RECFM value
*   Entry:  Field 'RECFM' contains the record format bits
*   Exit :  R1 -> next available byte after result
*
DSPRECFM EQU   *
         MVI   0(R1),C'?'        Assume unknown RECFM              v130
         TM    RECFM+1,X'03'     Using shortened variable formats? v130
         BNZ   DSPV              Yes, start with V                 v130
         TM    RECFM,DCBRECF     FIXED?
         BZ    *+8
         MVI   0(R1),C'F'
         TM    RECFM,DCBRECV     VARIABLE?
         BZ    *+8
*
DSPV     EQU   *                                                   v130
         MVI   0(R1),C'V'
         TM    RECFM,DCBRECU     UNDEFINED?
         BNO   *+8
         MVI   0(R1),C'U'
         LA    R1,1(,R1)
*
         TM    RECFM,DCBRECBR    BLOCKED?
         BZ    *+12
         MVI   0(R1),C'B'
         LA    R1,1(,R1)
*
         TM    RECFM,DCBRECSB    SPANNED?
         BZ    *+12
         MVI   0(R1),C'S'
         LA    R1,1(,R1)
         TM    RECFM,DCBRECTO    TRACK OVERFLOW?
         BZ    *+12
         MVI   0(R1),C'T'
         LA    R1,1(,R1)
*
         TM    RECFM,DCBRECCA    ASA CONTROL CHAR?
         BZ    *+12
         MVI   0(R1),C'A'
         LA    R1,1(,R1)
         TM    RECFM,DCBRECCM    MACHINE CONTROL CHAR?
         BZ    *+12
         MVI   0(R1),C'M'
         LA    R1,1(,R1)
         BR    R14
*
*-- Format the DSORG value
*   Entry:  Field 'DSORG' contains the organization bits
*   Exit :  R1 -> next available byte after result
*
DSPORG   EQU   *
         MVC   0(2,R1),=C'? '    Assume unknown DSORG
         CLC   DSORG,=X'4000'    DSORG=PS?
         BNE   *+10
         MVC   0(2,R1),=C'PS'
         CLC   DSORG,=X'0200'    DSORG=PO?
         BNE   *+10
         MVC   0(2,R1),=C'PO'
         CLC   DSORG,=X'0008'    DSORG=VS?
         BNE   *+10
         MVC   0(2,R1),=C'VS'
         LA    R1,2(,R1)         -> next available byte
         BR    R14
*
DNUM900  EQU   *                ** Here if file not found
         LH    R1,TAGID            Get the file number
         CVD   R1,DBLE             Convert file #
         UNPK  TWRK(4),DBLE        Add zones
         OI    TWRK+3,X'F0'        Fix sign
         MVC   MTEXT,BLANKS        Clear work area
         MVC   MTEXT(L'NJE027E),NJE027E Move msg
         MVC   MTEXT+14(4),TWRK    Insert file number
         LA    R1,L'NJE027E        Length of message
         BAL   R14,ISSUE000        Go stack the message
*
*
DNUM990  EQU   *
         LA    R2,NCB1             -> NCB area
         NSIO  TYPE=CLOSE,         Close spool dataset                 x
               NCB=(R2),                                           v210x
               ENTRY=ANJESPL                                       v210
         DROP  R6                  TAG
         B     XITCMH00            Command function completed
*
*
*-- RESET filenum      Format:  RESET ##,dest=node.userid          v120
*                      Alt:     E ##,d=node.userid                 v120
*
*     Entry:  R2 -> comma at end of file num                       v120
*     Entry:  R3 = file number                                     v120
*
ENUM000  EQU   *                                                   v120
         TM    NJFL1,NJF1AUTH          Is user cmd authorized?     v120
         BZ    NOTAUTH                 Not auth for command        v120
         LA    R4,1(,R2)               Skip over the comma         v120
         CLC   =C'DEST=',0(R4)         Look for keyword            v120
         BE    ENUM010                 Got it                      v120
         CLC   =C'D=',0(R4)            Look for keyword            v120
         BE    ENUM020                 Got it                      v120
         B     ENUM910                 Invalid command format      v120
*
ENUM010  EQU   *                                                   v120
         LA    R4,5(,R4)               Skip over DEST=             v120
         B     ENUM030                                             v120
*
ENUM020  EQU   *                                                   v120
         LA    R4,2(,R4)               Skip over D=                v120
*
ENUM030  EQU   *                                                   v120
         XC    TRTAB,TRTAB             Set up translate table      v120
         MVI   TRTAB+C'.',X'FF'        Search for '.' chars        v120
*
         LA    R1,0(,R1)               Clear high order byte       v120
         TRT   0(18,R4),NONBLANK       Look for first char         v120
         BZ    ENUM910                 Invalid, nothing after '='  v120
         LR    R4,R1                   -> start of node id         v120
         TRT   0(18,R1),TRTAB          Look for '.'                v120
         BZ    ENUM910                 Invalid                     v120
         LA    R2,1(,R1)               -> position just past delim v120
         SR    R1,R4                   Compute node name length    v120
         BNP   ENUM910                 Exit if invalid             v120
         CH    R1,=H'8'                More than 8 char?           v120
         BH    ENUM910                 It is invalid               v120
*
         MVC   DESTNODE,BLANKS         Init receiving field        v120
         BCTR  R1,0                    Adjust for execute          v120
         EX    R1,MVCNODE              Move nodename               v120
*MVCNODE MVC   DESTNODE(0),0(R4)                                   v120
*
         LR    R4,R2                   -> start of userid          v120
         TRT   0(9,R2),BLANK           Look for blank              v120
         BZ    ENUM910                 Invalid                     v120
         SR    R1,R4                   Compute userid length       v120
         BNP   ENUM910                 Exit if invalid             v120
         CH    R1,=H'8'                More than 8 char?           v120
         BH    ENUM910                 It is invalid               v120
*
         MVC   DESTUSER,BLANKS         Init receiving field        v120
         BCTR  R1,0                    Adjust for execute          v120
         EX    R1,MVCUSER              Move nodename               v120
*MVCUSER MVC   DESTUSER(0),0(R4)                                   v120
*
*-- Check for local node or *                                      v120
*
ENUM050  EQU   *                                                   v120
         CLC   DESTNODE,LCLNODE        Reset to local node?        v211
         BE    ENUM100                 Yes, allow it               v120
         CLC   DESTNODE,=CL8'*'        Using * for local node?     v120
         BNE   ENUM060                 No, go validate             v120
         MVC   DESTNODE,LCLNODE        Replace with local node namev211
         B     ENUM100                 Use local node              v120
*
*-- Ensure Link or Route exists for new node name                  v120
*
ENUM060  EQU   *                                                   v120
         MVC   CMDNODE,DESTNODE        Copy desired new link name  v120
         LA    R1,CMDNODE              -> Link name to find        v120
         BAL   R14,FLNK000             Find the link name in table v120
         BZ    ENUM070                 Link doesnt exist; route?   v211
         TM    LFLAG-LINKTABL(R2),LCONNECT Is link connected?      v220
         BO    ENUM100                 Yes, use it                 v211
*
ENUM070  EQU   *                                                   v211
         BAL   R14,RLNK000             Check for matching route    v120
*        BZ    CMDE059                 No match, unknown link name v120
         BZ    AB111                   No match, unknown link name v120
         MVC   CMDNODE,0(R1)           Temp set route name         v211
*
*-- Ok, update the directory entry                                 v120
*
ENUM100  EQU   *                                                   v120
         XC    NCB1,NCB1               Init NCB                    v120
         LA    R2,NCB1                 -> NCB area                 v120
         USING NCB,R2                                              v120
*
         NSIO  TYPE=OPEN,              Open spool file             v120x
               NCB=(R2),                                           v210x
               ENTRY=ANJESPL                                       v210
         LTR   R15,R15                 Any errors?                 v120
         BZ    ENUM120                 No                          v120
         BAL   R14,FMT000              Display error               v120
         B     U0039                   Abend on VSAM error         v120
AB111 EQU *
  LR R3,R1
  ABEND 111,DUMP
*
ENUM120  EQU   *                                                   v120
         LA    R6,TDATA                -> tag data area            v120
         USING TAG,R6                                              v120
         STH   R3,TAGID                Set file # to find          v120
         MVC   TAGTOVM,DESTUSER        Userid to update            v120
         MVC   TAGTOLOC,DESTNODE       Nodeid to update            v120
*
         NSIO  TYPE=UDIR,              Update directory entry      v120x
               NCB=(R2),                                           v120x
               TAG=(R6),               Where to place tag data     v210x
               ENTRY=ANJESPL                                       v210
         LTR   R15,R15                 Any errors?                 v120
         BZ    ENUM140                                             v120
         CLC   NCBRTNCD(2),=AL1(12,4)  Was file id not found?      v120
         BE    ENUM900                 Yes                         v120
         BAL   R14,FMT000              Otherwise, display error    v120
         B     U0039                   Abend on VSAM error         v120
*
*-- Close the spool and then post the main NJE38 task that a "new" v120
*-- file has arrived in the spool so it can queue it to the proper v120
*-- link.                                                          v120
*
ENUM140  EQU   *                                                   v120
         LA    R2,NCB1                 -> NCB area                 v120
         NSIO  TYPE=CLOSE,             Close spool dataset         v120x
               NCB=(R2),                                           v210x
               ENTRY=ANJESPL                                       v210
         DROP  R6                      TAG                         v120
*
         CLC   DESTNODE,LCLNODE        Did reset to local node?    v211
         BE    ENUM160                 Y, no WRE and POST required v120
*
         BAL   R14,GTW000              Get WRE                     v220
         LR    R4,R1                   -> WRE                      v120
         USING WRE,R4                                              v120
         MVI   WRESP,2                 Save subpool                v220
         MVI   WRETYPE,WRENEW          "New file in spool" WRE     v120
         MVC   WRELINK,CMDNODE         Set destination node        v211
         MVC   WREUSER,DESTUSER        Set destination userid      v120
*
         SPKA  0                                                   v220
         L     R6,CSABLK               -> CSA comm area            v211
         USING NJ38CSA,R6                                          v120
*
         LM    R0,R1,NJ38SWAP          Get first WRE ptr, sync counv120
ENUM150  EQU   *                                                   v120
         ST    R0,WRENEXT              First WRE becomes next      v120
         LA    R5,1(,R1)               Incr synchronization count  v120
         CDS   R0,R4,NJ38SWAP          Update CSA WRE anchor, sync v120
         BC    7,ENUM150               Gotta try again             v120
*
         LA    R7,NJ38ECB              -> NJE38 external WRE ECB   v120
         DROP  R6                      NJ38CSA                     v120
         DROP  R4                      WRE                         v120
*                                      WRE will be Q'd to main taskv120
         POST  (7)                     Post the main task WRE ECB  v120
*
         SPKA  X'80'                   Back to user key            v120
*
*-- Issue response that the file was requeued                      v120
*
ENUM160  EQU   *                                                   v120
         LA    R6,TDATA                                            v120
         USING TAG,R6                                              v120
         LH    R1,TAGID                Get the file number         v120
         CVD   R1,DBLE                 Convert file #              v120
         UNPK  TWRK(4),DBLE            Add zones                   v120
         OI    TWRK+3,X'F0'            Fix sign                    v120
         MVC   MTEXT,BLANKS            Clear work area             v120
         MVC   MTEXT(L'NJE029I),NJE029I Move msg                   v120
         MVC   MTEXT+13(4),TWRK        Insert file number          v120
         LA    R1,MTEXT+L'NJE029I      -> end of msg               v120
         MVC   0(8,R1),DESTNODE        Move in new node name       v120
         TRT   0(9,R1),BLANK           Look for end of node name   v120
         MVI   0(R1),C'('                                          v120
         MVC   1(8,R1),DESTUSER        Move in new userid          v120
         TRT   1(9,R1),BLANK           Look for end of user name   v120
         MVI   0(R1),C')'                                          v120
         LA    R1,1(,R1)               Skip over paren             v120
         LA    R0,MTEXT                -> start of msg             v120
         SR    R1,R0                   Compute length of msg       v120
         BAL   R14,ISSUE000            Go stack the message        v120
         B     XITCMH00                Exit                        v120
*
*
MVCNODE  MVC   DESTNODE(0),0(R4)       executed instr              v120
MVCUSER  MVC   DESTUSER(0),0(R4)       executed instr              v120
*
*
*-- ENUMxxx Error Exits                                            v120
*
         USING TAG,R6                                              v120
ENUM900  EQU   *                ** Here if file not found          v120
         LH    R1,TAGID            Get the file number             v120
         CVD   R1,DBLE             Convert file #                  v120
         UNPK  TWRK(4),DBLE        Add zones                       v120
         OI    TWRK+3,X'F0'        Fix sign                        v120
         MVC   MTEXT,BLANKS        Clear work area                 v120
         MVC   MTEXT(L'NJE027E),NJE027E Move msg                   v120
         MVC   MTEXT+14(4),TWRK    Insert file number              v120
         LA    R1,L'NJE027E        Length of message               v120
         BAL   R14,ISSUE000        Go stack the message            v120
         B     ENUM990             Exit                            v120
*
ENUM910  EQU   *                ** Here if cmd fmt invalid         v120
         MVC   MTEXT(L'NJE028E),NJE028E Move msg                   v120
         LA    R1,L'NJE028E        Length of message               v120
         BAL   R14,ISSUE000        Go stack the message            v120
         B     ENUM990                                             v120
*
ENUM990  EQU   *                                                   v120
         LA    R2,NCB1             -> NCB area                     v120
         NSIO  TYPE=CLOSE,         Close spool dataset             v120x
               NCB=(R2),                                           v210x
               ENTRY=ANJESPL                                       v210
         DROP  R6                  TAG                             v120
         B     XITCMH00            Command function completed      v120
*
*-- Exit command processing
*
*
XITCMH00 EQU   *
         SR    R15,R15             Set RC=0
*
XITCMH   EQU   *
         L     R13,4(,R13)         -> prev s.a.
         ST    R15,16(,R13)        Set RC
         LM    R14,R12,12(R13)     Reload callers regs
         BR    R14                 Return with RC
*
         LTORG
*
*-- D #### response models:
*
NJE026I  DC    C'NJE026I  File status for node '
N026A  DC C'File  Origin   Origin    Dest     Dest'
N026B  DC C' ID   Node     Userid    Node     Userid    CL  Records'
N026C  DC C'xxxx  xxxxxxxx xxxxxxxx  xxxxxxxx xxxxxxxx  c x,xxx,xxx'
N026D  DC C'Tagged name: '
N026E  DC C'Attributes: '
N026F  DC C'Origin DSN='
*           01234567890123456789012345678901234567890123456789012345678
*              901234567890123456789
NJE027E  DC    C'NJE027E  File(xxxx) does not exist'  used by E ### too
*
*
*-- E #### response models:
NJE028E  DC    C'NJE028E RESET invalid; command format is RESET #,D=nodx
               e.userid'                                           v120
NJE029I  DC    C'NJE029I File(xxxx) requeued to ' node(user)       v120
*
* Example Response for flat PUNCH data
*
*    Attributes: 80/F/PS
*
* Example Response for flat PRINT data
*
*    Attributes: 132/F/PS
*
* Example Response for NETDATA, sent from a VM system (source code):
*
*    Attributes: 24400/80/FB/PS
*
* Example Response for NETDATA, sent from a MVS system (PDS LOADLIB):
*
*    Attributes: 6144/U/PO  DIRBLKS=5
*    DSN=HERC01.COB.LOAD
*
*
*********************
*  N J E C M E      *               NJECME determines if NETDATA
*                   *               exists in a spool file and
*  Examine NETDATA  *               examines the INMR02 control
*                   *               record for attributes.
*********************               Entire CSECT added             v110
*
NJECME   CSECT
         B     28(,R15)               BRANCH AROUND EYECATCHERS
         DC    AL1(23)                LENGTH OF EYECATCHERS
         DC    CL9'NJECME'
         DC    CL9'&SYSDATE'
         DC    CL5'&SYSTIME'
*
         STM   R14,R12,12(R13)         Save Regs
         LR    R12,R15                 Base
         USING NJECME,R12
         USING NJEWK,R10
         ST    R13,CMESA+4             SAVE prv S.A. ADDR
         LA    R1,CMESA                -> my save area
         ST    R1,8(,R13)              Plug it into prior SA
         LR    R13,R1
*
*
         LA    R0,2                    # of bytes to get
         BAL   R14,GETBYTES            Get length and desc of segment
*
         TM    1(R1),X'20'             Is this a control record?
         BZ    XITCME04                No, its not NETDATA
*
         SR    R0,R0
         IC    R0,0(,R1)               Get segment length byte
         S     R0,=F'2'                Less 2 we already retrieved
         BAL   R14,GETBYTES            Get control record
*
         CLC   0(6,R1),INMR01          NETDATA?
         BNE   XITCME04                Not NETDATA
*
         LA    R0,2                    # of bytes to get
         BAL   R14,GETBYTES            Get length and desc of segment
*
         TM    1(R1),X'20'             Is this a control record?
         BZ    XITCME04                No, its not NETDATA
*
         SR    R0,R0
         IC    R0,0(,R1)               Get segment length byte
         S     R0,=F'2'                Less 2 we already retrieved
         LR    R3,R0                   Copy length of control record
         BAL   R14,GETBYTES            Get control record
*
         CLC   0(6,R1),INMR02          NETDATA?
         BNE   XITCME04                Not NETDATA
*
         LA    R15,10                  Len of "INMR02"+file number word
         AR    R1,R15                  Skip over those fields
*
CTL000   EQU   *
         SR    R3,R15                  Reduce remaining length
         BNP   XITCME00                Done with control record
*
*-- Look for supported keys
*
         CLC   0(2,R1),INMUTILN        Utility name?
         BE    UTL000                  Y
         CLC   0(2,R1),INMSIZE         File size?
         BE    FSZ000                  Y
         CLC   0(2,R1),INMDSORG        DSORG?
         BE    DSG000                  Y
         CLC   0(2,R1),INMBLKSZ        BLKSIZE?
         BE    BLK000                  Y
         CLC   0(2,R1),INMLRECL        LRECL?
         BE    LRL000                  Y
         CLC   0(2,R1),INMRECFM        RECFM?
         BE    RFM000                  Y
         CLC   0(2,R1),INMFFM          File mode number?
         BE    FFM000                  Y
         CLC   0(2,R1),INMDIR          # directory blocks?
         BE    DIR000                  Y
         CLC   0(2,R1),INMDSNAM        DSNAME?
         BE    DSN000                  Y
*
*-- Skip over unsupported/unrecognized keys
*
         LA    R1,2(,R1)               Skip over unrecognized key
         LA    R15,2                   Remaining length adjust
         SR    R0,R0                   Clear for IC
         ICM   R0,3,0(R1)              Get # value
         LA    R1,2(,R1)               Skip over # value
         LA    R15,2(,R15)             Remaining length adjust
         BZ    CTL000                  # was 0; no lengths
         SR    R14,R14                 Clear for ICM
*
CTL020   EQU   *
         ICM   R14,3,0(R1)             Get length field
         LA    R1,2(R14,R1)            Skip over length and data
         LA    R15,2(R14,R15)          Remaining length adjust
         BCT   R0,CTL020               Do next len/data field pair
         B     CTL000                  Resume
*
*-- Handle keys we support
*
*- Utility name
UTL000   EQU   *                       Get utility name
         MVC   UTLNAME,BLANKS          Init receiving field
         LA    R6,UTLNAME              -> receiving field
         B     KEY000                  Go handle the key
*
*- File size
FSZ000   EQU   *                       File size
         MVC   FSIZELEN,4(R1)          Save length of file size value
         LA    R6,FILESIZE             -> receiving field
         B     KEY000                  Go handle the key
*
*- DSORG
DSG000   EQU   *                       DSORG
         LA    R6,DSORG                -> receiving field
         B     KEY000                  Go handle the key
*- BLKSIZE
BLK000   EQU   *                       BLKSIZE
         LA    R6,BLKSIZE              -> receiving field
         B     KEY000                  Go handle the key
*
*- LRECL
LRL000   EQU   *                       LRECL
         LA    R6,LRECL                -> receiving field
         B     KEY000                  Go handle the key
*
*- RECFM
RFM000   EQU   *                       RECFM
         LA    R6,RECFM                -> receiving field
         B     KEY000                  Go handle the key
*
*- # directory blocks
DIR000   EQU   *                       File size
         MVC   DIRBLKLN,4(R1)          Save length of dirblk siz value
         LA    R6,DIRBLKS              -> receiving field
         B     KEY000                  Go handle the key
*
*- FFM
FFM000   EQU   *                       File mode number
         LA    R6,FFM                  -> receiving field
         B     KEY000                  Go handle the key
*
*- DSNAME
DSN000   EQU   *                       DSNAME
         MVC   DSNAME,BLANKS           Init receiving field
         LA    R6,DSNAME               -> receiving field
         LA    R1,2(,R1)               Skip over key
         LA    R15,2                   Remaining length adjust
         SR    R0,R0                   Clear for IC
         ICM   R0,3,0(R1)              Get # value
         LA    R1,2(,R1)               Skip over # value
         LA    R15,2(,R15)             Remaining length adjust
         BZ    CTL000                  # was 0; no lengths
         SR    R14,R14                 Clear for ICM
*
DSN020   EQU   *
         ICM   R14,3,0(R1)             Get length field
         BCT   R14,DSN030              Adjust for execute
         MVC   0(0,R6),2(R1)           executed instr
DSN030   EX    R14,*-6                 Move name to receiving field
         LA    R1,3(R14,R1)            Skip over length and data
         LA    R15,3(R14,R15)          Remaining length adjust
         LA    R6,1(R14,R6)            Bump to next qualifier area
         MVI   0(R6),C'.'              Add qualifier dot
         LA    R6,1(,R6)               -> next qualifier area
         BCT   R0,DSN020               Do next len/data field pair
         BCTR  R6,0                    -> last byte of DSNAME
         MVI   0(R6),C' '              Remove trailing dot
         BCTR  R6,0                    -> prior to trailing '.'
         LA    R0,DSNAME               -> start of DSNAME
         SR    R6,R0                   Compute DSN length
         STH   R6,DSNAMELN             Save it
         B     CTL000                  get next key
*
*-- Common routine to break part key/#/len/data elements that have #=1
*
KEY000   EQU   *
         LA    R1,4(,R1)               Skip over key, #
         LA    R15,4                   Remaining length accum
         SR    R5,R5                   Clear for IC
         ICM   R5,3,0(R1)              Get length of name
         BCT   R5,KEY010               Adjust for execute
         MVC   0(0,R6),2(R1)           executed instr
KEY010   EX    R5,*-6                  Move name to receiving field
         LA    R1,3(R5,R1)             -> next text unit key
         LA    R15,3(R5,R15)           Accum length adjustment
         B     CTL000                  Get next key
*
*
*
GETBYTES EQU   *
         ST    R14,SV14GB              Save return addr
         L     R5,GBREM                Get # bytes remaining in rec buf
         LA    R1,BUFF                 Point to getbytes buffer
         ST    R1,GBPOS                Set starting position
         LR    R8,R0                   Requested amount to R8
*
*
GB010    EQU   *
         LTR   R5,R5                   Any bytes left in phy record?
         BP    GB040                   Yes, use them first
*
         LA    R2,NCB1                 -> active NCB for spool file
         NSIO  TYPE=GET,               TAG data contains file #        x
               NCB=(R2),               Get a spool file record         x
               AREA=REC,               -> where to place record        x
               EODAD=XITCME04,         if EOF, NETDATA isnt valid  v210x
               ENTRY=ANJESPL                                       v210
         LTR   R15,R15                 Any errors?
         BZ    GB020                   No
         BAL   R14,FMT000              Display error
         B     U0039                   And abend
*
GB020    EQU   *
         LA    R5,80                   Num bytes read
         LA    R1,REC                  -> input buffer
*
GB030    EQU   *
         ST    R1,GBRPS                Reset start of record position
*
GB040    EQU   *
         LR    R7,R8                   Assume requested amt avail
         LR    R15,R8                  Same
*
         CR    R5,R8                   Have more than we need?
         BH    GB050                   Yes, just move requested
         LR    R7,R5                   Else move entire rec
         LR    R15,R5                  Same
*
GB050    EQU   *
         LR    R0,R7                   Save copy of length to move
         L     R14,GBPOS               -> GB buffer position
         L     R6,GBRPS                -> input record curr position
         MVCL  R14,R6                  Move
*
         ST    R14,GBPOS               New GB position
         ST    R6,GBRPS                New phys record curr position
*
         SR    R5,R0                   Reduce bytes left in phy record
         SR    R8,R0                   Reduce requested amt
         BP    GB010                   We need more, go get it
*
         ST    R5,GBREM                Remember whats left in phy rec
*
         LA    R1,BUFF                 Point to the requested bytes
         L     R14,SV14GB              Load  return addr
         BR    R14                     Return from getbytes
*
         LTORG
*
INMR01   DC    C'INMR01'               Control record
INMR02   DC    C'INMR02'               Control record
*
*- Keys
INMUTILN DC    X'1028'                 Utility name
INMSIZE  DC    X'102C'                 File size in bytes
INMDSORG DC    X'003C'                 DSORG
INMLRECL DC    X'0042'                 LRECL
INMBLKSZ DC    X'0030'                 BLKSIZE
INMRECFM DC    X'0049'                 RECFM
INMDSNAM DC    X'0002'                 DSNAME
INMDIR   DC    X'000C'                 # directory blocks
INMFFM   DC    X'102D'                 File mode number
*
*
*
*-- Exit NETDATA examination processing
*
*
XITCME00 EQU   *
         SR    R15,R15             Set RC=0; NETDATA info filled
         B     XITCME
*
XITCME04 EQU   *
         LA    R15,4               Set RC=4; File contains no NETDATA
*
XITCME   EQU   *
         L     R13,4(,R13)         -> prev s.a.
         ST    R15,16(,R13)        Set RC
         LM    R14,R12,12(R13)     Reload callers regs
         BR    R14                 Return with RC
*
         LTORG
*
*
*
*
*
ACTLINE  DSECT                     Display Active line format
REGION   DS    CL4' '
         DS    CL2' '
JOBNAME  DS    CL8' '
         DS    CL2' '
STEPNAME DS    CL8' '
ACTLINSZ EQU   *-ACTLINE
*
****  Main work area common
****  to all NJExxx CSECTs.
*
NJEWK    DSECT
NJEEYE   DS    CL4'NJEW'           Eyecatcher
NJEWKLEN DS    F                   Getmain size of this area
*
DBLE     DS    D                   Work area
TWRK     DS    2D                  Work area
*
         NJEPARMS                  Passed parameter list           v220
*
*
RESPNODE DS    CL8                 Respond to node
RESPID   DS    CL8                 Respond to userid
COMMAND  DS    CL8                 Command (START, DRAIN, etc).
CMDNODE  DS    CL8                 Link id name target of command/msg
CMDUID   DS    CL8                 User id name target of msg
DESTNODE DS    CL8                 destination node                v120
DESTUSER DS    CL8                 destination userid              v120
*
SV14     DS    A                   R14 save area
SVR14R   DS    A                   R14 save area                   v220
SVR14I   DS    A                   R14 save area                   v220
SV23     DS    2A                  R2,R3 save area
NCB1     DS    XL48                NCB
MTEXT    DS    CL120               Message text work area
MWORK    DS    CL120               Message text work area
WTOMSG   DS    CL132
CMDAREA  DS    CL120               Copy of CMDTEXT
*
TYPPRT   EQU   X'40'                PRT dev                        v110
TYPPUN   EQU   X'80'                PUN dev                        v110
TDATA    DS    0XL108              Tag data area
BLNKDASH DS    0CL256              Special TRT area
ASIDTAB  DS    24CL24              Space for D ACT 24 regions info
*
TARGET   DS    X                   Code for who gets the cmd response
TGTUSER  EQU   0                    remote user
TGTCONS  EQU   4                    MVS system console
*
NJFL1    DS    X                   Flag bits
NJF1MULT EQU   X'80'   1... ....    Multi-file cancel command
NJF1CNCL EQU   X'40'   .1.. ....    A file was deleted by command
NJF1DATH EQU   X'20'   ..1. ....    At least 1 AUTH user displayed
NJF1NYET EQU   X'10'   ...1 ....    No usable NETDATA found in filev110
NJF1VSER EQU   X'02'   .... ..1.    NETSPOOL VSAM error occurred
NJF1AUTH EQU   X'01'   .... ...1    CMD issuer is cmd authorized
*
*
SV14GB   DS    A                      R14 save area                v110
GBREM    DC    F'0'                   # bytes remaining in phys recv110
GBPOS    DS    A                      -> cur position in BUFF      v110
GBRPS    DS    A                      -> cur position in phys rec  v110
*                                                                  v110
UTLNAME  DS    CL8                    Utility name                 v110
FILESIZE DS    2F                     File size in bytes           v110
DIRBLKS  DS    2F                     #directory blocks            v110
BLKSIZE  DS    F                      BLKSIZE                      v110
LRECL    DS    F                      LRECL                        v110
RECFM    DS    XL2                    RECFM                        v110
DSORG    DS    XL2                    DSORG                        v110
FFM      DS    C                      File mode number             v110
         DS    X                      available                    v110
DIRBLKLN DS    H                      Length of dir blks value     v110
FSIZELEN DS    H                      Length of file size value    v110
DSNAMELN DS    H                      Length of DSNAME             v110
DSNAME   DS    CL44                   DSNAME                       v110
*
REC      DS    CL80                   Physical record              v110
TRTAB    DS    0CL256                 Translate table              v120
BUFF     DS    CL256                  GB buffer containing key datav110
*
NJESA    DS    18F                     NJECMX OS save area
CMCSA    DS    18F                     NJECMC OS save area         v110
CMGSA    DS    18F                     NJECMG OS save area         v110
CMHSA    DS    18F                     NJECMH OS save area         v110
CMESA    DS    18F                     NJECME OS save area         v110
BALRSAVE DS    16F                     Local rtns register save
*
         DS    0D                      Force doubleword size
NJEWKSZ  EQU   *-NJEWK
*
*
*-- System DSECTs
*
         CVT   DSECT=YES,PREFIX=NO
         IHAASVT
         IHAASCB
*
CSCB     DSECT
         IEECHAIN                      MAP FOR A CSCB
         IEESMCA
         IEFZB4D0
         IEFZB4D2
         DCBD  DSORG=PS,DEVD=DA
*
         COPY  LINKTABL
         COPY  RTE
         COPY  AUTHLIST
         COPY  TAG
         COPY  NETSPOOL
*
*-- NJE38 DSECTs
*
         NJEWRE                                                    v220
         NJERUSER                                                  v220
         NJETRACE TYPE=DSECT                                       v220
*
         END   NJECMX
*
./ ADD NAME=NJEDRV
*
*
*-- NJE38 - Line Driver Support
*
*
*   Attached by NJEINIT when a link is started.
*
*   This module invokes and provides MVS support for the functions of
*   the DMTXJE RSCS NJE line driver
*
* Change log:
*
* 15 Feb 21 - Files already at final destination being selected    v221
*              by broad wildcard routes                            v221
* 10 Dec 20 - Support for registered users and message queuing     v220
* 09 Dec 20 - Abend 0C4 in DMTXJE if msg length=0                  v213
* 04 Dec 20 - Expanded internal trace table support                v212
* 29 Nov 20 - Use text-based configuration; alternate routes       v211
* 02 Oct 20 - Use actual length for MGCR SEND cmds                 v210
* 10 Aug 20 - Use single NJESPOOL load for all STC NJE38 modules.  v210
* 20 Jul 20 - Improve trace entries for GMSGREQ function (NJEGMQ). v200
* 01 Jun 20 - FMT000 doesn't format errors from NCB2.              v130
* 08 May 20 - Last byte of prior cmd appearing in cmd buffer.      v110
* 08 May 20 - Invalid command ignored if the command is 1 byte.    v110
* 05 May 20 - Abend SD23 if SVC 34 parmlist >=130 bytes.           v102
*
*
*
*
* User abend codes (all should not occur)
*  U0022 - DMTXJE call to function POSTREQ
*  U0028 - DMTXJE call to function PMSGREQ
*  U0039 - Spool VSAM error
*  U0040 - Unknown request type
*  U0041 - Unknown MSG number
*  U0043 - Unknown WRE code
*  U0044 - Unknown WRE type
*  U0045 - RQEs exhausted
*  U0046 - GIVEREQ call from DMTXJE for AXS service inv req type/len
*  U0047 - GIVEREQ call from DMTXJE for REX service has inv req type
*  U0048 - more than 8 ECBs in ECBLIST issued from DMTXJE
*  U0049 - WAIT posted but none of the ECBs have a post bit set
*
*
*
*
         MACRO
&X       TRACE &TYPE=
&X       STM   R15,R2,16(R13)          R0-R2 restored by trace rtn
         L     R2,ATRACE               -> trace table
         L     R15,TRCRTN-TRCCTL(,R2)  -> trace routine
         BALR  R14,R15                 Go get a new trace entry
         L     R15,16(,R13)            Restore R15
         MVI   0(R14),&TYPE            Move in trace type code
         MEND
         PRINT GEN                                                      NJE00030
         REGEQU                        REGISTER EQUATES                 NJE00040
*
*
*
*
NJEDRV   CSECT                                                          NJE00020
         NJEVER
         STM   R14,R12,12(R13)         SAVE REGS                        NJE00050
         LR    R12,R15                 BASE                             NJE00060
         USING NJEDRV,R12              ADDRESS IT                       NJE00070
         LR    R8,R1                   Save input LINKTABL entry addr
*
         GETMAIN RU,                   Get local stg area              X
               LV=4096,                                                X
               BNDRY=PAGE
         LR    R10,R1
         LR    R1,R0                   Copy length
         LR    R2,R0                   Copy length
         LR    R0,R10                  -> new stg area
         SR    R15,R15                 set pad
         MVCL  R0,R14                  Clear the page
*
         USING NJEWK,R10
         ST    R13,NJESA+4             SAVE prv S.A. ADDR               NJE00080
         LA    R1,NJESA                -> my save area
         ST    R1,8(,R13)              Plug it into prior SA
         LR    R13,R1
*
         MVC   NJEEYE,=CL4'NJEW'       Work area eyecatcher
         ST    R2,NJEWKLEN             Save size of area in area
         MVC   WTOD(WTODL),WTODMY
         L     R11,=A(NJECOM)          -> common csect
         ST    R11,ANJECOM             Save addr
         USING NJECOM,R11
*
         LR    R2,R8                   Copy addr of LINKTABL entry
         USING LINKTABL,R2
         L     R8,LPOINTER             -> INITPARM area passed     v211
         MVC   INITPARM,0(R8)          Move the parms to our stg   v211
         XC    LPOINTER,LPOINTER       Reinitialize this field
*
         ST    R2,XJELINK              Save this task's LINKTABL addr
         MVC   XJENODE,LINKID          Save linkid of starting link
         MVC   LACTDRVR,LDEFDRVR
         MVC   LACTLINE,LDEFLINE
         MVC   LACTCLS1,LDEFCLS1
         MVI   LFLAG,LACTIVE           Mark link as active (starting)
         ST    R10,LNJEW               Save addr of local work area
         XC    LECB,LECB               Init ECB
         LA    R1,LECB                 -> notification ECB
         ST    R1,LINKECBA             Set it as link ecb
*
*
*-- Get stg for message processing
*
INIT010  EQU   *
         GETMAIN RU,BNDRY=PAGE,        Get stg for msg processing      X
               LV=MSGWKSZ
         ST    R1,AMSGWK               Save addr of area
*
         LR    R4,R1                   Copy addr
         LR    R1,R0                   Copy length
         LR    R3,R0                   Copy length
         LR    R0,R4                   -> new stg area
         SR    R15,R15                 set pad
         MVCL  R0,R14                  Clear the area
*
         USING MSGWK,R4
         MVC   MSGEYE,=CL4'MSGW'       Work area eyecatcher
         ST    R3,MSGWKLEN             Save size of area in area
         DROP  R4                      MSGWK
*                                                                       NJE00100
*-- Get two pages that will be used for DMTXJE's working stg
*
         GETMAIN RU,                   Get local stg area              X
               LV=8192,                                                X
               BNDRY=PAGE
         LR    R9,R1                   -> DMTXJE working stg areas
         ST    R9,XJESTOR              Save addr locally
*
*
*-- Initialization completed
*
         MVC   MACLIST(WTODL),WTOD
         MVC   MACLIST+4(L'NJE002I),NJE002I   Move msg text
         MVC   MACLIST+28(8),XJENODE
         WTO   ,MF=(E,MACLIST)
*
*-- Build the text unit address list for the comm line
*
         MVC   TXT1,TXT1D               INITIALIZE RETURN DD TXT UNIT
         MVC   TXT12,TXT12D             INITIALIZE TXT UNIT
         MVC   TXT4,TXT4D               INITIALIZE TXT UNIT
         LA    R1,TXT1                  POINT TO TEXT UNIT
         ST    R1,MACLIST               SET IN ADDRESS LIST
         LA    R1,TXT12                 POINT TO TEXT UNIT
         ST    R1,MACLIST+4             SET IN ADDRESS LIST
         LA    R1,TXT4                  POINT TO TEXT UNIT
         ST    R1,MACLIST+8             SET IN ADDRESS LIST
         OI    MACLIST+8,X'80'          SET VL
*
         UNPK  DBLE(4),LACTLINE(3)      Convert CUU of line
         TR    DBLE(3),HEXTRAN-240
         MVC   UNITCUU,DBLE
*
         BAL   R14,DYN000               GO ISSUE SVC 99
*
         MVC   INTRDR(DMYIRDRL),DMYIRDR Set up DCB, but dont open yet
         MVC   LINE1(DMYLINEL),DMYLINE Set up DCB
         LA    R1,LINE1                 -> DCB
         MVC   DCBDDNAM-IHADCB(,R1),DDNAME Move DDNAME to DCB
         MVC   MACLIST(OPENL),OPEN     Move open list
         OPEN  (LINE1),                Open the comm line              x
               MF=(E,MACLIST)
*
         SR    R0,R0                   No parms                         NJE00150
         SR    R1,R1                   No parms                         NJE00160
         LA    R7,VECSET               Replacement vectors              NJE00170
         LA    R8,XJEWORDS             -> Addr list for XJE to fill     NJE00170
*
*-- On entry to DMTXJE:
*
*    R0  = length of input parameters or 0
*    R1 -> input parameters or 0
*    R2 -> LINKTABL entry
*    R7 -> SVECTORS list that replaces RSCS functions
*    R8 -> list of addrs that DMTXJE fills for use here
*    R9 -> two pages of storage for DMTXJE working storage
*    R10-> working storage area for NJEINIT
*    R13-> OS save area
*
         L     R15,=V(DMTXJE)          Call RSCS V1 Line Driver         NJE00180
         BALR  R14,R15                                                  NJE00190
*
         DROP  R2                      LINKTABL
*                                                                       NJE00200
QUIT     EQU   *                                                        NJE00210
         MVC   MACLIST(CLOSEL),CLOSE   Move close list
         CLOSE (LINE1),                                                x
               MF=(E,MACLIST)
*
         LR    R1,R9                   -> DMTXJE's work stg
         FREEMAIN RU,LV=8192,A=(1)     Release it
*
         L     R1,AMSGWK               -> MSGWK area
         L     R0,MSGWKLEN-MSGWK(,R1)  Get work area length
         FREEMAIN RU,LV=(0),A=(1)      Release it
*
         LR    R1,R10                  -> NJEWK main work area page
         L     R13,4(,R13)             -> caller's sa                   NJE00210
         FREEMAIN RU,                                                  x
               LV=4096,                                                x
               A=(1)
         LM    R14,R12,12(R13)         Reload system's regs             NJE00220
         XR    R15,R15                 RC=0                             NJE00230
         BR    R14                     Return                           NJE00240
*                                                                       NJE00250
*                                                                       NJE00250
*                                                                       NJE00250
*                                                                       NJE00250
ASYNRET  SR    R15,R15                 Null DMTXJE ASYNEXIT return      NJE00260
         BR    R14                                                      NJE00270
*
*-- Abends for routines that DMTXJE could potentially call which we
*-- dont support because we don't need to.  DMTXJE should in fact
*-- never call these.  These functions are handled by NJEDRV in
*-- other ways.
*
AB22     EQU   *                       POSTREQ
         LR    R4,R0
         LR    R5,R1
         ABEND 22,DUMP,STEP
AB28     EQU   *
         LR    R4,R0
         LR    R5,R1
         ABEND 28,DUMP,STEP            PMSGREQ
         LTORG                                                          NJE00280
*
DMYLINE  DCB   DDNAME=LINE1,           Communications line DCB         x
               MACRF=(E),                                              x
               DSORG=CX
DMYLINEL EQU   *-DMYLINE
*
DMYIRDR  DCB   DDNAME=INTRDR,          Internal reader DCB             x
               MACRF=(PM),              INTRDR stuff exists in         x
               DSORG=PS,                this module but is not         x
               LRECL=80,                implemented (it was            x
               RECFM=FB,                experimental).                 x
               BLKSIZE=800
DMYIRDRL EQU   *-DMYIRDR
*
*
OPEN     OPEN  0,MF=L
OPENL    EQU   *-OPEN
CLOSE    CLOSE 0,MF=L
CLOSEL   EQU   *-CLOSE
EXTRACT  EXTRACT MF=L
EXTRACTL EQU   *-EXTRACT
*
*                456789012345678901234567890123456789012345678901
NJE002I  DC    C'NJE002I Activating link'
*                                                                       NJE00330
*                                                                       NJE00740
VECSET   DS    0D                  Vectors that DMTXJE calls            NJE00750
TLINKS   DC    A(ALINKS-NJEWK)     Offset to ALINKS word in NJEWK       NJE00760
ASYNREQ  DC    A(ASYNRET)                                               NJE00770
POSTREQ  DC    A(AB22)                                                  NJE00780
SPLREQ   DC    A(NJESPL) was TCOM                                       NJE00790
IOREQ    DC    A(NJESIO)                                                NJE00800
WAITREQ  DC    A(NJEWT)                                                 NJE00810
ALERTREQ DC    A(NJEALQ)                                                NJE00820
GIVEREQ  DC    A(NJEREQ)                                           v220 NJE00830
*--replacement comdsect                                                 NJE00840
PMSGREQ  DC    A(AB28)                                                  NJE00850
GPAGEREQ DC    A(NJEGPG)                                                NJE00860
GLINKREQ DC    A(NJEGLQ)                                                NJE00870
GROUTREQ DC    A(NJEGRQ)                                                NJE00880
GMSGREQ  DC    A(NJEGMQ)                                                NJE00890
GTODEBCD DC    A(NJETOD)                                                NJE00900
SVLEN    EQU   *-TLINKS                                                 NJE00910
*
WTODMY   WTO   '                                                       x
                                             ',MF=L
WTODL    EQU   *-WTODMY
         DROP  R12
*                                                                       NJE00920
*********************                                                   NJE00920
*  N J E C O M      *               NJECOM hosts small routines and     NJE00920
*                   *               frequently used constants that      NJE00920
*  Common routines  *               are available to all NJExxx csects  NJE00920
*  and constants    *               via base register 11                NJE00920
*                   *                                                   NJE00920
*********************                                                   NJE00920
*                                                                       NJE00920
NJECOM   CSECT                                                          NJE00020
         DC    A(0)                 No branch around constants
         DC    AL1(23)                LENGTH OF EYECATCHERS
         DC    CL9'NJECOM'
         DC    CL9'&SYSDATE'
         DC    CL5'&SYSTIME'
         USING NJECOM,R11
         USING NJEWK,R10
*
*-- Issue Dynalloc SVC
*-- Initialize the S99RB block
*
DYN000   EQU   *
         ST    R14,DYNR14               SAVE RETURN REG
         MVC   LS99RB,CPS99RB           INIT THE S99RB
         LA    R1,LS99RB                POINT TO BLOCK
         USING S99RB,R1
         OI    S99FLAG1,S99NOCNV        FORCE NEW ALLOCATION
         ST    R1,LS99PTR               SET PARAMETER WORD
         OI    LS99PTR,X'80'            SET VL
         LA    R14,MACLIST              GET ADDRESS OF TEXT UNITS
         ST    R14,S99TXTPP             PUT IN S99RB
*
         LA    R1,LS99PTR               POINTER TO S99 PTR
         SVC   99                       ISSUE DYNALLOC
*
         NJETRACE TYPE=TRCDYNA          TRACE DYNALLOC RESULT
         STCM  R10,7,1(R14)             identify trace entry       v212
         MVC   4(3,R14),DYNR14+1        Trace caller               v212
         STC   R15,4(,R14)              Trace SVC 99 RC            v212
         MVC   8(8,R14),DDNAME          Trace resulting DDNAME
         LTR   R15,R15                  R15 non zero?
         BZ    DYN090                   No
         LA    R1,LS99RB
         MVC   8(4,R14),S99ERROR
         DROP  R1
*
DYN090   EQU   *
         L     R14,DYNR14               Rstore return addr
         BR    R14
*
*-- Get a new command type WRE
*
*-- Entry:  None
*   Exit:   R1 -> WRE
*
*
GTW000   EQU   *
         ST    R14,SVR14           Save return addr
         GETMAIN RU,               Get CSA for WRE TYPE=WREMSG         x
               LV=WRESIZE,                                         v220x
               SP=2                                                v220
         XC    0(WRESIZE,R1),0(R1)    Clear stg area               v220
         USING WRE,R1
         MVI   WRESP,2             Set subspool                    v220
         MVI   WRETYPE,WREMSG      MSG WRE
         DROP  R1
*
         NJETRACE TYPE=TRCGWRE
         STCM  R10,7,1(R14)        Identify trace entry            v220
         MVC   5(3,R14),SVR14+1    Addr of GTW000 caller           v220
         STM   R0,R1,8(R14)        Len, stg addr to trace          v220
         MVI   8(R14),2            Trace subpool #                 v220
         L     R14,SVR14           Load return addr
         BR    R14
*
*-- Queue the WRE on the main task and post his ECB
*
*-- Entry:  R4 -> WRE
*-- Exit:   None
*
PST000   EQU   *
         ST    R14,SVR14           Save return addr
         SPKA  0                                                   v220
         L     R15,CSABLK          -> NJE38 CSA block
         USING NJ38CSA,R15
         USING WRE,R4
         LM    R0,R1,NJ38SWAP      Get first WRE ptr, sync count
*
PST020   EQU   *
         ST    R0,WRENEXT          First WRE becomes next
         LA    R5,1(,R1)           Incr synchronization count
         CDS   R0,R4,NJ38SWAP      Update LINK WRE anchor, sync
         BC    7,PST020            Gotta try again
*
         LA    R1,NJ38ECB          -> main task notification ECB
         POST  (1)                 Wake him up
*
         SPKA  X'80'                                               v220
         L     R14,SVR14           Load return addr
         BR    R14
*
         DROP  R15                 NJ38CSA
         DROP  R4                  WRE
*
*
*-- Search CSCB chain to see if TSO user is logged on
*-- Entry:  R15->8-byte padded field containing TSO userid to find
*-- Exit:  CC=0  user was not logged on
*--        CC<>0 user is logged on
*
USR800   EQU   *
         CLC   =CL8'OP',0(R15)     Is the userid the operator?
         BE    USR890              Yes, let it thru
         L     R1,16               Get CVT ptr
         USING CVT,R1
         L     R1,CVTASCBH         -> highest prty ASCB
         USING ASCB,R1
*
USR810   EQU   *
         L     R2,ASCBCSCB         -> CSCB
         USING CSCB,R2
         LTR   R2,R2               Is there a CSCB?
         BZ    USR840              No, get next ASCB
*
USR820   EQU   *
         CLC   CHKEY,=XL8'00'      Jobname zeroed?
         BE    USR830              Y, skip this CSCB
         CLC   CHKEY,=CL8' '       Jobname is blank?
         BE    USR830              Y, skip this CSCB
         CLC   CHKEY,0(R15)        Is this the userid?
         BE    USR890              Yes
USR830   EQU   *
         L     R2,CHPTR            -> next CSCB
         LA    R2,0(,R2)           Clear high order
         LTR   R2,R2               Last CSCB?
         BNZ   USR820              No
         BR    R14                 Return with CC=0 (not found)
*
USR840   EQU   *
         L     R1,ASCBFWDP         -> next ASCB
         LTR   R1,R1               last one?
         BNZ   USR810              No
         BR    R14                 Return with CC=0 (not found)
*
USR890   EQU   *
         LTR   R14,R14             Set CC=non zero (userid found)
         BR    R14                 Return to caller
*
         DROP  R1                  ASCB
         DROP  R2                  CSCB
*
FMT000   EQU   *
         STM   R14,R2,BALRSAVE         Save regs used
         MVC   MACLIST(WTODL),WTOD
         MVC   MACLIST+4(L'NJE079I),NJE079I   Move msg text
         MVC   MACLIST+55(8),5(R12)    Move csect name
         TRT   MACLIST+55(9),BLANK     Look for end of csect name
         MVI   0(R1),C'+'
*
         LA    R15,0(,R14)  Clear high, Get addr of call to this rtn
         LA    R12,0(,R12)             Clear high byte
         SR    R15,R12                 Compute offset of call
         ST    R15,DBLE                Save to work area
         UNPK  TWRK(5),DBLE+2(3)       Add zones
         TR    TWRK(4),HEXTRAN-240     Display hex
         MVC   1(4,R1),TWRK            Move call offset to msg
*
         L     R15,BALRSAVE+12         Get R1 value (->failing NCB)v130
         UNPK  TWRK(5),NCBRTNCD-NCB(3,R15)  Add zones
         TR    TWRK(4),HEXTRAN-240
         MVC   MACLIST+35(4),TWRK      Move rtncd/errcd
*
         UNPK  TWRK(3),NCBREQ-NCB(2,R15)  Add zones
         TR    TWRK(2),HEXTRAN-240
         MVC   MACLIST+45(2),TWRK      Move req code
*
         L     R1,NCBMACAD-NCB(,R15)   Get failing VSAM macro addr
         LA    R1,0(,R1)               Clear high byte
         S     R1,ANJESPL              Compute offset into NJESPOOLv210
         ST    R1,DBLE
         UNPK  TWRK(5),DBLE+2(3)       Add zones
         TR    TWRK(4),HEXTRAN-240     Display hex
         MVC   MACLIST+50(4),TWRK      Move NJESPOOL offset to msg
*
         MVC   LASTRC(2),NCBRTNCD-NCB(R15)  Save off rtncd/errcd
         OI    NJFL1,NJF1VSER          Indicate VSAM error occurred
*
         WTO   ,MF=(E,MACLIST)
*
FMT090   EQU   *
         LM    R14,R2,BALRSAVE         Restore caller regs
         BR    R14
*
U0039    EQU   *
         STM   R0,R1,DBLE              Save across ABEND SVC
         ABEND 39,DUMP,STEP            Abend on spool errors
*
         LTORG
*
* TEXT UNITS TO SET UP  //DDNAME DD SYSOUT=(A,INTRDR),FREE=CLOSE
*
TXT1D    DC    Y(DALRTDDN),AL2(1),AL2(8),CL8' '   RETURN DDNAME
TXT2D    DC    Y(DALSYSOU),AL2(1),AL2(1),C'A'     SYSOUT=(A,
TXT3D    DC    Y(DALSPGNM),AL2(1),AL2(6),C'INTRDR'          INTRDR)
TXT4D    DC    Y(DALCLOSE),AL2(0)                 FREE=CLOSE
*
* TEXT UNITS TO SET UP  //DDNAME DD UNIT=cuu,FREE=CLOSE
*
TXT12D   DC    Y(DALUNIT),AL2(1),AL2(3),CL3' '    UNIT NAME
*
UTXT4    DC    Y(DUNDDNAM)                        DDNAME FOR UNALLOC
*
         DS    0F
CPS99RB  DS    0XL20                   DEFINE INITIAL S99RB
         DC    AL1(20)                 LENGTH OF REQ BLOCK
         DC    AL1(1)                  VERB CODE:  ALLOCATION
         DC    X'20'                   FLAGS:  NO MOUNTS,OFFLINE VOLS
         DC    X'00'                   FLAGS
         DC    AL2(0)                  ERROR REASON CODE
         DC    AL2(0)                  INFO REASON CODE
         DC    A(0)                    ADDR OF TEXT PTRS
         DC    A(0)                    ADDR OF RBX
         DC    AL4(0)                  MORE FLAGS
*
POST     POST  0,ASCB=0,ERRET=0,MF=L
POSTL    EQU   *-POST
*
*
BLANKS   DC    CL120' '
NONBLANK DC    64X'FF',X'00',191X'FF'   TR Table to locate nonblank
BLANK    DC    64X'00',X'FF',100X'00'   TR Table to locate blanks
TRTAB$   DC    91X'00',X'FF',164X'00'   TR Table to locate '$'
HEXTRAN  DC    CL16'0123456789ABCDEF'  Translate table
*
*                456789012345678901234567890123 45678 90123456789012345
NJE079I  DC    C'NJE079I NETSPOOL RTNCD/ERRCD=X''0000'',REQ=01,O=1234,Mx
               MMMMMMM     '
*                                                                       NJE00920
*                                                                       NJE00920
*********************                                                   NJE00920
*  N J E R E Q      *               NJEREQ presently only supports      NJE00920
*                   *               REX request types for CMD and MSG   NJE00920
*  Supports the     *               AXS request type open/close         NJE00920
*  GIVEREQ vector   *                                                   NJE00920
*                   *                                                   NJE00920
*********************                                                   NJE00920
*                                                                       NJE00920
* This csect is called by:  every place there is a GIVEREQ call in      NJE00920
*                           DMTXJE.                                     NJE00920
*                                                                       NJE00920
*                                                                       NJE00920
NJEREQ   CSECT                                                          NJE00020
         B     28(,R15)               BRANCH AROUND EYECATCHERS
         DC    AL1(23)                LENGTH OF EYECATCHERS
         DC    CL9'NJEREQ'
         DC    CL9'&SYSDATE'
         DC    CL5'&SYSTIME'
         STM   R14,R12,12(R9)          Save DMTXJE regs                 NJE00050
         LR    R12,R15                 Base                             NJE00060
         USING NJEREQ,R12              ADDRESS IT                       NJE00070
         L     R10,0(,R9)              -> NJEWK
         USING NJEWK,R10
*
         ST    R9,NJEREQSA+4
         LA    R13,NJEREQSA
         ST    R13,8(,R9)
*
         L     R11,ANJECOM         -> common csect
         USING NJECOM,R11
         L     R8,AMSGWK           -> msg processing work area
         USING MSGWK,R8
*
         USING REQBLOK,R1
         CLC   REQTASK,=CL4'REX'   Is this a CMD or MSG req?
         BE    REX000              Yes
         CLC   REQTASK,=CL4'AXS'   Is this an AXS-style req?
         BE    CALLAXS             Yes
         B     AB40                Unhandled req type for now
*
REX000   EQU   *
         L     R3,REQBUFA          -> associated request buffer
         CLI   MSGBTYP-MSGBLOK(R3),0  Is this a CMD type request?
         BE    CMD000              Yes
         CLI   MSGBTYP-MSGBLOK(R3),2  Is this a MSG type request?
         BE    REX010              Yes
*
U0047    EQU   *                ** Here if invalid REX-type requesst
         LR    R5,R1               R1 contents to R5 for dump regs
         ABEND 47,DUMP,STEP        This abend should not occur
*
CALLAXS  EQU   *
*                                  r1 -> original request block
*                                  r8 -> MSGWK
*                                  r10-> NJEWK
         L     R15,=A(NJEAXS)      -> AXS routines
         BALR  R14,R15             Go handle it
         B     XITREQ              And return to DMTXJE w R15=RC
*
*-- Message to MVS Console or TSO user
*
REX010   EQU   *
         BAL   R14,MSG000          Go process a MSGBLOK
         LA    R1,WTOMSG
         USING MSGBLOK,R3
         NJETRACE TYPE=TRCMSG      Message
         STCM  R10,7,1(R14)        Identify trace entry            v212
         MVC   4(1,R14),MSGBLEN     Msg len                        v212
         MVC   6(2,R14),MSGNUM      Msg number                     v212
         MVC   8(8,R14),MSGVMID     Msg target
         MVC   16(16,R14),WTOMSG+4  Move a bit of msg text         v212
*
         LA    R5,REX020           -> where to go if no userid
         CLI   MSGBRTE,X'20'       Message only to user?
         BE    REX030
*
REX020   EQU   *
         WTO   ,MF=(E,(1))
*
         CLC   MSGNUM,=AL2(145)    Is this msg 145 (file recv'd)?
         BE    REX100              Yes, special handling
         CLC   MSGNUM,=AL2(905)    Is this msg 905 (signon complete)?
         BE    REX200              Yes, special handling
*
         LA    R5,XITREQ00         -> where to go if no userid
         TM    MSGBRTE,X'20'       Message also to user?
         BO    REX030
         B     REX900              Done with request
*
REX030   EQU   *
         NI    MSGBRTE,255-X'20'   Turn off user flag
         CLC   MSGVMID,=CL8'OP'    Message is for the 'user' operator?
         BER   R5                  Yes, send to console or exit
         CLI   MSGVMID,X'00'       No response to userid?
         BER   R5                  Yes, send to console or exit
         CLI   MSGVMID,C' '        No TSO userid?
         BER   R5                  Yes, send to console or exit
*
REX040   EQU   *
         LA    R15,MSGVMID         -> userid to locate
*
         SR    R0,R0               R0=0 search and queue           v220
         BAL   R14,REG000          Search for registered user      v220
         BNZ   REX900              Msg queued, just exit here      v220
*
         BAL   R14,USR800          See if TSO user logged on
         BZ    REX900              Skip msg if not
*
         MVC   MTEXT,BLANKS
         MVC   MWORK,BLANKS
         MVC   MTEXT(4),=C'SE '''
         MVC   MTEXT+4(104),WTOMSG+4                               v102
         MVC   WTOMSG+4(108),MTEXT Move it back to WTO buffer      v210
         LA    R2,WTOMSG+111       -> last byte from MTEXT area    v210
         LA    R0,32               # char to check backwards       v210
*
REX050   EQU   *                   Only look backwards to col 80   v210
         CLI   0(R2),C' '          Try to find last non-blank      v210
         BNE   REX060              Found it                        v210
         BCTR  R2,0                -> prev char                    v210
         BCT   R0,REX050           Keep scanning                   v210
*
REX060   EQU   *                                                   v210
         LA    R2,1(,R2)           -> first blank after last char  v210
         MVC   0(8,R2),=C''',USER=('                               v210
         MVC   8(12,R2),BLANKS      Ensure trailer initted         v210
         MVC   8(7,R2),MSGVMID      Max for TSO userid is 7        v210
         LA    R1,8+7(,R2)          -> max end of trt              v210
         TRT   8(7,R2),BLANK        Look for end of userid         v210
         MVI   0(R1),C')'           Move closing                   v210
         MVI   1(R1),C' '           Plus 1 blank                   v210
         LA    R0,WTOMSG            -> start of msg area           v210
         SR    R1,R0                Compute length of msg          v210
         LA    R1,1(,R1)            Account for blank at end       v210
         XC    WTOMSG(4),WTOMSG     Clear len, flags               v210
         STH   R1,WTOMSG            Insert the msg length          v210
*
         SPKA  0
         LA    R1,WTOMSG
         SR    R0,R0
         SVC   34                  Issue MGCR SVC
         SPKA  X'80'
         B     REX900              Done with request
*
*-- When MSG 145 is issued that a file has been received,
*-- then do the following IF this is the final node for the file:
*
*--  1. Send a message back to the sender that file arrived at this
*--     node.
*--  2. Send a message to the destination TSO user that file arrived.
*
*
REX100   EQU   *
         CLC   MSGVARS+24(8),LCLNODE   Was file for this node?
         BNE   REX900                  No, done with msg
         MVC   MSGVMID,MSGVARS+32      Set userid of new file to recv
*                                       arrival msg
*
*-- Prepare a remote msg to the file sender that file arrived here.
*
         BAL   R14,GTW000              Get a WRE
*
         LR    R4,R1
         USING WRE,R4
         MVC   WRELINK,MSGVARS+8       Dest= file sender's node
         MVC   WREUSER,MSGVARS+16      Dest= file sender's userid
         MVC   WREORIG,BLANKS          No originating user
         MVC   WRETXT,BLANKS           Init
         MVC   WRETXT(6),=CL6'File ('  Set msg
         MVC   WRETXT+6(4),MSGVARS+0   File number
         MVC   WRETXT+10(34),=CL34') received at destination node for'
         MVC   WRETXT+45(8),MSGVARS+24 show dest node
         TRT   WRETXT+45(9),BLANK      Look for end
         MVI   0(R1),C'('
         MVC   1(8,R1),MSGVARS+32      show dest user
         TRT   1(9,R1),BLANK           Look for end
         MVI   0(R1),C')'
         MVI   WRETXTLN,66             Set the max possible len
*
         BAL   R14,PST000              Queue the WRE to main task
         DROP  R4                      WRE
*
*-- Finally, go tell local TSO user that his file arrived.
*
         B     REX040                  Tell him it arrived
*
*-- MSG 905 is issued when signon is complete.
*-- Send a copy of it back to the connecting node's operator.
*
REX200   EQU   *
         BAL   R14,GTW000              Get a WRE
*
         LR    R4,R1
         USING WRE,R4
         MVC   WRELINK,XJENODE         Dest= file sender's node
         MVC   WREUSER,BLANKS          Dest= operator or RSCS console
         MVC   WREORIG,BLANKS          No originating user
         MVC   WRETXT,BLANKS           Init
         MVC   WRETXT(50),MTEXT+2      Set 'connected' msg text
         MVI   WRETXTLN,51             Set the max possible len
*
         BAL   R14,PST000              Queue the WRE to main task
         DROP  R4                      WRE
         B     REX900                  Done with msg
*
REX900   EQU   *
         MVC   MSGVMID,BLANKS      Clear to avoid inadvertent oper msgs
         MVC   MSGVARS(16),BLANKS  issued to users
         B     XITREQ00
         DROP  R3                      MSGBLOK
*
*-- Process incoming command from remote users
*
*    CMD000 - extract the command and echo it to MVS console.
*    CMD100-CMD300 - Process the command and respond to requestor.
*
TGTUSER  EQU   0                   cmd response returned to remote user
TGTCONS  EQU   4                   cmd response returned to sys console
*
CMD000   EQU   *
         LR    R6,R3               CMDBLOK ptr to R6
         USING CMDBLOK,R6
         XC    MBLOK,MBLOK         Clear area to build MSGBLOK
         LA    R4,MBLOK            -> msg blok area
         USING MSGBLOK,R4
         MVC   MSGVARS(14*8),BLANKS Init  variables area
         MVC   MSGBLEN,CMDBLEN     Move text length
         MVI   MSGBTYP,2           Set msg type request
* LOCATION EXECUTING:
         MVC   MSGNUM,=AL2(5)      Use message number 5
         MVC   MSGVARS+0(8),CMDLINK  Move node name as msg variable
         MVC   MSGVARS+8(8),CMDVMID  Move userid as msg variable
         LA    R15,MSGVARS+16      -> where variables will start
*
         NJETRACE TYPE=TRCRCMD     Trace remote command
         STCM  R10,7,1(R14)        Identify trace entry            v212
         MVC   7(1,R14),CMDBLEN    Trace length                    v212
         MVC   8(8,R14),CMDVMID     remote userid                  v212
         MVC   16(8,R14),CMDLINK    remote node                    v212
*
         CLI   CMDVMID,X'40'       Is userid leading off blank?    v200
         BE    CMD015              Yes use msg 4                   v200
         CLI   CMDVMID,X'00'       Is userid present?
         BNE   CMD020              Yes, use MSG 5 as planned
*
CMD015   EQU   *                                                   v200
         MVC   CMDVMID,BLANKS      Ensure userid is blanks
         MVC   MSGNUM,=AL2(4)      Use message number 4 instead
         LA    R15,MSGVARS+8       -> where variables will start
*
CMD020   EQU   *
         SR    R5,R5               Clear for IC
         IC    R5,CMDBLEN          Get the cmd length
         BCTR  R5,0                Adjust for execute              v110
         S     R5,=A(CMDTEXT-CMDBLOK-1) less block & sender ovrheadv110
         BNP   XITREQ00            Ignore if invalid len
         STC   R5,CMDBLEN          Save adjusted len
         EX    R5,MVCCMD           Move the actual cmd text
*MVCCMD  MVC   0(0,R15),CMDTEXT
         LA    R1,0(R5,R15)        -> last byte used in MSGVARS
         SR    R1,R3               Compute length of this MSGBLOK
         ST    R1,MSGBLEN          Plug it into its length field
*
         NJETRACE TYPE=TRCRCMD     Remote command
         OI    0(R14),X'80'        Indicate continuation trace entry
         MVC   1(31,R14),CMDTEXT   1st 31 bytes cmd to trace       v212
*
         LR    R3,R4               -> built MSGBLOK in R3
         BAL   R14,MSG000          Go format the message
         MVC   WTOMSG+10(112),MTEXT Move finished msg
         LA    R1,WTOMSG
         WTO   ,MF=(E,(1))         Show cmd on console
*
CMD050   EQU   *
         ST    R6,ACMDBLOK         Set addr in cmd parm list
         LA    R1,INITPARM         -> parm list to pass            v211
         LA    R0,TGTUSER          Remote user gets response
         L     R15,ANJECMX         -> Command processor
         BALR  R14,R15             Call NJECMX
*
*-- Exit command processing
*
CMD990   EQU   *
         L     R1,AMSGECB          -> DMTXJE MSGECB
         POST  (1)                 Tell DMTXJE there are stacked msgs
         B     XITREQ00            And exit
*
MVCCMD   MVC   0(0,R15),CMDTEXT    executed instr
*
         DROP  R6                  CMDBLOK
         DROP  R4                  MSGBLOK
*
*
*
*
*
*-- Process MSGBLOK and format a message
*
*   Exit: formatted message text is in MTEXT and ready for WTO or
*         other disposition.
*
         DS    0F
MSG000   EQU   *
         USING MSGBLOK,R3
         STM   R0,R9,MSGREGS       Save working regs
         L     R4,=V(DMTMSG)       -> message repository
         USING MSGREPO,R4
*
MSG010   EQU   *
         CLC   MSGRNEXT,=A(0)      End of MSG repo?
         BE    AB41                Yes, unknown msg number
         CLC   MSGNUM,MSGRNUM      Locate msg in repo
         BE    MSG020              Found it
         L     R4,MSGRNEXT         -> next msg in repo
         B     MSG010              Keep looking
*
MSG020   EQU   *
         MVC   MSGBRTE,MSGRFLGS    Move routing flags
         MVC   WTOMSG(WTOL),WTO    Move macro model
         MVC   WTOMSG+4(3),=CL3'NJE'  MSG id
         LH    R0,MSGNUM           Get message number
         CVD   R0,DBLE             Convert
         UNPK  WTOMSG+7(3),DBLE    Make display
         OI    WTOMSG+9,X'F0'      Fix sign
         MVC   MTEXT,BLANKS        Init work field
         MVC   MWORK,BLANKS        Init work field
         CLC   MSGNUM,=AL2(170)    Is this special msg 170?
         BE    MSG170              Yes, special handling
         CLC   MSGNUM,=AL2(171)    Is this special msg 171?
         BE    MSG171              Yes, special handling
         SR    R15,R15             Clear for IC
         IC    R15,MSGRLEN         Get msg text length
         BCTR  R15,0               Adjust for execute
         EX    R15,MVCMSG          Move msg text to work area
*MVCMSG  MVC   MTEXT(0),MSGRTXT
*
         SR    R5,R5               Clear for IC
         IC    R5,MSGBLEN          Get length of msg block
         S     R5,=A(MSGVARS-MSGBLOK) Less size of overhead portion
         BNP   MSG100              Branch if no variables
         LA    R15,MSGVARS         -> message variables
         LA    R1,MTEXT            -> message area
*
MSG050   EQU   *
         TRT   0(L'MTEXT,R1),TRTAB$ Look for replacement indic
         BZ    MSG100              All text replaced
         MVC   MWORK,1(R1)         Save off remainder of line
         MVC   0(8,R1),0(R15)      Put replacement text in line
*-
         LA    R0,7                max # blanks to look for
         AR    R1,R0               -> last byte this repl text
*
MSG060   EQU   *
         CLI   0(R1),C' '          Is this byte blank?
         BNE   MSG070              No; true end of repl text var
         BCTR  R1,0                -> previous replacement text char
         BCT   R0,MSG060           Keep looking for ending blank
         LA    R1,7(,R1)           No blanks, all 8 char used; -> next
*
MSG070   EQU   *
         LA    R1,1(,R1)           -> blank or last char of repl var
         MVC   0(L'MTEXT,R1),MWORK Recopy saved part of msg
         LA    R15,8(,R15)         -> next replacement var
         S     R5,=F'8'            Reduce length remaining vars
         BP    MSG050              Go replace more text
*
MSG100   EQU   *
         CLI   0(R1),C'$'          More immediate $ delims remaining?
         BNE   MSG110              No
         MVC   0(L'MTEXT,R1),BLANKS Clear any remaining $ delims
*
MSG110   EQU   *
         MVC   WTOMSG+10(112),MTEXT Move finished msg
         LM    R0,R9,MSGREGS       Restore caller regs
         BR    R14                 Return with message in MTEXT
*
MVCMSG   MVC   MTEXT(0),MSGRTXT    Executed instr
         DROP  R4                  MSGREPO
*
*-Special case for msg 170:        From NODE:
*
*- Dont issue msg number prefix (e.g., NJE170I)
*- Just move msg as is to WTO buffer; dont parse thru all the $ chars
*
MSG170   EQU   *
         SR    R5,R5               Clear for IC
         IC    R5,MSGBLEN          Get length of msg block
         S     R5,=A(MSGVARS-MSGBLOK) Less size of overhead portion
         BNP   MSG100              Branch if no variables
         MVC   MTEXT(L'M17X),M17X  Set up msg
         LA    R15,MSGVARS         -> message variables
         MVC   MTEXT+7(8),0(R15)   Move node name from
         TRT   MTEXT+7(9),BLANK    Look for end of node name
         MVI   0(R1),C':'          Insert the colon
         LA    R1,2(,R1)           Skip : and one blank
         S     R5,=F'8'            Reduce length of nodename we moved
*
         EX    R5,MVCMSG70         Move the msg text
         LM    R0,R9,MSGREGS       Restore caller regs
         MVC   WTOMSG+4(112),MTEXT+2 Move finished msg w/o NJE170I
         BR    R14                 Return with message 170 in MTEXT
*
MVCMSG70 MVC   0(0,R1),8(R15)      Executed instr
*
*-Special case for msg 171:        From NODE(USERID):
*
*- Dont issue msg number prefix (e.g., NJE171I)
*- Just move msg as is to WTO buffer; dont parse thru all the $ chars
*
MSG171   EQU   *
         ST    R14,SVR14M          Save R14                        v220
         LA    R15,MSGVMID         -> userid to locate
         LA    R0,1                R0=1 search for userid only     v220
         BAL   R14,REG000          Search for registered user      v220
         BNZ   MSG171J             User was regs'trd, skip TSO chk v220
         BAL   R14,USR800          See if TSO user logged on
         BZ    UNL000              Skip message if user not logged on
*
MSG171J  EQU   *                                                   v220
         SR    R5,R5               Clear for IC
         IC    R5,MSGBLEN          Get length of msg block
         S     R5,=A(MSGVARS-MSGBLOK) Less size of overhead portion
         BNP   MSG100              Branch if no variables
         MVC   MTEXT(L'M17X),M17X  Set up msg
         LA    R15,MSGVARS         -> message variables
         MVC   MTEXT+7(8),0(R15)   Move node name from
         TRT   MTEXT+7(9),BLANK    Look for end of node name
         MVI   0(R1),C'('          Insert the paren
         MVC   1(8,R1),8(R15)      Move node userid from
         TRT   1(9,R1),BLANK       Look for end of userid
         MVC   0(2,R1),=C'):'      Insert the paren
         LA    R1,3(,R1)           Skip : and one blank
         S     R5,=F'16'           Reduce length of node/user we moved
*
         EX    R5,MVCMSG71         Move the msg text
         LM    R0,R9,MSGREGS       Restore caller regs
         MVC   WTOMSG+4(112),MTEXT+2 Move finished msg w/o NJE170I
         L     R14,SVR14M          Load return addr                v220
         BR    R14                 Return with message 170 in MTEXT
*
MVCMSG71 MVC   0(0,R1),16(R15)     Executed instr
*
*-- Send msg back to a MSG sender that user is not logged on
*
UNL000   EQU   *                   User Not Logged
         L     R7,CSABLK               -> NJE38 CSA block
         USING NJ38CSA,R7
*
         GETMAIN RU,                   Get CSA for WRE TYPE=WREMSG     x
               LV=WRESIZE,                                         v220x
               SP=2                                                v220
         XC    0(WRESIZE,R1),0(R1)     Clear stg area              v220
*
*
         NJETRACE TYPE=TRCGWRE
         STCM  R10,7,1(R14)        Identify trace entry            v220
         LA    R15,*
         STCM  R15,7,5(R14)        Addr of Getmain to trace        v212
         STM   R0,R1,8(R14)        Len, stg addr to trace          v220
         MVI   8(R14),2            Trace subpool #                 v220
*
         LR    R4,R1
         USING WRE,R4
         MVI   WRESP,2                 Save subpool                v220
         MVI   WRETYPE,WREMSG          Set type to MSG type
         MVC   WRELINK,MSGVARS+0       Set destination node
         MVC   WREUSER,MSGVARS+8       Set destination user
         MVC   WREORIG,BLANKS          No originating user
         MVC   WRETXT,BLANKS           Init
         MVC   WRETXT(4),=CL4'User'    Set msg
         MVC   WRETXT+5(8),MSGVMID     User name of msg sender
         TRT   WRETXT+5(9),BLANK       Look for end
         MVC   1(13,R1),=CL13'not logged on'   Set msg
         MVI   WRETXTLN,27             Set the max length
         DROP  R3                      MSGBLOK
*
         SPKA  0                                                   v220
         LM    R2,R3,NJ38SWAP          Get first WRE ptr, sync count
UNL020   EQU   *
         ST    R2,WRENEXT              First WRE becomes next
         LA    R5,1(,R3)               Incr synchronization count
         CDS   R2,R4,NJ38SWAP          Update CSA WRE anchor, sync
         BC    7,UNL020                Gotta try again
*
         LA    R7,NJ38ECB              -> NJE38 external WRE ECB
         DROP  R7                      NJ38CSA
         DROP  R4                      WRE
*
         POST  (7)                     Post the main task WRE ECB
*
         SPKA  X'80'
*
         LM    R0,R9,MSGREGS       Restore caller regs
         B     XITREQ00            And exit
*
*
*
*
*-- Special code to intercept messages destined for                v220
*-- registered users                                               v220
*
*-- Entry:  R0=0 Search for user and queue msg if registered       v220
*           R0=1 Search for user only (no queuing)                 v220
*
REG000   EQU   *                                                   v220
         L     R2,AREGUSER         -> registered user anchor word  v220
         ICM   R2,15,0(R2)         -> registered user queue        v220
         BZR   R14                 No registered users             v220
*
         USING REGUSERB,R2                                         v220
REG010   EQU   *                                                   v220
         CLC   REGUSRID,0(R15)     Find a matching registered user v220
         BE    REG020              Found it                        v220
         ICM   R2,15,REGNEXT       -> next REGUSER entry           v220
         BNZ   REG010              Keep looking                    v220
         BR    R14                 Userid was not registered       v220
*
REG020   EQU   *                                                   v220
         LTR   R0,R0               Search only or search and queue?v220
         BNZR  R14                 Exit if only search selected    v220
*                                                                  v220
         ST    R14,SVR14R          Save return addr                v220
         BAL   R14,GTW000          Get a WRE                       v220
         LR    R4,R1                                               v220
         USING WRE,R4                                              v220
         MVI   WRETYPE,WREQRM      Queue registered msg WRE        v220
*
         MVC   WRELINK,LCLNODE     Target WRE to local node task   v220
         MVC   WREUSER,REGUSRID    Dest= registered user id        v220
         MVC   WREORIG,BLANKS      No originating node             v220
         MVC   WRETXT,WTOMSG+4     Plug in the msg to be queued    v220
         MVI   WRETXTLN,L'WRETXT   Set the max possible len        v220
*
         BAL   R14,PST000          Queue WRE to main task          v220
*
         DROP  R2,R4               REGUSERB,WRE                    v220
*
REG090   EQU   *                                                   v220
         L     R14,SVR14R          Load return addr                v220
         LTR   R14,R14             Set non-zero CC                 v220
         BR    R14                 Ret w/CC non-zero (msg queued   v220
*
*
XITREQ00 EQU   *
         SR    R15,R15             Set RC=0
*
XITREQ   EQU   *
         L     R9,4(,R13)          -> DMTXJE save area
         ST    R15,16(,R9)         Set return R15
         LM    R14,R12,12(R9)      Reload callers regs
         BR    R14                 Return to DMTXJE
*
AB40     EQU   *                   Unhandled request type
         LR    R4,R0
         LR    R5,R1
         ABEND 40,DUMP,STEP
AB41     EQU   *                   Unhandled message number
         LR    R4,R0
         LR    R5,R1
         ABEND 41,DUMP,STEP
         DROP  R8                  MSGWK
         LTORG
*               1234567890123456789012345678901234567890123456789012345
WTO      WTO   '                                                       x
                                                                       x
                        ',MF=L
*              67890123456789012345678901234567890123456789012345678901
WTOL     EQU   *-WTO
*
M17X     DC    CL24'I From xxxxxxxx '
*
*-- DSECTS used by NJEREQ
*
*
REQBLOK  DSECT                     Map request area used by DMTXJE
REQLOK   DS    F'0'                SYNCH LOCK
REQTASK  DS    CL4'REX '           TASK NAME
REQBUFA  DS    A(0)                -> REQUEST BUFFER
REQRESPA DS    A(0)                -> RESPONSE area or zero
*
*
PDEVBLOK DSECT                     PRT/PUN device request block
PDEVRLEN DS    AL1(19)             REQUEST LENGTH
PDEVFUN  DS    AL1(0)              REQUEST FUNCTION
OOPCODE  EQU   X'11'                OPEN OUTPUT FILE
OCLCODE  EQU   X'12'                CLOSE OUTPUT FILE
PDEVRESV DS    AL1(0)              RESERVED BYTE
PDEVSOPT DS    AL1(0)              Dev type (e.g., TYPPUN)
TYPPRT   EQU   X'40'                PRT dev
TYPPUN   EQU   X'80'                PUN dev
APDEVTAG DS    A(0)                Tag address
PDEVFIOA DS    A(0)                FILE I/O AREA
PDEVLINK DS    CL8' '              LINK NAME
*
RDEVBLOK DSECT                     RDR device request block
RDEVRLEN DS    AL1(19)             REQUEST LENGTH
RDEVFUN  DS    AL1(0)              REQUEST FUNCTION
IOPCODE  EQU   X'01'                OPEN INPUT FILE
ICLCODE  EQU   X'02'                CLOSE INPUT FILE
RDEVRESV DS    AL1(0)              RESERVED BYTE
RDEVSOPT DS    AL1(0)              Dev type (e.g., TYPRDR)
TYP2540R EQU   X'82'                2540 RDR
RPDEVTAG DS    A(0)                Tag address
RDEVFIOA DS    A(0)                FILE I/O AREA
RDEVLINK DS    CL8' '              LINK NAME
*
*
MSGBLOK  DSECT                     Map msg area used by DMTXJE
MSGBLEN  DS    AL1                 MSGBLOK length
MSGBTYP  DS    AL1(2)              Type 2 = MSGBLOK request
MSGBRTE  DS    AL1                 Route code
MSGBSEV  DS    AL1                 Severity code
MSGLINK  DS    XL8                 LINKID
MSGVMID  DS    CL8                 VIRTUAL MACHINE ID
MSGID    DS    CL3'XJE',CL1' '     Module ID plus action code
MSGBUF   DS    0CL120' '           MSG BUFFER
MSGNUM   DS    AL2                 RSCS msg number
         DS    AL2
MSGVARS  DS    14CL8               Variables for msg
MSGBLOKL EQU   *-MSGBLOK           Size of dsect
*
*
MSGREPO  DSECT                     Map msg repository in DMTMSG
MSGRNEXT DS    A                   Address of next MDEF entry
MSGRNUM  DS    H                   RSCS Message number
MSGRFLGS DS    X                   Message flags
         DS    AL1                 Unused byte
MSGRLEN  DS    AL1                 Length of msg text
MSGRTXT  DS    0CL120              Text of raw message
*
*
MSGWK    DSECT                     MSG work area (used by NJEREQ)
MSGEYE   DS    CL4'MSGW'           Eyecatcher
MSGWKLEN DS    F                   Size of area
MSGREGS  DS    10A                 Save regs 0-9 in MSG000
WTOMSG   DS    CL128
MTEXT    DS    CL120               Message text work area
MWORK    DS    CL120               Message text work area
MBLOK    DS    (MSGBLOKL)X         Space to build a MSGBLOK
SV14     DS    A                   R14 save area
SV23     DS    2A                  R2,R3 save area
         DS    0D                  Force doubleword size
MSGWKSZ  EQU   *-MSGWK
*                                                                       NJE00920
*                                                                       NJE00920
*********************                                                   NJE00920
*  N J E A X S      *               NJEREQ presently only supports      NJE00920
*                   *               AXS request type open/close         NJE00920
*  Supports the     *                                                   NJE00920
*  GIVEREQ vector   *                                                   NJE00920
*  for AXS function *                                                   NJE00920
*                   *                                                   NJE00920
*********************                                                   NJE00920
*                                                                       NJE00920
*                                                                       NJE00920
* This csect is called by:  NJEREQ, after an AXS-based GIVEREQ call in  NJE00920
*                           DMTXJE.                                     NJE00920
*
*
*
*
NJEAXS   CSECT                                                          NJE00020
         B     28(,R15)               BRANCH AROUND EYECATCHERS
         DC    AL1(23)                LENGTH OF EYECATCHERS
         DC    CL9'NJEAXS'
         DC    CL9'&SYSDATE'
         DC    CL5'&SYSTIME'
         STM   R14,R12,12(R13)         Save DMTXJE regs                 NJE00050
         LR    R12,R15                 Base                             NJE00060
         USING NJEAXS,R12              ADDRESS IT                       NJE00070
         USING NJEWK,R10
         USING NJECOM,R11
*
         ST    R13,NJEAXSSA+4
         LA    R13,NJEAXSSA
*
*
         LR    R4,R1
         USING REQBLOK,R4
*
*
AXS000   EQU   *
         L     R3,REQBUFA          -> associated request buffer
         USING PDEVBLOK,R3         PDEVBLOK/RDEVBLOK are the same
         CLI   PDEVFUN,IOPCODE     Open input type request?
         BE    AXSA000             Yes
         CLI   PDEVFUN,ICLCODE     Close input type request?
         BE    AXSB000             Yes
         CLI   PDEVFUN,OOPCODE     Open output type request?
         BE    AXSP000             Yes
         CLI   PDEVFUN,OCLCODE     Close output type request?
         BE    AXSC000             Yes
         DROP  R4                  REQBLOK
*
U0046    EQU   *                ** Here if invalid AXS-type requesst
         ABEND 46,DUMP,STEP        This abend should not occur
*
*-- AXS Open output file request
*
AXSP000  EQU   *
         CLI   PDEVRLEN,19         Less than required length?
         BL    U0046               Y, inv request length
*
AXSP010  EQU   *
         GETMAIN RU,LV=4096,BNDRY=PAGE  Get PDEVFIOA stg
         ST    R1,PDEVFIOA
         XC    0(256,R1),0(R1)     Clear 256
*
         NJETRACE TYPE=TRCGET
         STCM  R10,7,1(R14)            Identify trace entry        v212
         LA    R15,*
         STCM  R15,7,5(R14)            Addr of Getmain to trace    v212
         STM   R0,R1,8(R14)            Len, stg addr to trace      v212
*
*
*- Build an IOTABLE block, modeled like RSCSADA
*- DMTAXS OPENOUT does this same thing.
*
         USING RSCSADA,R1
         MVC   ADACUU,=X'000D'     Make look like PUN 00D
         MVI   ADATYP,TYPPUN       Set as PUN dev type
*
         L     R6,APDEVTAG         -> Tag data
         USING TAG,R6
         TM    TAGINDEV,TYPPUN     Is it actually a PUN type?
         BO    AXSP015             Yes
         MVC   ADACUU,=X'000E'     Make look like PRT 00E
         MVI   ADATYP,TYPPRT       Set as PRT dev type
*
AXSP015  EQU   *
         MVI   ADASREQ,X'01'       One sense byte
         MVC   ADACCW,DMYCCW       Set up dummy write CCW
         LA    R2,ADABUFF          -> buffer
         STCM  R2,7,ADACCW+1       Set in dummy CCW
         DROP  R6                  TAG
*
*-- Open Spool to write out the incoming tranmission data
*
         LA    R6,NCB1             -> NCB for output file
         USING NCB,R6
         MVC   NCBFL1,ADATYP       Set PRT or PUN type in NCB
         DROP  R1                  RSCSADA
*
         NSIO  TYPE=OPEN,          Open dataset                        x
               NCB=(R6),                                           v210x
               ENTRY=ANJESPL                                       v210
*
         NJETRACE TYPE=TRCOPNO     Open output request
         STCM  R10,7,1(R14)        Identify trace entry            v212
         MVC   4(1,R14),NCBFL1     Prt or Pun type                 v212
         MVC   6(2,R14),NCBRTNCD   Error code bytes                v212
*
         LTR   R15,R15             Any errors?
         BZ    AXSP020             No
         BAL   R14,FMT000          Display error
         B     U0039               Abend on VSAM error
         DROP  R6                  NCB
*
AXSP020  EQU   *
         POST  (4)                 Post the RSCS synch lock (PDEVSYNC)
         B     XITAXS00
*
*-- AXS Close output file request
*-- Then build a WRE to alert the outgoing task (if needed) that
*-- a file has arrived for it to send out.
*
AXSC000  EQU   *
         CLI   PDEVRLEN,11         Less than required length?
         BL    U0046               Y, inv request length
*
         L     R1,PDEVFIOA         -> i/o area
*
         NJETRACE TYPE=TRCFREE
         STCM  R10,7,1(R14)            Identify trace entry        v212
         LA    R15,*
         STCM  R15,7,5(R14)            Addr of Getmain to trace    v212
         L     R0,=F'4096'             Size to free
         STM   R0,R1,8(R14)            Len, stg addr to trace      v212
*
         FREEMAIN RU,LV=(0),A=(1)
         XC    PDEVFIOA,PDEVFIOA
*
         LA    R6,NCB1                 -> NCB for output use
         USING NCB,R6
         L     R5,APDEVTAG         -> tag data
         NSIO  TYPE=CLOSE,             Done with spool file            x
               NCB=(R6),                                               x
               TAG=(R5),                                           v210x
               ENTRY=ANJESPL                                       v210
*
         NJETRACE TYPE=TRCCLSO     Open output request
         STCM  R10,7,1(R14)        Identify trace entry            v212
         MVC   4(1,R14),NCBFL1     Flags                           v212
         MVC   6(2,R14),NCBRTNCD   Error code bytes                v212
         MVC   8(2,R14),NCBFID     File id #                       v212
         MVC   10(2,R14),NCBRECCT  Record count                    v212
         MVC   16(8,R14),TAGINLOC-TAG(R5)   Incoming node id       v212
         MVC   24(8,R14),TAGTOLOC-TAG(R5)   Outgoing node id       v212
         DROP  R6
*
         POST  (4)                 Post the RSCS synch lock (PDEVSYNC)
*
         USING TAG,R5
         CLC   TAGTOLOC,LCLNODE    Was this system the dest?
         BE    AXSC090             Yes.  No other link needs wake-up
         DROP  R3                  PDEVBLOK
*
*-- Alert outgoing task
*
         L     R7,CSABLK               -> NJE38 CSA block
         USING NJ38CSA,R7
*
         GETMAIN RU,                   Get CSA for WRE TYPE=WRENEW     x
               LV=WRESIZE,                                         v220x
               SP=2                                                v220
         XC    0(WRESIZE,R1),0(R1)     Clear stg area              v220
         USING WRE,R1
*
         NJETRACE TYPE=TRCGWRE
         STCM  R10,7,1(R14)        Identify trace entry            v220
         LA    R15,*
         STCM  R15,7,5(R14)        Addr of Getmain to trace        v212
         STM   R0,R1,8(R14)        Len, stg addr to trace          v220
         MVI   8(R14),2            Trace subpool #                 v220
*
         MVI   WRESP,2                 Save subpool                v220
         MVI   WRETYPE,WRENEW          "New file in spool" WRE
         MVC   WRELINK,TAGTOLOC        Set destination node
         DROP  R5
*
         SPKA  0                                                   v220
         LM    R2,R3,NJ38SWAP          Get first WRE ptr, sync count
AXSC020  EQU   *
         ST    R2,WRENEXT              First WRE becomes next
         LR    R4,R1                   -> WRE to be added as first
         LA    R5,1(,R3)               Incr synchronization count
         CDS   R2,R4,NJ38SWAP          Update CSA WRE anchor, sync
         BC    7,AXSC020               Gotta try again
*
         LA    R7,NJ38ECB              -> NJE38 external WRE ECB
         DROP  R7                      NJ38CSA
*
         POST  (7)                     Post the main task WRE ECB
*
         SPKA  X'80'
*
AXSC090  EQU   *
         B     XITAXS00
*
*
*-- AXS Open input file request
*
AXSA000  EQU   *
         USING RDEVBLOK,R3
         CLI   RDEVRLEN,19         Less than required length?
         BL    U0046               Y, inv request length
*
AXSA010  EQU   *
         GETMAIN RU,LV=4096,BNDRY=PAGE  Get RDEVFIOA stg
         ST    R1,RDEVFIOA
         XC    0(256,R1),0(R1)     Clear 256
*
         NJETRACE TYPE=TRCGET
         STCM  R10,7,1(R14)            Identify trace entry        v212
         LA    R15,*
         STCM  R15,7,5(R14)            Addr of Getmain to trace    v212
         STM   R0,R1,8(R14)            Len, stg addr to trace      v212
*
*
*- Build an IOTABLE block, modeled like RSCSADA
*- DMTAXS OPENOUT does this same thing.
*
         USING RSCSADA,R1
         MVC   ADACUU,=X'000C'     Make look like RDR 00C
         MVI   ADASREQ,X'01'       One sense byte
         MVI   ADATYP,TYP2540R     Set as RDR dev type
         MVC   ADACCW,DMYCCW2      Set up dummy read CCW
         LA    R2,ADABUFF          -> buffer
         STCM  R2,7,ADACCW+1       Set in dummy CCW
         DROP  R1                  RSCSADA
*
*-- Open Spool to read file to be transmitted
*
         LA    R6,NCB2                 -> NCB for input file
         USING NCB,R6
*
         NSIO  TYPE=OPEN,              Open dataset                    x
               NCB=(R6),                                           v210x
               ENTRY=ANJESPL                                       v210
*
         NJETRACE TYPE=TRCOPNI         Open input request
         STCM  R10,7,1(R14)            Identify trace entry        v212
         MVC   4(1,R14),NCBFL1         flags                       v212
         MVC   6(2,R14),NCBRTNCD       Error code bytes            v212
*
         LTR   R15,R15                 Any errors?
         BZ    AXSA020                 No
         BAL   R14,FMT000              Display error
         B     U0039                   Abend on VSAM error
*
AXSA020  EQU   *
         NSIO  TYPE=CONTENTS,          Get list of files               x
               NCB=(R6),                                           v210x
               ENTRY=ANJESPL                                       v210
*
         NJETRACE TYPE=TRCCONT         Contents request
         STCM  R10,7,1(R14)            Identify trace entry        v212
         MVC   4(1,R14),NCBFL1         flags                       v212
         MVC   6(2,R14),NCBRTNCD       Error code bytes            v212
         ST    R14,SVR14               Save trace entry addr       v220
*
         LTR   R15,R15                 Any errors?
         BZ    AXSA030                 No
         CLC   NCBRTNCD(2),=AL1(12,6)  No files in directory?
         BE    AXSA180                 Close up and indicate no files
         BAL   R14,FMT000              Display error
         B     U0039                   Abend on VSAM error
*
AXSA030  EQU   *
         L     R2,NCBAREA              Get a list of spool content
         USING NSDIR,R2
         SR    R5,R5
         ICM   R5,3,NCBRECCT           # of returned entries
         SR    R7,R7                   Indicate nothing found yet  v211
*
AXSA040  EQU   *
         CLC   NSTOLOC,LCLNODE         Is this file already final? v221
         BE    AXSA160                 Y, dont let * route select  v221
         CLC   XJENODE,NSTOLOC         Is this file for this link?
         BE    AXSA150                 yes
*
*-- Also, look at routes
*
         L     R1,AROUTES              -> ROUTES anchor word       v211
         ICM   R1,15,0(R1)             -> RTE list                 v211
         BZ    AXSA160                 No matching routes to find  v211
         USING RTE,R1                                              v211
*
AXSA050  EQU   *
         LA    R14,ROUTNAME            -> name from route list     v211
         LA    R15,8                   max length                  v211
         LA    R8,NSTOLOC              -> selected name to locate  v211
         LR    R9,R15                  copy length                 v211
         CLCL  R14,R8                  Did we locate the name?     v211
         BE    AXSA090                 Yes                         v211
         CLI   0(R14),C'*'             Wildcard was in the name?   v211
         BE    AXSA090                 Y, we matched to that point v211
***      CLC   NSTOLOC,ROUTNAME        Is file dest in route list? v211
***      BE    AXSA090                 Found it
         ICM   R1,15,ROUTPTR           -> Next route entry         v211
         BNZ   AXSA050                 Keep looking                v211
         B     AXSA160                 No matching route; next file
*
AXSA090  EQU   *
         CLC   XJENODE,ROUTNEXT        Is route-to name our link?  v211
         BE    AXSA150                 Yes, use it                 v211
         CLC   XJENODE,ROUTALT1        Is route-to name our link?  v211
         BE    AXSA150                 Yes, use it                 v211
         CLC   XJENODE,ROUTALT2        Is route-to name our link?  v211
         BE    AXSA150                 Yes, use it                 v211
         CLC   XJENODE,ROUTALT3        Is route-to name our link?  v211
         BNE   AXSA160                 No, this file not for this link
*                                      Else, select this file
         DROP  R1                      RTE                         v211
*
AXSA150  EQU   *
         LA    R7,TDATA                -> tag data area for file   v211
         USING TAG,R7
         XC    TDATA(TAGLEN),TDATA                                 v211
         MVC   TAGINLOC(TAGUSELN),NSINLOC  Copy tag datq
         MVC   TAGLINK,XJENODE         Set up next link is this link
         ST    R7,NCBTAG               Tag block addr to NCB       v211
         L     R14,SVR14               Restore trace entry addr    v220
         MVC   4(2,R14),NCBFID         File id # to trace
         MVC   6(2,R14),NCBRECCT       Record count to trac
         MVC   8(8,R14),NSTOLOC        File destination node
         B     AXSA170
*
*
AXSA160  EQU   *
         LA    R2,NSDIRLN(,R2)         Next NETSPOOL dir entry
         BCT   R5,AXSA040              Continue thru the contents
         DROP  R2                      NSDIR
*
*
AXSA170  EQU   *
         LM    R0,R1,NCBAREAL          Get list length and address
         XC    NCBAREA,NCBAREA         Clear obsolete ptr
*
         NJETRACE TYPE=TRCFREE
         STCM  R10,7,1(R14)            Identify trace entry        v212
         LA    R15,*
         STCM  R15,7,5(R14)            Addr of Freemain to trace   v212
         STM   R0,R1,8(R14)            Len, stg addr to trace      v212
*
         FREEMAIN RU,LV=(0),A=(1)
*
         LTR   R7,R7                   Did we obtain tag data?     v211
         BZ    AXSA180                 No, no file available
*
         MVI   RDEVSOPT,TYP2540R       Set up reader type
         ST    R7,RPDEVTAG             Save tag data for DMTXJE    v211
*
         MVC   TAGDEV,=X'000C'         Pseudo reader dev addr
         MVC   TAGBLOCK,RDEVFIOA       Set the XJE i/o buffer addr
         IC    R1,TAGINDEV             Get PRT or PUN type flags
         N     R1,=A(TYPPRT+TYPPUN)    Keep only these bits
         STC   R1,NCBFL1               Set dev type in NCB
         DROP  R7                      TAG                         v211
*
         POST  (4)                 Post the RSCS synch lock (RDEVSYNC)
         B     XITAXS00
*
AXSA180  EQU   *
         POST  (4)                 Post the RSCS synch lock (RDEVSYNC)
         OI    0(R4),X'02'         Indicate no file available in ECB
*
         NSIO  TYPE=CLOSE,         Done with Spool                     x
               NCB=(R6),                                           v210x
               ENTRY=ANJESPL                                       v210
*
         NJETRACE TYPE=TRCCLSI     Open output request
         STCM  R10,7,1(R14)        Identify trace entry            v212
         MVC   4(1,R14),NCBFL1     Flags                           v212
         MVI   5(R14),X'FF'        Indic this trace entry = no filev212
         MVC   6(2,R14),NCBRTNCD   Error code bytes                v212
         DROP  R6                  NCB
         B     XITAXS00
*
*-- AXS Close input file request
*
AXSB000  EQU   *
         CLI   RDEVRLEN,11         Less than required length?
         BL    U0046               Y, inv request length
*
         L     R1,RDEVFIOA         -> i/o area
*
         NJETRACE TYPE=TRCFREE
         STCM  R10,7,1(R14)            Identify trace entry        v212
         LA    R15,*
         STCM  R15,7,5(R14)            Addr of Freemain to trace   v212
         L     R0,=F'4096'             Size to free
         STM   R0,R1,8(R14)            Len, stg addr to trace      v212
*
         FREEMAIN RU,LV=(0),A=(1)
         XC    RDEVFIOA,RDEVFIOA
*
         LA    R6,NCB2              -> NCB for input use
         USING NCB,R6
         NSIO  TYPE=PURGE,          Purge the file                     x
               NCB=(R6),                                           v210x
               ENTRY=ANJESPL                                       v210
*
         NJETRACE TYPE=TRCPURG     File purge request
         STCM  R10,7,1(R14)        Identify trace entry            v212
         MVC   4(1,R14),NCBFL1     Flags                           v212
         MVC   6(2,R14),NCBRTNCD   Error code bytes                v212
         MVC   8(2,R14),NCBFID     File id #                       v212
         MVC   10(2,R14),NCBRECCT  Record count                    v212
*
         LTR   R15,R15                 Any errors?
         BZ    AXSB020                 No
         BAL   R14,FMT000              Display error
         B     U0039                   Abend on VSAM error
*
AXSB020  EQU   *
         NSIO  TYPE=CLOSE,             Done with dataset               x
               NCB=(R6),                                           v210x
               ENTRY=ANJESPL                                       v210
*
         NJETRACE TYPE=TRCCLSI     Open output request
         STCM  R10,7,1(R14)        Identify trace entry            v212
         MVC   4(1,R14),NCBFL1     Flags                           v212
         MVC   6(2,R14),NCBRTNCD   Error code bytes                v212
         MVC   8(2,R14),NCBFID     File id #                       v212
         MVC   10(2,R14),NCBRECCT  Record count                    v212
         L     R5,NCBTAG           -> tag data
         MVC   16(8,R14),TAGTOLOC-TAG(R5)   Outgoing node id       v212
         DROP  R6                  NCB
*
         POST  (4)                 Post the RSCS synch lock (RDEVSYNC)
         B     XITAXS00
*
         DROP  R3                  PDEVBLOK
*
XITAXS00 EQU   *
         SR    R15,R15             Set RC=0
         B     XITAXS
*
XITAXS   EQU   *
         L     R13,4(,R13)         -> NJEREQ save area
         ST    R15,16(,R13)        Set RC for R15
         LM    R14,R12,12(R13)     Reload callers regs
         BR    R14                 Return to NJEREQ
*
         LTORG
*
DMYCCW   CCW   X'01',*-*,0,132     Dummy output CCW
DMYCCW2  CCW   X'02',*-*,0,80      Dummy input CCW
*                                                                       NJE00920
*                                                                       NJE00920
*********************                                                   NJE00920
*  N J E S I O      *            NJESIO supports comm line i/o,         NJE00920
*                   *             and PRT/PUN output to NETSPOOL.       NJE00920
*  Supports the     *                                                   NJE00920
*  IOREQ vector     *                                                   NJE00920
*                   *                                                   NJE00920
*********************                                                   NJE00920
*                                                                       NJE00920
*-- NJESIO is called by DMTXJE label RSIO for comm line i/o             NJE00920
*-- NJESIO is called by DMTXJE label PWRITDEV for print & punch i/o     NJE00920
*                                                                       NJE00920
*                                                                       NJE00920
NJESIO   CSECT                                                          NJE00020
         B     28(,R15)               BRANCH AROUND EYECATCHERS
         DC    AL1(23)                LENGTH OF EYECATCHERS
         DC    CL9'NJESIO'
         DC    CL9'&SYSDATE'
         DC    CL5'&SYSTIME'
         STM   R14,R12,12(R9)          Save DMTXJE regs                 NJE00050
         LR    R12,R15                 Base                             NJE00060
         USING NJESIO,R12              ADDRESS IT                       NJE00070
         L     R10,0(,R9)              -> NJEWK
         USING NJEWK,R10
*
         ST    R9,NJESIOSA+4
         LA    R13,NJESIOSA
         ST    R13,8(,R9)
         L     R11,ANJECOM         -> common csect
         USING NJECOM,R11
*
         LR    R7,R1               -> "RSCS adapter" i/o block
         USING RSCSADA,R7
*
         CLC   ADACUU,=X'000D'     Punch data?
         BE    PUNIO               Yes
         CLC   ADACUU,=X'000E'     Print data?
         BE    PRTIO               Yes
*
         LA    R8,XIOB             -> IOB
         USING IOBSTDRD,R8
         XC    XECB,XECB           Init ECB
         XC    XIOB,XIOB           Init IOB
         OI    IOBFLAG1,IOBDATCH+IOBCMDCH+IOBUNREL Turn on CD+CC flags
*********LA    R1,ADAECB           -> ECB
         LA    R1,XECB             -> Our own ECB for EXCP
         ST    R1,IOBECBPT         Set it in the IOB
         LA    R1,LINE1            -> DCB
         ST    R1,IOBDCBPT         Set it in the IOB
         MVC   IOBSTART,ADCCWA     Set ptr to CCW in IOB
         MVI   IOBSTART,X'00'      Ensure flag bits zeroed
*
         NJETRACE TYPE=TRCEXCP
         STCM  R10,7,1(R14)            Identify trace entry        v212
         MVC   4(4,R14),IOBECBPT   ECB address to trace            v212
         MVC   8(4,R14),IOBSTART   CCW start addr to trace         v212
         MVC   12(4,R14),12(R9)    R14 caller of this i/o operationv212
         L     R15,IOBSTART        -> CCWs                         v212
         MVC   16(8,R14),0(R15)    Trace 1st CCW                   v212
         TM    4(R15),X'C0'        CC or CD in CCW?                v212
         BZ    *+10                No                              v212
         MVC   24(8,R14),8(R15)    Trace 2nd CCW                   v212
*
         EXCP  XIOB                Execute the CCW
*
         B     XITSIO00
*
*-- Handle PUNCH records.
*
PUNIO    EQU   *
         L     R2,ADCCWA
         TM    0(R2),X'03'         No-operation CCW? (tag data)
         BO    NOOP                Yes, do not write
*
         SR    R3,R3
         ICM   R3,7,1(R2)          -> data addr in CCW
         LH    R5,6(,R2)           Get length from CCW
         LA    R6,NCB1             -> NCB for outgoing
         USING NCB,R6
*
         NSIO  TYPE=PUT,           Write record to spool               X
               NCB=(R6),                                               x
               AREA=(R3),                                              x
               RECLEN=(R5),                                        v210x
               ENTRY=ANJESPL                                       v210
         LTR   R15,R15              Any errors?
         BZ    NOOP                 No
         BAL   R14,FMT000           Display error
         B     U0039                Abend on VSAM error
*
*-- Handle PRINT records.
*
PRTIO    EQU   *
         L     R2,ADCCWA
         CLI   0(R2),X'03'         No-operation CCW? (tag data)
         BE    NOOP                Yes, do not write
*
         SR    R3,R3
         ICM   R3,7,1(R2)          -> data addr in CCW
         LH    R5,6(,R2)           Get length from CCW
         LA    R6,NCB1             -> NCB for outgoing
         USING NCB,R6
*
         MVC   DATAREC(1),0(R2)    Move CCW OP as carriage ctl byte
         MVC   DATAREC+1(132),0(R3)  Move the record data
         LA    R3,DATAREC          Write from this area
         LA    R5,1(,R5)           Bump rec length for added CC byte
         CH    R5,=H'133'          Did that push it over 132?
         BL    *+8                 no
         LA    R5,132              132 is the limit
*
         NSIO  TYPE=PUT,           Write record to spool               X
               NCB=(R6),                                               x
               AREA=(R3),                                              x
               RECLEN=(R5),                                        v210x
               ENTRY=ANJESPL                                       v210
         LTR   R15,R15              Any errors?
         BZ    NOOP                 No
         BAL   R14,FMT000           Display error
         B     U0039                Abend on VSAM error
*
NOOP     EQU   *
         XC    ADACSW(8),ADACSW
         MVI   ADACSW+4,X'0C'      Set CE+DE in CSW
         MVI   ADAECB,X'40'        Post the ECB
         LA    R1,8(,R2)           -> CCW executed + 8
         ST    R1,ADACSW
*
         DROP  R6                  NCB
         DROP  R7                  RSCSADA
         DROP  R8                  IOBSTDRD
*
XITSIO00 EQU   *
         L     R9,4(,R13)          -> DMTXJE save area
         LM    R14,R12,12(R9)      Reload callers regs
         BR    R14                 Return to DMTXJE
*
         LTORG
*                                                                       NJE00290
*-- DSECTS used by NJESIO                                               NJE00290
*                                                                       NJE00290
RSCSADA  DSECT                     RSCS adapter i/o block
ADAECB   DS    F'0'                SYNCH LOCK
ADACUU   DS    XL2'00'             Device address
ADASREQ  DS    AL1(0)              Number of sense bytes
ADATYP   DS    AL1(0)              Device type
ADCCWA   DS    A(0)                ADAPTER CCW ADDR
ADASIOCC EQU   *                   SIO CONDITION CODE
ADACSW   DS    2F'0'               ADAPTER ENDING CSW
ADASENSE DS    F'0'                ADAPTER SENSE BYTE
ADACCW   DS    D                   CCW
ADABUFF  EQU   *                   Buffer start
*                                                                       NJE00290
*                                                                       NJE00290
* OS-Style EXCP ECB condition code notes                                NJE00920
*
* ECB condition code value in ECB byte 0 after EXCP:
*
*- 7F Normal completion: The Read or Write operation has ended
*  with indications of Channel End-Device End and either Unit
*  Exception or Incorrect Length, or toth, if they are normal
*  conditions (for example, Unit Exception indicating end-of-
*  transmission or negative response to polling).
*  should examine the bits in DECFLAGS to determine the
*
*- 41 Complete with I/O error; the program should examine the bits
*  in DECERRST to determine the kind of error.
*
*- 44 The I/O request was rejected, because (1) a device error was
*  detected after the last I/O operation on the device was posted
*  complete or (2) a request-for-test message was received
*  from a local 3270 display station requesting that a test message
*  be sent to another local 3270 device. The buffer contents
*  are unpredictable.
*
*- 48 Enable Command Halted or I/O Operation Purged
*  An I/O operation was purged at Channel End interrupt time
*  as a result of closing the line group while I/O operations
*  were still in progress.
*                                                                       NJE00920
*********************                                                   NJE00920
*                   *                                                   NJE00920
*  N J E S P L      *                                                   NJE00920
*                   *                                                   NJE00920
*  Supports the     *                                                   NJE00920
*  reading of data  *                                                   NJE00920
*  from NETSPOOL    *                                                   NJE00920
*  for outgoing     *                                                   NJE00920
*  links.           *                                                   NJE00920
*                   *                                                   NJE00920
*********************                                                   NJE00920
*                                                                       NJE00920
*-- NJESPL is called by DMTXJE label VMDEBLOK                           NJE00920
*                                                                       NJE00920
*                                                                       NJE00920
NJESPL   CSECT                                                          NJE00020
         B     28(,R15)               BRANCH AROUND EYECATCHERS
         DC    AL1(23)                LENGTH OF EYECATCHERS
         DC    CL9'NJESPL'
         DC    CL9'&SYSDATE'
         DC    CL5'&SYSTIME'
         STM   R14,R12,12(R9)          Save DMTXJE regs                 NJE00050
         LR    R12,R15                 Base                             NJE00060
         USING NJESPL,R12              ADDRESS IT                       NJE00070
         L     R10,0(,R9)              -> NJEWK
         USING NJEWK,R10
*
         ST    R9,NJESPLSA+4
         LA    R13,NJESPLSA
         ST    R13,8(,R9)
         L     R11,ANJECOM          -> common csect
         USING NJECOM,R11
*
* R1 -> RDEVFIOA
*
RD000    EQU   *
         MVC   0(120,R1),BLANKS     Init record area
         MVC   120(120,R1),BLANKS   Init record area
*
         LA    R2,NCB2              -> NCB for file incoming
         USING NCB,R2
         L     R8,NCBTAG            -> TAG data for file
         USING TAG,R8
         MVC   0(2,R1),=H'132'      Assume 132-byte print data
         LA    R3,2(,R1)            -> where to place spool record
*                                   This will put car ctl in byte 2
*
         TM    TAGINDEV,TYPPRT      Are these print records?
         BO    RD110                Yes, all set
*
         MVI   2(R1),X'41'          Else use 41 punch CCW code
         MVC   0(2,R1),=H'80'       And 80-byte punch length
         LA    R3,3(,R1)            -> where to place spool record
*
* read one record from spool and return it to XJE for transmission
*
RD110    EQU   *
         SR    R4,R4                Clear for IC
         ICM   R4,3,0(R1)           Get the record length we're using
*
         NSIO  TYPE=GET,            Read a spool record                X
               NCB=(R2),                                               x
               AREA=(R3),                                              x
               RECLEN=(R4),                                            x
               EODAD=XITSPL04,                                     v210x
               ENTRY=ANJESPL                                       v210
         LTR   R15,R15              Any errors?
         BZ    RD120                No
         BAL   R14,FMT000           Display error
         B     U0039                Abend on VSAM error
*
RD120    EQU   *
         B     XITSPL00
         DROP  R2                   NCB
         DROP  R8                   TAG
*
XITSPL04 EQU   *
         LA    R15,4                Here on end of data; set RC
         B     XITSPL
*
XITSPL00 EQU   *
         SR    R15,R15
*
XITSPL   EQU   *
         L     R9,4(,R13)          -> DMTXJE save area
         ST    R15,16(,R9)
         LM    R14,R12,12(R9)      Reload callers regs
         BR    R14                 Return to DMTXJE
*
         LTORG
*                                                                       NJE00920
*                                                                       NJE00920
*********************                                                   NJE00920
*  N J E W T        *                                                   NJE00920
*                   *                                                   NJE00920
*  Supports the     *                                                   NJE00920
*  WAITREQ vector   *                                                   NJE00920
*                   *                                                   NJE00920
*********************                                                   NJE00920
*                                                                       NJE00920
*                                                                       NJE00920
* This csect is called by:  every place there is a WAITREQ call in      NJE00920
*                           DMTXJE.                                     NJE00920
*                                                                       NJE00920
NJEWT    CSECT                                                          NJE00020
         B     28(,R15)               BRANCH AROUND EYECATCHERS
         DC    AL1(23)                LENGTH OF EYECATCHERS
         DC    CL9'NJEWT'
         DC    CL9'&SYSDATE'
         DC    CL5'&SYSTIME'
         STM   R14,R12,12(R9)          Save DMTXJE regs                 NJE00050
         LR    R12,R15                 Base                             NJE00060
         USING NJEWT,R12               ADDRESS IT                       NJE00070
         L     R10,0(,R9)              -> NJEWK
         USING NJEWK,R10
*
         ST    R9,NJEWTSA+4
         LA    R13,NJEWTSA
         ST    R13,8(,R9)
         L     R11,ANJECOM         -> common csect
         USING NJECOM,R11
*
         LR    R3,R1               Copy ECB or ECBLIST ptr
*
*
WT010    EQU   *                   Here to process RSCS ECBLIST
         XC    XECBLIST(32),XECBLIST  Clear our ECBLIST
         MVC   XECBLIST(4),LINKECBA  Link ECB is always first in list
*
* DMTXJE sets R3 specially, in this way:
* R3-> ECB if the word content pointed to by R3 = 0.
* R3-> ECBLIST if the word content pointed to by R3 ¬= 0.
*
         CLC   1(3,R3),=AL3(0)     Is there an address or an ECB?
         BNE   WT015               Non-zero, it is in ECBLIST form
         CLM   R3,7,AADAECB+1      Is it the addr of ADAECB?
         BNE   *+8                 No, no special action
         LA    R3,XECB             Otherwise use our EXCP ECB instead
         ST    R3,XECBLIST+4       Plug addr of single ECB in list
         OI    XECBLIST+4,X'80'    Mark end of list
         B     WT050               Go check for work
*
WT015    EQU   *
         LA    R0,7                Seven remaining ECBs in list
         LA    R1,XECBLIST+4       -> our ECBLIST (after the first)
         LA    R2,XECB             -> our EXCP ECB
*
WT020    EQU   *
         TM    0(R3),X'40'         Empty RSCS ECBLIST entry?
         BO    WT030               Yes, skip it
         MVC   0(4,R1),0(R3)       Put RSCS ECB ptr in our list
         CLC   1(3,R1),AADAECB+1   Did we just plug the ADAECB addr?
         BNE   *+8                 No, no special action
         STCM  R2,7,1(R1)          Otherwise, use our EXCP ECB instead
         TM    0(R3),X'80'         Was this the last RSCS ECB?
         BO    WT050               Yes, go check for work
         LA    R1,4(,R1)           Next ECBLIST word for MVS
         BCT   R0,WT030            Continue to next
U0048    ABEND 48,DUMP,STEP        Should not occur (more than 8 ecbs)
*
WT030    EQU   *
         LA    R3,4(,R3)           Next ECBLIST word for RSCS
         B     WT020               Keep building ECB list
*
WT040    EQU   *
         WAIT  1,ECBLIST=XECBLIST  Wait on the ECB list
*
*-- Identify the ECB that was posted
*
WT050    EQU   *
         LA    R1,XECBLIST         -> our ECBLIST
WT060    EQU   *
         L     R2,0(,R1)           -> ECB
         TM    0(R2),X'40'         Was this ECB posted?
         BO    WT070               Yes
         TM    0(R1),X'80'         Last ECB addr in list?
         BO    WT065               Yes
         LA    R1,4(,R1)           -> next ECB addr
         B     WT060
*
*-- No ECBs were posted but check for WREs still on Q
*
WT065    EQU   *
         CLC   WREQ,=A(0)          Process WRE Q still has work?
         BE    WT040               Its zero, ok to WAIT
         SPKA  0                   Some WREs are in key 0 stg
         B     WRK000              Go handle the WRE request
*
WT070    EQU   *
         LA    R8,XIOB             -> IOB for last i/o
         USING IOBSTDRD,R8
*
         NJETRACE TYPE=TRCWAIT     Trace wait completion
         STCM  R10,7,1(R14)            Identify trace entry        v212
         ST    R2,4(,R14)          Addr of posted ECB to trace     v212
         MVC   12(4,R14),12(R9)    R14 caller of this wait oper    v212
*
         CLM   R2,7,LINKECBA+1     Was the Link ECB posted?
         BE    COMM000             Yes
         CLM   R2,7,IOBECBPT+1     Was i/o ECB the one posted?
         BNE   XITWT00             No
*
WT080    EQU   *                ** Here to return line i/o status
         MVC   8(1,R14),IOBSTART   Trace SIO status                v212
         MVC   9(1,R14),IOBSENS0   Trace SENSE byte                v212
         MVC   16(8,R14),IOBCSW-1  Move CSW to trace               v212
         L     R2,AADAECB
         USING RSCSADA,R2          Pass back CSW from i/o to DMTXJE
         MVC   ADACSW(8),IOBCSW-1  Pass back CSW
*
         IC    R1,IOBSTART         Get the SIO cond code (bits 2,3)
         SRL   R1,4
         STC   R1,ADACSW           Set SIOCOND for DMTXJE
         NI    ADACSW,X'03'        Keep only the SIOCOND bits
         MVI   ADAECB,X'40'        "post" DMTXJE's line ECB
*
         TM    ADACSW,X'02'        Was there a unit-check?
         BZ    XITWT00             No
         MVC   ADASENSE(1),IOBSENS0 Move single sense byte from IOB
*
         DROP  R2                  RSCSADA
         DROP  R8                  IOBSTDRD
*
XITWT00  EQU   *
         L     R9,4(,R13)          -> DMTXJE save area
         LM    R14,R12,12(R9)      Reload callers regs
         BR    R14                 Return to DMTXJE
*                                                                       NJE00290
*-- WRE(s) have been posted to this link.  Dequeue that chain of WREs   NJE00290
*-- from the WRE-IN Q  (LWREWRIN) and put them on our local process Q.
*                                                                       NJE00290
COMM000  EQU   *
         XC    0(4,R2),0(R2)           Clear ECB that got us here
         L     R2,XJELINK              -> task's LINKTABL entry
         USING LINKTABL,R2
         LM    R4,R5,LWRESWAP          Get WRE anchor, sync count
*
COMM010  EQU   *
         LTR   R4,R4                   Was WRE Q empty?
         BZ    XITWT00                 Yes, nothing else to do
         SR    R14,R14                 Zero out the WRE Q anchor
         LR    R15,R5                  Copy same sync count
         CDS   R4,R14,LWRESWAP         Try to empty the WRE Q
         BC    7,COMM010               Can't yet, try again
         DROP  R2                      LINKTABL
*
*-- R4 -> start of WRE chain we dequeued from WRE Q
*
*-- Find the end of the WRE chain we just dequeued and chain that
*-- last WRE to the start of the existing process chain
*
*   Example (before we do anything below):
*
*   Input WRE chain                Process WRE chain
*    from LWREWRIN                   from WREQ
*   --------------------           ---------------------
*   LWREWRIN -> WRE A              WREQ -> WRE X
*   WRE A -> WRE B                 WRE X -> WRE Y
*   WRE B -> 0                     WRE Y -> 0
*
*
*
*   After COMM020-COMM030 completed:
*
*   Input WRE chain                Process WRE chain
*    from LWREWRIN                   from WREQ
*   --------------------           ---------------------
*   LWREWRIN -> 0                  WREQ -> WRE A
*                                  WRE A -> WRE B
*                                  WRE B -> WRE X
*                                  WRE X -> WRE Y
*                                  WRE Y -> 0
*
*
         LR    R3,R4               Copy ptr to 1st WRE
         USING WRE,R3
*
COMM020  EQU   *
         ICM   R15,15,WRENEXT      -> next WRE
         BZ    COMM030             Found the end
         LR    R3,R15              Make that next one the current
         B     COMM020             Keep looking for the end
*
COMM030  EQU   *
         SPKA  0                   Some WREs are in key 0 stg
         MVC   WRENEXT,WREQ        Add existing process chain to end
         DROP  R3                  WRE
         ST    R4,WREQ             Set new 1st WRE on process Q
*
*
*-- Process a WRE
*-- Find the last WRE on chain and process it first (its the oldest)
*
*
*=== The entire WRK000 routine must run Key=0 ===*
*
*
WRK000   EQU   *
         LA    R2,WREQ-(WRENEXT-WRE) -> 0th WRE on process Q
         L     R3,WREQ             -> 1st WRE on process Q
         USING WRE,R3
*
WRK020   EQU   *
         ICM   R15,15,WRENEXT      -> next WRE
         BZ    WRK030              Found the end
         LR    R2,R3               -> current -1 WRE
         LR    R3,R15              Make that next one the current
         B     WRK020              Keep looking for the end
*
WRK030   EQU   *
         XC    WRENEXT-WRE(,R2),WRENEXT-WRE(R2) Make current -1 as last
*
*-- Now see what kind of WRE it is and act on the request
*
         NJETRACE TYPE=TRCIWRE     Trace incoming WRE
         STCM  R10,7,1(R14)            Identify trace entry        v220
         LA    R15,*               -> here                         v220
         ST    R15,4(,R14)         Save addr of trace request      v220
         ST    R3,8(,R14)          Trace WRE addr                  v220
         MVC   12(4,R14),WRETYPE   Trace type code,len,subpool     v220
         MVC   16(8,R14),WRELINK   link dest                       v220
         MVC   24(8,R14),WREUSER   userid dest                     v220
         NJETRACE TYPE=TRCIWRE     Trace incoming WRE follow on    v220
         OI    0(R14),X'80'        Indicate follow on              v220
         STCM  R10,7,1(R14)            Identify trace entry        v220
         MVC   4(8,R14),WREORIG    Originator userid               v220
         MVC   12(20,R14),WRETXT   Trace WRE content               v220
*
         CLI   WRETYPE,WRENEW      New file queued WRE?
         BE    WRK100
         CLI   WRETYPE,WRECMD      CMD type WRE?
         BE    WRK200
         CLI   WRETYPE,WREMSG      MSG type WRE?
         BE    WRK400
U0044    ABEND 44,DUMP,STEP
*
WRK100   EQU   *
         L     R1,ARDEVECB         -> DMTXJE RDEVSYNC ECB
         POST  (1)                 Tell DMTXJE there is input file
         B     WRK900
*
WRK200   EQU   *
         CLI   WRECODE,X'81'       Drain?
         BE    WRK800              Yes
         CLI   WRECODE,X'B0'       CMD?
         BE    WRK300              Yes
U0043    ABEND 43,DUMP,STEP
*
*-- Build XJE CMDBLOK in XJE CMDRESP area
*
WRK300   EQU   *
         L     R1,ACMDRESP         -> CMD response area
         MVC   0(4,R1),=X'00B00000' Set up CMBBLOK hdr: len,code,0,0
         MVC   4(8,R1),LCLNODE     Respond to this node
         MVC   12(8,R1),WREUSER    response to userid
         MVC   20(8,R1),WRELINK    Destination node of cmd
*
         SR    R5,R5
         IC    R5,WRETXTLN         Get IBM length of cmd text
         EX    R5,CPYTXT           Copy text from WRE
*CPYTXT  MVC   28(0,R1),WRETXT
         LA    R5,4+8+8+8(,R5)     Compute total CMDBLOK IBM len
         STC   R5,0(,R1)           Plug into CMDBLOK
*
         L     R1,ACMDECB          -> DMTXJE CMDECB
         POST  (1)                 Let it know command entered
         B     WRK900
*
CPYTXT   MVC   28(0,R1),WRETXT     executed instr
*
*
*-- Stack a message on a chain for DMTXJE to transmit to a remote
*-- user over a link. (Messages are unstacked by NJEGMQ when DMTXJE
*-- requests that function).
*
*-- NOTE: the building the the msg in STKMSG is a little screwy and
*--       it is because we are trying to conform to what the NMR
*--       build routine in DMTXJE requires. This in DMTXJE-BLDNMRM.
*--       This is pretty gruesome stuff.
*
* On entry:
*
*    R3 -> WRE which contains the message and destination
*
*
WRK400   EQU   *
         LM    R0,R1,RQENUM        Get # RQEs and first addr
         USING RQE,R1
*
WRK420   EQU   *
         CLC   RQEOWN,=A(0)        Look for empty RQE
         BE    WRK430              Got one
         LA    R1,RQESZ(,R1)       -> next RQE
         BCT   R0,WRK420
U0045    ABEND 45,DUMP,STEP
*
WRK430   EQU   *
         L     R2,XJELINK          -> this task's LINKTABL entry
         SR    R0,R0               Look for owner word value of 0
         CS    R0,R2,RQEOWN        Set owner to LINKTABL addr
         BC    4,WRK400            CC=1; owner non-zero, look again
*
         XC    RQEDATA(256),RQEDATA       Init area
         XC    RQEDATA+256(4),RQEDATA+4   Init area
         DROP  R1                  RQE
*
         LR    R4,R1               RQE ptr to R4
         ST    R4,4(,R14)          RQE/STACKMSG ptr to trace       v212
         USING STACKMSG,R4
         MVC   STKNODE,WRELINK     Move node name to respond to
         MVC   STKID,WREUSER       Move user name to respond to
*
         MVC   STKMSG(L'BLANKS),BLANKS  Init 1st part of this area
         MVC   STKMSG(16),=CL16'DMTCMX171I FROM '
         MVC   STKMSG+16(8),LCLNODE Msg is from the local node
         TRT   STKMSG+16(9),BLANK  Look for end of local node id
*
         CLC   WREORIG,=XL8'00'    No originating userid?
         BE    WRK435              No, use MSG170 style
         CLC   WREORIG,BLANKS      No originating userid?
         BE    WRK435              No, use MSG170 style
         MVI   0(R1),C'('          Set opening
         MVC   1(8,R1),WREORIG     Set origin userid of msg
         TRT   1(9,R1),BLANK       Look for end of orig user id
         MVC   0(2,R1),=C'):'      Set closing
         MVC   4(120,R1),WRETXT    Move msg text now
         B     WRK438
*
WRK435   EQU   *
         MVI   STKMSG+8,C'0'       Change to DMTCMX170I
         MVI   0(R1),C':'          Just move a colon
         MVC   4(120,R1),WRETXT    Move msg text now
*
WRK438   EQU   *
         LA    R0,STKNODE          -> node name
         SR    R1,R0               Compute length to msg text start
*
         SR    R15,R15
         IC    R15,WRETXTLN
         LA    R15,8(R1,R15)       Add stack ovhd len to text length
         STC   R15,STKLEN          Store in block
         DROP  R4                  STACKMSG
*
         LA    R2,MSGQ-(STKNEXT-STACKMSG)  -> 0th stacked msg
         USING STACKMSG,R2
*
WRK440   EQU   *
         ICM   R15,15,STKNEXT      -> next stacked message
         BZ    WRK450              Found the end
         LR    R2,R15              stacked msg ptr to R2
         B     WRK440
*
WRK450   EQU   *
         ST    R4,STKNEXT          Add new stacked msg to the end
*
         L     R1,AMSGECB          -> DMTXJE MSGECB
         POST  (1)                 Tell DMTXJE there are stacked msgs
         B     WRK900
*
*-- Drain request on shutdown
*
WRK800   EQU   *
         L     R1,ACMDRESP         -> CMD response area
         MVC   0(DMYCMDL,R1),DMYCMD   Plug a drain command
         L     R1,ACMDECB          -> DMTXJE CMDECB
         POST  (1)                 Let it know command entered
         B     WRK900
*
*-- Done with WRE; release it
*
WRK900   EQU   *                   Release the WRE -> R3
         LA    R0,WRESIZE          Size of this WRE                v220
*
         LR    R1,R3               WRE ptr to R1
         NJETRACE TYPE=TRCFWRE
         STCM  R10,7,1(R14)            Identify trace entry        v212
         LA    R15,*
         STCM  R15,7,5(R14)            Addr of Freemain to trace   v212
         STM   R0,R1,8(R14)            Len, stg addr to trace      v212
*
         SR    R15,R15             Clear for IC                    v220
         IC    R15,WRESP           Get subpool number              v220
         STC   R15,8(,R14)         Trace subspool                  v220
         MVI   WRESP,X'FF'             Mark stg as freed           v220
         DROP  R3                  WRE                             v220
*
         FREEMAIN RU,              Free the WRE                        x
               LV=(0),                                                 x
               A=(1),                                                  x
               SP=(15)                                             v220
*
         SPKA  X'80'                   Back to user key
         B     XITWT00
*
         DS 0F
DMYCMD   DC    AL1(DMYCMDL),X'81',AL2(0)
         DC    CL8'      '         response node (not needed for drain)
         DC    CL8'OP'             response user
         DC    C'DRAIN nodeid   '  dummy model
DMYCMDL  EQU   *-DMYCMD
*
*GPR  1 =  00012B50     Example command CMDBLOK to remote link
*D T12B50.40
*012B50    1FB00000  E9E6F0F2  40404040  40404040     *....ZW02
*012B60    40404040  E6C1C2D5  C5E34040  D840E2E8     *    WABNET  Q SY
*012B70    00000000  00000000  00000000  00000000     *................
*012B80 TO 012B90   SUPPRESSED LINE(S) SAME AS ABOVE .....
*
*
*
*
         LTORG
*                                                                       NJE00290
*                                                                       NJE00920
*********************                                                   NJE00920
*  N J E G P G      *                                                   NJE00920
*                   *              This function simply serves to       NJE00920
*  Supports the     *              obtain a full pages of memory        NJE00920
*  GPAGEREQ vector  *              when DMTXJE requests them            NJE00920
*                   *                                                   NJE00920
*********************                                                   NJE00920
*                                                                       NJE00920
NJEGPG   CSECT                                                          NJE00020
         B     28(,R15)               BRANCH AROUND EYECATCHERS
         DC    AL1(23)                LENGTH OF EYECATCHERS
         DC    CL9'NJEGPG'
         DC    CL9'&SYSDATE'
         DC    CL5'&SYSTIME'
         STM   R14,R12,12(R9)      Save DMTXJE regs                     NJE00050
         LR    R12,R15             Base                                 NJE00060
         USING NJEGPG,R12          ADDRESS IT                           NJE00070
         L     R10,0(,R9)          -> NJEWK
         USING NJEWK,R10
*
         ST    R9,NJEGPGSA+4
         LA    R13,NJEGPGSA
         ST    R13,8(,R9)
         L     R11,ANJECOM         -> common csect
         USING NJECOM,R11
*
         SLL   R0,12               Multiply # pages requested by 4096
         GETMAIN RU,               Get storage                         x
               LV=(0),                                                 x
               BNDRY=PAGE
*
         NJETRACE TYPE=TRCGET
         STCM  R10,7,1(R14)            Identify trace entry        v212
         LA    R15,*
         STCM  R15,7,5(R14)            Addr of Getmain to trace    v212
         STM   R0,R1,8(R14)            Len, stg addr to trace      v212
*
*
XITGPG00 EQU   *
         L     R9,4(,R13)          -> DMTXJE save area
         ST    R1,24(,R9)          Return new page in R1
         LM    R14,R12,12(R9)      Reload callers regs
         BR    R14                 Return to DMTXJE
         LTORG
*                                                                       NJE00290
*                                                                       NJE00920
*********************                                                   NJE00920
*  N J E G M Q      *                                                   NJE00920
*                   *              This function is called by DMTXJE    NJE00920
*  Supports the     *              when it wants to "unstack" messages  NJE00920
*  GMSGREQ vector   *              for transmission to a Node.  Occurs  NJE00920
*                   *              when MSGECB is posted.               NJE00920
*********************                                                   NJE00920
*                                                                       NJE00290
* Messages are placed on this stack by routine ISSUE000 in NJECMX.
* Messages are also placed on this stack by ALQ000 in NJEALQ.  Note
* that messages placed on the stack by ISSUE000 goes on the MSGQ
* chain; these messages are originated and owned by the same link
* task.   Messages placed on the stack by ALQ000 are not placed on
* the message queue chain because of the vagaries of multiple link
* tasks possibly needing to place an entry on the chain simultaneously
* or while this link task is retrieving one from the chain.  Instead
* ALQ000 messages are placed in the stack without using the chain;
* the target link owner address is placed in the RQEOWN (STKOWN) field
* to identify who is to retrieve it, but there is no chain manipulation
* and no conflict by multiple tasks.  Control over who gets what
* available RQE for stacking is controlled by COMPARE AND SWAP in
* ALQ000.
*
NJEGMQ   CSECT                                                          NJE00020
         B     28(,R15)               BRANCH AROUND EYECATCHERS
         DC    AL1(23)                LENGTH OF EYECATCHERS
         DC    CL9'NJEGMQ'
         DC    CL9'&SYSDATE'
         DC    CL5'&SYSTIME'
         STM   R14,R12,12(R9)          Save DMTXJE regs                 NJE00050
         LR    R12,R15                 Base                             NJE00060
         USING NJEGMQ,R12              ADDRESS IT                       NJE00070
         L     R10,0(,R9)              -> NJEWK
         USING NJEWK,R10
*
         ST    R9,NJEGMQSA+4
         LA    R13,NJEGMQSA
         ST    R13,8(,R9)
         L     R11,ANJECOM         -> common csect
         USING NJECOM,R11
*
*-- R1 -> DMTXJE provided area to place the stacked message
*
GMQ000   EQU   *                ** Search the MSGQ chain for msgs
         ICM   R2,15,MSGQ          -> stacked msg Q
         BZ    GMQ100              None stacked, but check for RQE
         USING STACKMSG,R2
         MVC   0(120,R1),STKLEN    Move stacked msg to DMTXJE area
         MVC   MSGQ,STKNEXT        Remove this stacked msg from Q
*
         NJETRACE TYPE=TRCGMQM     Trace GMSGREQ from MSGQ         v212
         STCM  R10,7,1(R14)            Identify trace entry        v212
         ST    R2,4(,R14)          Trace RQE/STACKMSG addr         v212
         MVC   8(24,R14),STKLEN    Trace 24 of stack area          v212
         NJETRACE TYPE=TRCGMQM     Trace GMSGREQ follow-on         v212
         OI    0(R14),X'80'        Indicate follow on              v212
         MVC   1(31,R14),STKLEN+24 Trace more of stacked msg text  v212
*
         XC    STKOWN,STKOWN       This RQE no longer owned        v212
         DROP  R2                  STACKMSG
         B     XITGMQ00            We're done
*
GMQ100   EQU   *                ** Search the RQE area for messages
         LM    R3,R4,RQENUM        Get number and addr of RQEs
         USING RQE,R4
*
GMQ120   EQU   *
         CLC   RQEOWN,XJELINK      Look for RQE that this link owns
         BE    GMQ130              Got one
         LA    R4,RQESZ(,R4)       -> next RQE
         BCT   R3,GMQ120
         B     XITGMQ04            No more messages to unstack
*
GMQ130   EQU   *
         USING STACKMSG,R4
         MVC   0(120,R1),STKLEN    Move stacked msg to DMTXJE area
*
         NJETRACE TYPE=TRCGMQR     Trace GMSGREQ from RQE          v212
         STCM  R10,7,1(R14)            Identify trace entry        v212
         ST    R4,4(,R14)          Trace RQE/STACKMSG addr         v212
         MVC   8(24,R14),STKLEN    Trace 24 of stack area          v212
         NJETRACE TYPE=TRCGMQR     Trace GMSGREQ follow-on         v212
         OI    0(R14),X'80'        Indicate follow on              v212
         MVC   1(31,R14),STKLEN+24 Trace more of stacked msg text  v212
*
         XC    STKNEXT,STKNEXT     Ensure no left over pointers
         XC    STKOWN,STKOWN       This RQE no longer owned
         DROP  R4                  STACKMSG
*
XITGMQ00 EQU   *
         SR    R15,R15             Zero RC = unstacked msg -> R1
         B     XITGMQ
*
XITGMQ04 EQU   *
         LA    R15,4               Non-zero RC = no messages to unstk
*
XITGMQ   EQU   *
         L     R9,4(,R13)          -> DMTXJE save area
         ST    R15,16(,R9)         Return with RC in R15
         LM    R14,R12,12(R9)      Reload callers regs
         BR    R14                 Return to DMTXJE
*                                                                       NJE00290
*                                                                       NJE00920
*********************                                                   NJE00920
*  N J E G L Q      *                                                   NJE00920
*                   *              This function is called by DMTXJE    NJE00920
*  Supports the     *              when it wants to locate a link by    NJE00920
*  GLINKREQ vector  *              name in the LINKTABL.                NJE00920
*                   *                                                   NJE00920
*********************                                                   NJE00920
*                                                                       NJE00290
*  Entry:  R1-> CL8'name of destination link'                           NJE00290
*  Exit:   R1-> LINKTABL entry of destination link, R15=0               NJE00290
*          R15 = 0 if entry found; R15 = 16 if not found.               NJE00290
*                                                                       NJE00290
*                                                                       NJE00290
NJEGLQ   CSECT                                                          NJE00020
         B     28(,R15)               BRANCH AROUND EYECATCHERS
         DC    AL1(23)                LENGTH OF EYECATCHERS
         DC    CL9'NJEGLQ'
         DC    CL9'&SYSDATE'
         DC    CL5'&SYSTIME'
         STM   R14,R12,12(R9)      Save DMTXJE regs                     NJE00050
         LR    R12,R15             Base                                 NJE00060
         USING NJEGLQ,R12          ADDRESS IT                           NJE00070
         L     R10,0(,R9)          -> NJEWK
         USING NJEWK,R10
*
         ST    R9,NJEGLQSA+4
         LA    R13,NJEGLQSA
         ST    R13,8(,R9)
         L     R11,ANJECOM         -> common csect
         USING NJECOM,R11
*
         L     R2,ALINKS           -> LINKS anchor word            v211
         L     R2,0(,R2)           -> first LINKTABL entry         v211
         USING LINKTABL,R2
         ICM   R2,15,LNEXT         Skip over local entry           v211
         BZ    GLQ080              Doesnt exist                    v211
*
GLQ000   EQU   *
         CLC   0(8,R1),LINKID      Look for destination link
         BE    GLQ090              Found it
         ICM   R2,15,LNEXT         -> next LINKTABL entry
         BNZ   GLQ000              Keep searching
*
GLQ080   EQU   *                                                   v211
         LA    R15,16              No matching entry found
         B     XITGLQ              And exit w/ original R1 intact
*
GLQ090   EQU   *
         LR    R1,R2               -> LINKTABL entry to return
         SR    R15,R15             RC=0, entry was found
*
XITGLQ   EQU   *
         NJETRACE TYPE=TRCGLQ      Trace GLINKREQ
         STCM  R10,7,1(R14)            Identify trace entry        v212
         ST    R15,4(,R14)         Trace resulting RC              v212
         MVC   8(8,R14),0(R1)      Trace LINKID
*
         L     R9,4(,R13)          -> DMTXJE save area
         ST    R1,24(,R9)          Return A(linktabl entry) in R1
         ST    R15,16(,R9)         Set R15 RC to caller
         LM    R14,R12,12(R9)      Reload callers regs
         BR    R14                 Return to DMTXJE
*
         DROP  R2
         LTORG
*                                                                       NJE00290
*                                                                       NJE00920
*********************                                                   NJE00920
*  N J E G R Q      *                                                   NJE00920
*                   *              This function is called by DMTXJE    NJE00920
*  Supports the     *              when it wants to locate a node       NJE00920
*  GROUTREQ vector  *              name in the routing table.           NJE00920
*                   *                                                   NJE00920
*********************                                                   NJE00920
*                                                                       NJE00290
NJEGRQ   CSECT                                                          NJE00020
         B     28(,R15)               BRANCH AROUND EYECATCHERS
         DC    AL1(23)                LENGTH OF EYECATCHERS
         DC    CL9'NJEGRQ'
         DC    CL9'&SYSDATE'
         DC    CL5'&SYSTIME'
         STM   R14,R12,12(R9)          Save DMTXJE regs                 NJE00050
         LR    R12,R15                 Base                             NJE00060
         USING NJEGRQ,R12              ADDRESS IT                       NJE00070
         L     R10,0(,R9)              -> NJEWK
         USING NJEWK,R10
*
         ST    R9,NJEGRQSA+4
         LA    R13,NJEGRQSA
         ST    R13,8(,R9)
         L     R11,ANJECOM         -> common csect
         USING NJECOM,R11
*
*-- R1 -> Requested route name
*
*
*-- First determine if the route name we are looking up is actuallyv211
*-- a link name.                                                   v211
*
RLNK000  EQU   *
         L     R2,ALINKS           -> LINKS anchor word            v211
         L     R2,0(,R2)           1st entry (LOCAL entry)         v211
         USING LINKTABL,R2
         L     R2,LNEXT            Skip over local entry           v211
         SR    R0,R0               R0=0 assume name not a link     v211
*
RLNK010  EQU   *                                                   v211
         CLC   LINKID,0(R1)        Find the link entry by name     v211
         BE    RLNK020             Got it                          v211
         ICM   R2,15,LNEXT         -> next LINKTABL entry          v211
         BNZ   RLNK010             Keep looking                    v211
         B     RLNK030             Didn't find a matching link     v211
         DROP  R2                  LINKTABL                        v211
*
*-- Here if route we want is a link name too (dont use wildcards)  v211
*
RLNK020  EQU   *                                                   v211
         BCTR  R0,0                Indic route is explicit link nm v211
*                                                                  v211
*-- Search the RTEs for the route name                             v211
*                                                                  v211
RLNK030  EQU   *
         L     R2,AROUTES          -> ROUTES anchor word           v211
         ICM   R2,15,0(R2)         -> RTE list                     v211
         BZ    XITGRQ04            If 0, no routes found
         USING RTE,R2                                              v211
*
RLNK040  EQU   *
         LA    R4,ROUTNAME         -> name from route list         v211
         LA    R5,8                max length                      v211
         LR    R6,R1               -> selected name to locate      v211
         LR    R7,R5               copy length                     v211
         CLCL  R4,R6               Did we locate the name?         v211
         BE    RTE400              Yes                             v211
         LTR   R0,R0               Must be explicit link name?     v211
         BNZ   RLNK050             Yes, no wildcard checking       v211
         CLI   0(R4),C'*'          Wildcard was in the name?       v211
         BE    RTE400              Then we matched to that point   v211
*
RLNK050  EQU   *                                                   v211
         ICM   R2,15,ROUTPTR       -> next RTE                     v211
         BNZ   RLNK040             Keep looking                    v211
         B     XITGRQ04            Error if not found
*
RTE400   EQU   *
         LA    R0,4                # possible routed-to names      v211
         LA    R3,ROUTNEXT         -> first possible name          v211
*
RTE410   EQU   *                                                   v211
         L     R4,ALINKS           -> LINKS anchor word            v211
         L     R4,0(,R4)           -> first LINKTABL entry         v211
         USING LINKTABL,R4                                         v211
         ICM   R4,15,LNEXT         Skip over local entry           v211
         BZ    XITGRQ04            Let DMTXJE fail the request     v211
*
RTE420   EQU   *                                                   v211
         CLC   0(8,R3),BLANKS      No route-to name?               v211
         BE    XITGRQ04            Fail the request                v211
         CLC   0(8,R3),LINKID      Look for destination link       v211
         BE    RTE440              Found it                        v211
         ICM   R4,15,LNEXT         -> next LINKTABL entry          v211
         BNZ   RTE420              Keep searching                  v211
*
RTE430   EQU   *                                                   v211
         LA    R3,8(,R3)           Next alternate route-to         v211
         BCT   R0,RTE410           Rescan for matching link        v211
         B     XITGRQ04            None found, fail the request    v211
*
RTE440   EQU   *                                                   v211
         TM    LFLAG,LCONNECT      Is the link active?             v211
         BZ    RTE430              N, try next route-to link       v211
         LR    R1,R3               Return selected link in R1      v211
         DROP  R4                  LINKTABL                        v211
*
XITGRQ00 EQU   *
         SR    R15,R15             Zero RC = final link name -> R1
         B     XITGRQ
*
XITGRQ04 EQU   *
         LA    R15,4               Non-zero RC = no matching route
*
XITGRQ   EQU   *
         NJETRACE TYPE=TRCGRQ      Trace GROUTREQ
         STCM  R10,7,1(R14)            Identify trace entry        v212
         ST    R15,4(,R14)         Trace resulting RC              v212
         MVC   8(8,R14),0(R1)      Trace LINKID
*
         L     R9,4(,R13)          -> DMTXJE save area
         ST    R15,16(,R9)         Return with RC in R15
         ST    R1,24(,R9)          Return -> route entry in r1
         LM    R14,R12,12(R9)      Reload callers regs
         BR    R14                 Return to DMTXJE
*                                                                       NJE00290
         LTORG
*                                                                       NJE00290
*                                                                       NJE00920
*********************                                                   NJE00920
*  N J E A L Q      *                                                   NJE00920
*                   *              This function is called by DMTXJE    NJE00920
*  Supports the     *              when it wants to post a msg or       NJE00920
*  ALERTREQ vector  *              cmd to another link.                 NJE00920
*                   *                                                   NJE00920
*********************                                                   NJE00920
*                                                                       NJE00290
NJEALQ   CSECT                                                          NJE00020
         B     28(,R15)               BRANCH AROUND EYECATCHERS
         DC    AL1(23)                LENGTH OF EYECATCHERS
         DC    CL9'NJEALQ'
         DC    CL9'&SYSDATE'
         DC    CL5'&SYSTIME'
         STM   R14,R12,12(R9)          Save DMTXJE regs                 NJE00050
         LR    R12,R15                 Base                             NJE00060
         USING NJEALQ,R12              ADDRESS IT                       NJE00070
         L     R10,0(,R9)              -> NJEWK
         USING NJEWK,R10
*
         ST    R9,NJEALQSA+4
         LA    R13,NJEALQSA
         ST    R13,8(,R9)
         L     R11,ANJECOM         -> common csect
         USING NJECOM,R11
         LR    R7,R1               Copy msg ptr to R7
*
*-- R7 -> Message NMR
*-- R0 =  Task name (RSCS format) of link to alert
*
         L     R2,ALINKS           -> LINKS anchor word            v211
         L     R2,0(,R2)           -> first LINKTABL entry         v211
         USING LINKTABL,R2
         ICM   R2,15,LNEXT         -> next LINKTABL entry          v211
         BZ    XITALQ04            Doesnt exist                    v211
*
ALQ000   EQU   *
         CL    R0,LTCBA            Look for target task id
         BE    ALQ020              Found it
         ICM   R2,15,LNEXT         -> next LINKTABL entry
         BNZ   ALQ000              Keep searching
         B     XITALQ04            Not found, exit with RC
*
ALQ020   EQU   *
         SR    R15,R15             RC=0, entry was found
         L     R5,LNJEW            -> work area of target task
*
*-- Stack a message in an RQE for DMTXJE to transmit to a remote
*-- user over a link. (Messages are unstacked by NJEGMQ when DMTXJE
*-- requests that function).
*
*
*
ALQ100   EQU   *
*
ALQ110   EQU   *
         LM    R0,R1,RQENUM        Get number and addr of RQEs
         USING RQE,R1
*
ALQ120   EQU   *
         CLC   RQEOWN,=A(0)        Look for empty RQE
         BE    ALQ130              Got one
         LA    R1,RQESZ(,R1)       -> next RQE
         BCT   R0,ALQ120
U0045A   ABEND 45,DUMP,STEP        RQEs exhausted
*
*                                  R2 -> target task's LINKTABL entry
ALQ130   EQU   *
         SR    R0,R0               Clear compare value             v213
         SR    R15,R15             Set up for -1                   v213
         BCTR  R15,0               Make -1                         v213
         CS    R0,R15,RQEOWN       Reserve the RQE with -1 owner   v213
         BC    4,ALQ110            CC=1; owner non-zero, look again
*
         XC    RQEDATA(256),RQEDATA       Init area
         XC    RQEDATA+256(4),RQEDATA+256 Init area                v213
*
*-- When stacking a command or msg destined for another outgoing link,
*-- the stacking process as done by RSCS PMSGREQ in DMTCOM lops off
*-- the first two bytes of the data (a length byte and a X'B2') and
*-- then moves the data to be stacked started with byte 2. It then
*-- recalculates the new length as two bytes less, and further
*-- adjusts the length down by one more byte as it makes the length
*-- into IBM format.  The code just below with register 0 performs
*-- this same operation, for ALERTREQ stacking only.
*
         USING STACKMSG,R1
*
         SR    R0,R0               Clear for IC
         IC    R0,0(,R7)           Get original length from tank
         MVC   STKLEN(256),2(R7)   Move tank data, skipping 1st 2 bytes
         S     R0,=F'3'            Reduce length for 2 bytes skipped
*                                   -1 more to make IBM length
         STC   R0,STKLEN           Plug new command stack length
         ST    R2,STKOWN           Now set true LINKTABL owner     v213
*
         NJETRACE TYPE=TRCALQ      Trace alert task
         STCM  R10,7,1(R14)            Identify trace entry        v212
         ST    R1,4(,R14)          Trace RQE/STACKMSG address      v212
         MVC   8(24,R14),STKLEN    Trace 1st 24 of stack data area v212
         DROP  R1                  STACKMSG
*
XITALQ00 EQU   *
         L     R1,AMSGECB-NJEWK(,R5) -> DMTXJE MSGECB
         POST  (1)                 Tell DMTXJE there are stacked msgs
*
         SR    R15,R15             Zero RC = unstacked msg -> R1
         B     XITALQ
*
XITALQ04 EQU   *
         LA    R15,4               Non-zero RC = no task found
*
XITALQ   EQU   *
         L     R9,4(,R13)          -> DMTXJE save area
         ST    R15,16(,R9)         Return with RC in R15
         LM    R14,R12,12(R9)      Reload callers regs
         BR    R14                 Return to DMTXJE
*                                                                       NJE00290
         LTORG
*                                                                       NJE00290
*                                                                       NJE00920
*********************              This function is called by DMTXJE    NJE00920
*  N J E T O D      *              when it wants to convert the TOD     NJE00920
*                   *              format.  It does not use standard    NJE00920
*  Supports the     *              linkage and is called directly by    NJE00920
*  GTODEBCD vector  *              DMTXJE and it references no non-     NJE00920
*                   *              DMTXJE fields.                       NJE00920
*********************                                                   NJE00920
*                                                                       NJE00290
NJETOD   CSECT                                                          NJE00020
         B     28(,R15)               BRANCH AROUND EYECATCHERS
         DC    AL1(23)                LENGTH OF EYECATCHERS
         DC    CL9'NJETOD'
         DC    CL9'&SYSDATE'
         DC    CL5'&SYSTIME'
         USING NJETOD,R15              ADDRESS IT                       NJE00070
*                                                                       NJE00290
*.
*
* ENTRY NAME -
*
*        GTODEBCD
*
* FUNCTION -
*
*        CONVERT A S/370 FORMAT TOD TO EBCDIC DATE AND TIME.
*
* CALLS TO OTHER ROUTINES -
*
*        NONE
*
* OPERATION -
*
*        1. CONVERT TIME AND DATE AND EDIT INTO USER
*           SUPPLIED FIELD.
*
*        2. OBTAIN DAY OF THE WEEK AND TIME ZONE
*           AND MOVE INTO USER SUPPLIED FIELD
*
* ENTRY -
*
*                  R0, R1=S/370 FORMAT TOD TO BE CONVERTED
*                  R2=ADDRESS OF A FIELD INTO WHICH THE OUTPUT
*                       IS TO BE EDITED BY MEANS OF AN EDIT INSTR.
*                      (THIS FIELD MUST START WITH A BYTE SET TO
*                       ONE LESS THAN THE TOTAL LENGTH OF THE FIELD,
*                       WHICH SHOLUD CONTAIN AN EDITING MASK, INTO
*                       WHICH THE RESULT IS TO BE PLACED.
*                       BLANKS ARE MOVED INTO THE SIX BYTE FIELD
*                       IMMEDIATELY FOLLOWING THE SPECIFIED
*                       OUTPUT EDITING FIELD.)
*
*                  R13= ADDRESS OF AN  21 FW FIELD OF THE FOLLOWING
*                          INITIAL FORMAT:
*
*              DC       3D'0' FOR DATE AND TIME DECIMAL CONVERSION
*              DC       A(0)  FIELD TO RECEIVE CONVERTED DAY OF THE WK
*              DC       F'-1' TO HOLD LAST CALCULATION ELAPSED HOURS
*              DC       A(0+4) SW USED AS AN INDEX, FOR STD VS DLT
*              DC       A(TIMEZON+4) ADDR OF TIMEZON TABLE IN CALLERS
*                                    STORAGE
*              DC       11F'0' SAVE AREA
*
*    NOTE:  THIS AREA SHOULD NOT BE MODIFIED AFTER THE INITIAL CALL
*
* EXIT -
*
*                  DATE, TIME, AND TIME ZONE HAVE BEEN GENERATED AND
*                  AND MOVED TO THE SPECIFIED OUTPUT AREA.
*
         EJECT
*
* RESPONSES -
*
*        NONE
*
* ERROR MESSAGES -
*
*        NONE
*
*.
*
*ODEBCD  DC    0H'0'
*        USING *,R15               GET ADDRESSABILITY
         USING TODDSECT,R13        GET COMMON AREA ADDRESSABILITY
         STM   R0,R10,TODSAVE+4*R0 SAVE REGISTERS TO BE MODIFIED
*
TODRETRY EQU   *
         SRDL  R0,12               RIGHT JUST TIME OF DAY MICROSECONDS
         LM    R3,R5,TODEBCON      LOAD KEY VALUES FROM LAST COMP
         LA    R10,0(R4,R5)        R10=ADDR OF APPROPRIATE TIMEZONE ENT
         SLR   R6,R6               CLEAR R6 FOR RETURN FIELD LENGTH
         IC    R6,0(R2)            R6=LENGTH OF CALLER'S EDIT MASK
         LA    R2,1(R6,R2)         R2=ADDR OF RETURN FIELD FOR TIMEZONE
         MVC   0(6,R2),2(R10)      GIVE CALLER TIMEZONE NAME IN EBCDIC
         D     R0,F60MEG           370 TOD BY 60,000,000(NO. USEC/MIN)
         LR    R10,R0              R10=ODD MICROSECONDS LESS THAN A MIN
         SLR   R0,R0               CLEAR R0 FOR MORE DIVIDING
         AH    R1,0(R4,R5)         ADJUST TIMEZONE DIFFERENCE FROM GMT
         D     R0,F60              DIVIDE MINUTES BY 60 TO GET HOURS
         LR    R9,R0               R9=ODD MINUTES LESS THAN AN HOUR
         CLR   R1,R3               HOUR SAME AS FOR THE LAST CONV?
         BNE   NEWHOUR             NOPE-GOTTA GO DO A COMPLETE COMP
*
TODFINIS EQU   *
         LR    R1,R10              R1=ODD MICROSECONDS LESS THAN A MIN
         SLR   R0,R0               CLEAR R0 FOR DIVIDE
         D     R0,F10              R1=SECONDS TO FIVE DECIMAL PLACES
         M     R8,F10MEG           SHIFT MINUTES LEFT SEVEN PLACES DEC
         ALR   R9,R1               SET SEC AND FRACTION TO RIGHT OF MIN
         CVD   R9,MMSSMMMM         FIELD=DECIMAL '000000MMSSMMMMMZ'
         IC    R0,MMSSMMMM+3       SAVE DECIMAL MINUTES THROUGH MVO
         MVO   MMSSMMMM-2(6),MMDDYYHH+3(5) APPEND DATE AND HOUR
         STC   R0,MMSSMMMM+3       RESTORE MINUTES CLOBBERED BY ZONE
         L     R2,TODSAVE+4*R2     RESTORE CALLER'S R2
         IC    R1,0(R2)            R1=LENGTH OF CALLER'S EDIT MASK
         MVI   0(R2),C' '          SET FILL CHARACTER OF MASK TO A BLNK
         EX    R1,TODEDIT          EDIT OUTPUT INTO CALLER'S FIELD
         LM    R0,R10,TODSAVE+4*R0 RESTORE MODIFIED CALLER'S REGS
         L     R15,DAYNUMBR        SET RETURN DAY OF WEEK 0 -> 6 IN R15
         BR    R14                 AND RETURN TO THE CALLER
*
TODEDIT  ED    0(0,R2),MMSSMMMM-1  EDIT TO BE EXECUTED BY ABOVE CODE
*
NEWHOUR  EQU   *
         ST    R1,TODEBCON         SAVE HOUR COMPUTATION FOR NEXT CALL
         SLR   R0,R0               CLEAR R0 FOR MORE DIVIDING
         D     R0,F24              DIV HRS BY 24 TO GET DAYS AND ODD HR
         LR    R8,R0               R8=ODD HOURS LESS THAN ONE DAY
*
FIRSTDAY EQU   1                   - JANUARY 1, 1900, WAS A MONDAY
*
         LA    R3,FIRSTDAY(R1)     R3=DAY COUNT SINCE SUNDAY LONG PAST
         SLR   R2,R2               CLEAR R2 FOR DIVIDE TO FOLLOW
         D     R2,F7               R2=CURRENT WEEKDAY NUMBER 0 -> 6
         ST    R2,DAYNUMBR         SAVE WEEKDAY FOR LATER REF AND RET
*
         SLR   R7,R7               ASSUME NO LEAPYEAR FOR NOW
         S     R1,F365             SUBTRACT THE DAYS IN 1900
         BM    YEAR1900            DEAL WITH SPEC PROB IF YEAR IS 1900
         SLR   R0,R0               CLEAR R0 FOR YET MORE DIVIDING
         D     R0,F1461            DIV DYS BY DYS IN 4 YEARS((4*365)+1)
         SLL   R1,2                MULT QUOTIENT BY FOUR TO GET YEARS
         LA    R5,1(R1)            R5=YEARS LESS ODD YEARS NORM TO 1900
         LR    R3,R0               R3=REMAINING DAYS
         SLR   R2,R2               CLEAR R2 FOR IMPENDING DIVIDE
         D     R2,F365             GET NUM OF ODD YRS AND ODD DYS LEFT
         CL    R3,F3               CHECK FOR PRESENCE OF LEAPYEAR
         BL    YEARSET             GO FIN YEAR NUMBER IF NOT LEAPYEAR
         LA    R7,1                ADJUST EXTRA DAY REG FOR LEAPYEAR
         BE    YEARSET             COMP YEAR NUM IF NO SPECIAL PROB
         BCTR  R3,0                OTHERWISE SET ODD YEAR REG BACK TO 3
         LA    R2,365              SET DY OF YR TO LAST DAY OF LEAPYEAR
*
YEARSET  EQU   *
         ALR   R5,R3               ADD ODD YRS TO FORM EXACT YEAR IN R5
*
DATECALC EQU   *
         LA    R2,1(R2)            BUMP DATE TO STA AT ONE RATH THAN 0
         LA    R1,59(R7)           R1=60 IF LEAPYEAR, 59 IF NOT
         CLR   R2,R1               IS THE DATE PAST FEBRUARY?
         BNH   WINTER              NOPE - LET THE DATE STAND AS IT IS
         LA    R2,2(R2)            SET FOR NON LEAPYEAR INITIALLY...
         SLR   R2,R7               DEC BY ONE IF DATE IS OF A LEAPYEAR
*
WINTER   EQU   *
         LA    R3,91(R2)           R3=DATE OF YEAR + 91
         LR    R7,R3               R7=SAME THING
         M     R2,F2145            MAGIC NUMBER - NO INTUITIVE EXPL
         SRL   R3,16               DIV BY 65536 TO GET MONTH NUMBER + 2
         LR    R6,R3               R6=NUMBER OF MONTH + 2
         BCTR  R6,0                R6=NUMBER OF MONTH + 1
         BCTR  R6,0                R6=NUMBER OF MONTH EXACTLY
         M     R2,F1955            MULTIPLY BY ANOTHER MAGIC NUMBER
         SRL   R3,6                DIV BY 64 GET TOT DYS IN PAST MON+91
         SLR   R7,R3               R7=EXACT DATE OF MONTH
         LA    R0,4                SET TIME TYPE FLAG TO DIFF TABLE DIS
         LCR   R0,R0               SET FLAG TO STAN TIME (-4) INITIALLY
         CL    R6,FW4              COMPARE MONTH NUMBER TO APRIL NUMBER
         BL    FLAGCHEK            FLAG IS CORRECT GO LOOK AT CALC FLAG
         LA    R1,0                INIT MON INDICATOR INCASE OF BRANCH
         BE    DETAILS             DO A CLOSE INSP IF DATE IS IN APRIL
         CL    R6,F10              AFTER APRIL-COMPARE MONTH TO OCT
         BH    FLAGCHEK            DATE IS AFT OCT-STANDARD TIME SET OK
         LA    R0,4                OTHERWISE RESET FLAG TO DAYLITE TIME
         BL    FLAGCHEK            FLAG SET PROP IF AFT APR BEFORE OCT
         LA    R1,1                MUST CHECK CLOSELY - SET OCT IND
*
DETAILS  EQU   *
         LA    R2,30(R1)           R2=DAYS IN MONTH - APRIL OR OCTOBER
         LA    R4,7(R7)            R4=COMPUTED DATE OF MONTH + 7
         SR    R4,R2               R4=NUM OF DAYS PAST IN LAST WK OF MO
         BM    FLAGCHEK            DATE COMP IS PRIOR TO STA OF LAST WK
         CL    R4,DAYNUMBR         WILL SUNDAY OCCUR BETWEEN
*                                  TOMORROW AND THE END OF THE MONTH?
         BNH   FLAGCHEK            YES - TIME FLAG IS SET PROPERLY
         CLI   DAYNUMBR+3,X'00'    IS COMPUTED DATE SUNDAY, PERHAPS?
         BNE   INVERT              NOPE-AFTER SUN-INVERT FLAG AND CONT
         L     R4,TODEBCON+4       R4=FLAG USED IN PRIOR COMPUTATION
         SRA   R4,4                R4=-1 IF STAN USD; 0 IF DAYLITE USD
         LCR   R1,R1               R1=0 IF MONTH APR;  -1 IF MONTH OCT
         LA    R2,3(R1,R4)         R2=HOUR CHANGE COMP: 1, 2, OR 3
         CLR   R8,R2               IS COMPUTED TIME BEFORE TIME CHANGE?
         BNH   FLAGCHEK       YES - FLAG HAS BEEN PROPERLY SET @VA07031
*
INVERT   EQU   *
         LCR   R0,R0               INVERT TIME FLAG TO PROPER SETTING
*
FLAGCHEK EQU   *
         CL    R0,TODEBCON+4      NOW - DID WE USE THE RIGHT TIME TYPE?
         BNE   SETRETRY           NO-MUST DO THE WHOLE COMP OVER AGAIN
*
         LA    R2,100              SET DIVISOR FOR DEC MANIPULATIONS
         LR    R1,R6               R1=HEXADECIMAL MONTH NUMBER
         MR    R0,R2               SHIFT MONTH LEFT TWO PLACES DECIMAL
         ALR   R1,R7               SET DAY NUMBER INTO ACCUMULATION
         MR    R0,R2               SHIFT MMDD LEFT TWO PLACES DECIMAL
         SLR   R4,R4               CLEAR R4 FOR R5 YEAR DIVIDE
         DR    R4,R2               R4=YEAR NUMBER MODULO CENTURY
         ALR   R1,R4               SET TRUNCATED YEAR NUM INTO ACCUM
         MR    R0,R2               SHIFT MMDDYY LEFT TWO PLACES DECIMAL
         ALR   R1,R8               SET HOUR NUMBER INTO ACCUMULATION
         CVD   R1,MMDDYYHH         FIELD=DECIMAL '0000000MMDDYYHHZ'
         B     TODFINIS            GO BACK TO MAINLINE CODE TO FIN UP
*
YEAR1900 EQU   *
         LA    R2,365(R1)          UNDO DAMAGE TO DATE OF YEAR
         SLR   R5,R5               SET YEAR NUMBER TO ZERO
         B     DATECALC            AND GO CALCULATE THE DATE OF YEAR
*
SETRETRY EQU   *
         SLR   R1,R1               SET R1 TO ZERO AND...
         BCTR  R1,0                DECREMENT TO SET R1 TO -1
         ST    R1,TODEBCON         DUM UP LAST HR VAL TO FORCE RECAL
         ST    R0,TODEBCON+4       SET PROP TIME TYPE FLAG FOR NEXT TRY
         LM    R0,R2,TODSAVE+4*R0  RESTORE CALLER'S INPUT REGISTERS
         B     TODRETRY            AND START FROM THE TOP AGAIN
*
F60MEG   DC    F'60000000'
F60      DC    F'60'
F10      DC    F'10'
F10MEG   DC    F'10000000'
F24      DC    F'24'
F7       DC    F'7'
F365     DC    F'365'
F1461    DC    F'1461'
F3       DC    F'3'
F2145    DC    F'2145'
F1955    DC    F'1955'
FW4      DC    F'4'
         LTORG
*
TODDSECT DSECT
MMDDYYHH DS    1D                  TO HOLD NEW HOUR CALCULATION IN DEC
         DS    1D                  FOR APPENDING MMDDYYHH TO MMSSMMMM
MMSSMMMM DS    1D                  TO RECEIVE DECIMAL MINUTE AND SECOND
DAYNUMBR DS    1A                  TO RECEIVE COMPUTED DAY OF WEEK 0->6
TODEBCON DS    1F,2A               SEE BELOW
*        DC    F'-1'               TO HOLD LAST CALC ELAPSED HRS
*        DC    A(0+4) SWITCH, USED AS AN INDEX, FOR STD VS. DLT TIME
*        DC    A(TIMEZON+4)        EXT ADDR OF TIMEZONE DISP TAB
TODSAVE  DC    11F'0'              TODEBCD ROUTINE SAVE AREA
*                                                                       NJE00290
*                                                                       NJE00290
****  Main work area common                                             NJE00290
****  to all NJExxx CSECTs.                                             NJE00290
*                                                                       NJE00290
NJEWK    DSECT
NJEEYE   DS    CL4'NJEW'           Eyecatcher
NJEWKLEN DS    F                   Getmain size of this area
XJENODE  DS    CL8                 Link node name
ANJECOM  DS    A                   -> NJECOM common csect               NJE00320
AMSGWK   DS    A                   -> MSGWK storage                     NJE00320
*
DBLE     DS    D                   Work area                            NJE00310
TWRK     DS    2D                  Work area
INTDD    DS    CL8                 DDNAME of INTRDR allocation
*
         NJEPARMS                  Passed parameter list           v220
*
*
*-- This area is filled by DMTXJE right after initial entry
XJEWORDS DS    0XL20               Addr list from DMTXJE
AMSGECB  DS    A                    Addr of DMTXJE's MSGECB
ACMDECB  DS    A                    Addr of DMTXJE's CMDECB
ACMDRESP DS    A                    Addr of DMTXJE's CMDRESP area
AADAECB  DS    A                    Addr of DMTXJE's ADAECB
ARDEVECB DS    A                    Addr of DMTXJE's RDEVSYNC
*--end of passed area
*
*
XJESTOR  DS    A                   -> two page DMTXJE stg area
WREQ     DS    A                   -> Process WRE chain for this task
XECB     DS    F                   ECB for EXCP use
XIOB     DS    XL48                Area for EXCP IOB
PUNIOB   DS    XL48                PUNCH pseudo IOB
MACLIST  DS    XL100               Macro expansion area
LINKECBA DS    A                   -> Link task communications ECB
XECBLIST DS    8A                  OS ECBLIST of RSCS-style ECBLIST
*
*
NCB1     DS    XL48                NETSPOOL NCB for outgoing files
NCB2     DS    XL48                NETSPOOL NCB for incoming files
LINE1    DS    (DMYLINEL)X         DCB
INTRDR   DS    (DMYIRDRL)X         DCB
WTOD     DS    (WTODL)X
*
SVR14    DS    A                      R14 save area
SVR14R   DS    A                      R14 save area                v220
SVR14M   DS    A                      R14 save area                v220
DYNR14   DS    A                      R14 SAVE AREA
LS99PTR  DS    A                      PTR TO S99RB
LS99RB   DS    XL20                   SPACE FOR S99RB
*
TXT1     DS    0XL14,Y,AL2,AL2        SPACE FOR THE DDNAME TEXT UNIT
DDNAME   DS    CL8                     DDNAME RETURNED
*
TXT2     DS    0XL07,Y,AL2,AL2,C      SYSOUT=(A,
TXT3     DS    0XL12,Y,AL2,AL2,CL6         INTRDR)
TXT4     DS    0XL04,Y,AL2            FREE=CLOSE
*
TXT12    DS    0XL09,Y,AL2,AL2        UNIT NAME text unit
UNITCUU  DS    CL3                     UNIT NAME
*
NJFL1    DS    X                   Flag bits
NJF1VSER EQU   X'02'   ..... ..1.   VSAM error
*
LASTRC   DS    X                   RC on VSAM error
LASTERR  DS    X                   ERRCD on VSAM error
*
DATAREC  DS    CL133               Data record area
*
TDATA    DS    108X
*
NJESA    DS    18F                     NJEDRV  OS save area             NJE00300
NJEREQSA DS    18F                     NJEREQ  OS save area             NJE00300
NJEAXSSA DS    18F                     NJEAXS  OS save area             NJE00300
NJESIOSA DS    18F                     NJESIO  OS save area             NJE00300
NJEWTSA  DS    18F                     NJEWT   OS save area             NJE00300
NJESPLSA DS    18F                     NJESPL  OS save area             NJE00300
NJEGPGSA DS    18F                     NJEGPG  OS save area             NJE00300
NJEGMQSA DS    18F                     NJEGMQ  OS save area             NJE00300
NJEGLQSA DS    18F                     NJEGLQ  OS save area             NJE00300
NJEGRQSA DS    18F                     NJEGRQ  OS save area             NJE00300
NJEALQSA DS    18F                     NJEALQ  OS save area             NJE00300
BALRSAVE DS    16F                     Local rtns register save         NJE00300
*
         DS    0D                      Force doubleword size
NJEWKSZ  EQU   *-NJEWK
*                                                                       NJE00930
*
*-- System DSECTs
*
         IEZIOB
         CVT   DSECT=YES,PREFIX=NO
         IHAPSA
         IKJTCB
         IHAASVT
         IHAASCB
IEZCOM   DSECT
         IEZCOM                        Comm area
IEZCIB   IEZCIB                        CIB
*
CSCB     DSECT
         IEECHAIN                      CSCB
         IEESMCA
         IEFZB4D0
         IEFZB4D2
         DCBD  DSORG=PS,DEVD=DA
*
         COPY LINKTABL                                                  NJE00940
         COPY RTE                                                       NJE00940
         COPY AUTHLIST                                                  NJE00940
         COPY TAG                                                       NJE00940
         COPY NETSPOOL                                                  NJE00940
*
*-- NJE38 DSECTs
*
         NJERUSER                                                  v220
         NJEWRE                                                    v220
         NJETRACE TYPE=DSECT                                       v220
*
         END   NJEDRV                                                   NJE01000
./ ADD NAME=NJEFMT
*
*
*-- NJE38 - NETSPOOL Formatter
*
*
*   This program formats the NETSPOOL dataset.
*
*
*
*
         REGEQU
NJEFMT   CSECT
         NJEVER
         STM   R14,R12,12(R13)         SAVE CMS REGS
         LR    R12,R15                 BASE
         USING NJEFMT,R12              ADDRESS IT
*
         GETMAIN RU,                   GET LOCAL STG AREA              X
               LV=NJEFSZ
         LR    R10,R1
         LR    R1,R0                   COPY LENGTH
         LR    R2,R0                   COPY LENGTH
         LR    R0,R10                  -> NEW STG AREA
         SR    R15,R15                 SET PAD
         MVCL  R0,R14                  CLEAR THE PAGE
*
         USING NJEFWK,R10
         ST    R13,NJESA+4             SAVE PRV S.A. ADDR
         LA    R1,NJESA                -> MY SAVE AREA
         ST    R1,8(,R13)              PLUG IT INTO PRIOR SA
         LR    R13,R1
*
         MVC   NJEEYE,=CL4'NJEF'       Work area eyecatcher
         ST    R2,NJEWKLEN             Save size of area
         MVC   SYSPRINT(DMYPRTL),DMYPRT Set up DCB
         MVC   LIST,BLANKS             Init print line
*
         MVC   MACLIST(OPENL),OPEN     Move OPEN list
         OPEN  (SYSPRINT,OUTPUT),      Open the print dataset          X
               MF=(E,MACLIST)
*
         MVC   LIST(L'MSG001),MSG001
         BAL   R14,PUT                 Write the line
         BAL   R14,PUT                 Write blank line
*
         GETMAIN RU,                   Get storage for NETSPOOL block  x
               LV=4089,                                                x
               BNDRY=PAGE
         ST    R1,BLK                  Save address
         LR    R8,R1                   Keep in R8
*
         LR    R1,R0                   Copy length
         LR    R0,R8                   Copy address
         SR    R15,R15                 Clear pad
         MVCL  R0,R14                  Clear the stg
*
         GENCB BLK=ACB,                                                x
               DDNAME=NETSPOOL,                                        x
               MACRF=(OUT,KEY,SEQ),                                    x
               MF=(G,MACLIST)
         STM   R0,R1,ACBL              Save len, addr
*
         LA    R9,KEY                  -> block number argument
         GENCB BLK=RPL,                                                x
               ACB=(*,ACB),                                            x
               AREA=(R8),              -> block area                   x
               AREALEN=4089,                                           x
               RECLEN=4089,                                            x
               ARG=(R9),                                               x
               OPTCD=(KEY,SEQ,MVE),                                    x
               MF=(G,MACLIST)
         STM   R0,R1,RPLL              Save len, addr
*
         L     R7,ACB                  -> ACB
         MVC   MACLIST(OPENL),OPEN     Move macro model
         OPEN  ((R7)),                 Open NETSPOOL                   x
               MF=(E,MACLIST)
         LTR   R15,R15                 Did open succeed?
         BNZ   OPENFAIL                No
         OI    FLAGS1,FL1OPEN          Indic ACB open
*
         LA    R5,HIRBA                -> SHOWCB receipt fields
         SHOWCB ACB=(R7),                                              x
               AREA=(R5),                                              x
               LENGTH=8,                                               x
               FIELDS=(HALCRBA,CINV),  Hi alloc RBA + CISZ             x
               MF=(G,MACLIST)
*
         CLC   CISZ,=F'4096'           Ensure CISZ is 4096
         BNE   BADCISZ                 It is not
         L     R5,HIRBA                Get high allocated RBA
         SRL   R5,12                   Divide by 4096
         ST    R5,BLKS                 Save number of blocks in d.set
*
         L     R6,RPL
         USING IFGRPL,R6
         LA    R4,1                    Init block counter
*
FMT000   EQU   *
         PUT   RPL=(R6)                Write a block
*
         LTR   R15,R15                 Any errors?
         BZ    FMT010                  No
         CLI   RPLRTNCD,X'08'          Logical error?
         BNE   PUTFAIL                 No, display error
         CLI   RPLERRCD,X'08'          Duplicate block?
         BE    FMT100                  Cluster is already formatted
         B     PUTFAIL                 Display all other errors
*
FMT010   EQU   *
         LA    R4,1(,R4)               Count blocks
         BCT   R5,FMT000               Format exact amount
         B     FMT200                  Now go write images
*
*-- Here if NETSPOOL was previously formatted
*
FMT100   EQU   *
         WTO   'NJEFMT - NETSPOOL dataset is already formatted'
         WTO   'NJEFMT - Reformatting will cause loss of all data'
*
FMT110   EQU   *
         XC    OPECB,OPECB             Reinit ECB
         LA    R2,DBLE                 -> reply area
         LA    R3,OPECB                -> WTOR ECB
         MVC   MACLIST(WTORDMYL),WTORDMY  Move model WTOR
         WTOR  ,(R2),6,(R3),MF=(E,MACLIST)
*
         WAIT  1,ECB=OPECB
         CLC   DBLE(6),=C'CANCEL'      Was cancel chosen?
         BE    OPERCAN                 Yes
         CLI   DBLE,C'U'               Was U chosen
         BNE   FMT110                  Reissue msg
*
*-- Switch to direct processing and rewrite fresh initial images
*-- to the directory and allocation map to be a newly formatted file.
*
FMT200   EQU   *
         MVC   MACLIST(CLOSEL),CLOSE   Move close list
         CLOSE ((R7)),                 Close ACB                       X
               MF=(E,MACLIST)
         NI    FLAGS1,255-FL1OPEN      Indic ACB closed
*
         MODCB ACB=(R7),               Switch to direct                x
               MACRF=(KEY,DIR,OUT),                                    x
               MF=(G,MACLIST)
*
         MODCB RPL=(R6),                                               x
               OPTCD=(KEY,DIR,UPD),    Switch to direct update         x
               MF=(G,MACLIST)
*
         MVC   MACLIST(OPENL),OPEN     Move macro model
         OPEN  ((R7)),                 Open NETSPOOL                   x
               MF=(E,MACLIST)
         LTR   R15,R15                 Did open succeed?
         BNZ   OPENFAIL                No
         OI    FLAGS1,FL1OPEN          Indic ACB open
*
         L     R2,BLK                  -> VSAM area
*
FMT210   EQU   *
         MVC   KEY,=F'1'               Set block # argument
         GET   RPL=(6)
         LTR   R15,R15                 Any errors?
         BNZ   GETFAIL                 YES
*
         LR    R0,R2                   -> block area
         LA    R1,4089                 Size of block
         LM    R14,R15,BLK1            Get block data addr, pad+len
         MVCL  R0,R14                  Init the block, SPL ID=0
         MVC   8(4,R2),BLKS            Set max # blocks in dataset
*
         PUT   RPL=(6)                 Update the block
         LTR   R15,R15                 Any errors?
         BNZ   PUTFAIL2                YES
*
FMT220   EQU   *
         MVC   KEY,=F'2'               Set block # argument
         GET   RPL=(6)
         LTR   R15,R15                 Any errors?
         BNZ   GETFAIL                 YES
*
         LR    R0,R2                   -> block area
         LA    R1,4089                 Size of block
         LM    R14,R15,BLK2            Get block data addr, pad+len
         MVCL  R0,R14                  Init the block
*
         PUT   RPL=(6)                 Update the block
         LTR   R15,R15                 Any errors?
         BNZ   PUTFAIL2                YES
*
FMT230   EQU   *
         MVC   KEY,=F'3'               Set block # argument
         GET   RPL=(6)
         LTR   R15,R15                 Any errors?
         BNZ   GETFAIL                 YES
*
         LR    R0,R2                   -> block area
         LA    R1,4089                 Size of block
         LM    R14,R15,BLK3            Get block data addr, pad+len
         MVCL  R0,R14                  Init the block
*
         PUT   RPL=(6)                 Update the block
         LTR   R15,R15                 Any errors?
         BNZ   PUTFAIL2                YES
*
*-- Set up allocation map
*
* The allocation map is a bit map, 1 bit for each block in the
* NETSPOOL dataset.  A "1" bit means the block is in use.  Initially,
* blocks 1-7 will be marked in use as they contain upon formatting:
*   block 1 - pointer to directory (A or B) and allocation blocks
*   block 2 - initial directory block A
*   block 3 - initial directory block B
*   blocks 4-7 - allocation bit map
*
* The bitmap contains 4 * 4096 bytes * 8 bits = 130,848 bits.  Thus,
* the largest supported NETSPOOL size is about 874 cylinders on a
* 3380 DASD.
*
* The size of the NETSPOOL dataset can of course be smaller and all
* bits past the end of the file should be marked as "in-use" in the
* bitmap so they would never be allocated.
*
* The calculation for this is at FMT250.
* Example:  assume 10 cylinder file on 3380 = 150 blocks per cyl,
* or 1500 total blocks in file.
*
* Starting from block 1501 (the first block past the end of the
* dataset) divide by 8 to compute the byte number in the bitmap
* representing block 1501:
*
* 1. 1501 / 8 = 187 remainder 5
* 2. Make a byte image of X'FF' (all records unavail in byte).
* 3. Shift it to the right by the remainder (adding 0's on the left):
*       X'FF' shifted right by 5 = X'07'
* 4. Store the X'07' computed value into byte 187 of the bitmap.
* 5. All subsequent bytes 188 through the end of four blocks are X'FF'
* 6. Write the four blocks to disk.
*
FMT240   EQU   *
         GETMAIN RU,LV=16384           4 blocks of size
         LR    R4,R1
         LR    R1,R0                   COPY LENGTH
         LR    R0,R4                   -> NEW STG AREA
         SR    R15,R15                 SET PAD
         MVCL  R0,R14                  CLEAR THE PAGES
*
         MVC   0(1,R4),DATA4           Set up allocation; blocks 1-7
*                                       are initially in use
FMT250   EQU   *
         L     R7,BLKS                 Get # blocks in dataset
         LA    R7,1(,R7)               block # of first unavail blk
         SR    R6,R6                   Clear for divide
         D     R6,=F'8'                Get byte offset remainder bits
*
         AR    R7,R4                   -> byte containing bit for
*                                       first record beyond file size
         ICM   R1,8,=X'FF'             Assume all recs in byte unavail
         SRL   R1,0(R6)                Adjust for actual blocks that
*                                       do exist in same byte
         STCM  R1,8,0(R7)              Store it in map
*
         LA    R0,1(,R7)               -> next byte in map
         L     R1,=F'16384'            Stg size
         AR    R1,R4                   Point to end of it
         SR    R1,R0                   Compute length to end
         L     R15,=X'FF000000'        Set all FFs pad char
         MVCL  R0,R14                  All FFs to the end
*
*
         LA    R3,4                    Blk # of allocation map
         LA    R7,4                    # of blocks to process
         L     R6,RPL                  -> RPL
*
FMT270   EQU   *               Write map blocks 4 through 7
         ST    R3,KEY                  Set block # argument
         GET   RPL=(6)
         LTR   R15,R15                 Any errors?
         BNZ   GETFAIL                 YES
*
         LR    R0,R2                   -> block area
         LA    R1,4089                 Size of block
         LA    R5,4089                 Size of block
         MVCL  R0,R4                   Init the block
*
         PUT   RPL=(6)                 Update the block
         LTR   R15,R15                 Any errors?
         BNZ   PUTFAIL2                YES
*
         LA    R3,1(,R3)               next blk #
         BCT   R7,FMT270
         B     EXIT0                   Format success
*
*-- Error routines
*
OPENFAIL EQU   *
         MVC   LIST(L'MSG002),MSG002   Open failed
         CVD   R15,DBLE                Convert RC
         UNPK  LIST+29(2),DBLE
         OI    LIST+30,X'F0'
         USING IFGACB,R7
         UNPK  DBLE(3),ACBERFLG(2)
         TR    DBLE(2),HEXTRAN-240
         MVC   LIST+43(2),DBLE         Move error value to line
         DROP  R7
         BAL   R14,PUT                 Write open fail msg
         B     EXIT8
*
BADCISZ  EQU   *
         MVC   LIST(L'MSG004),MSG004   NETSPOOL dataset definition err
         BAL   R14,PUT                 Write msg
         MVC   LIST(L'MSG005),MSG005   CISZ must be 4096
         BAL   R14,PUT                 Write msg
         B     EXIT8
*
OPERCAN  EQU   *
         MVC   LIST(L'MSG006),MSG006   Formatting terminated by oper
         BAL   R14,PUT                 Write msg
         B     EXIT8
*
PUTFAIL  EQU   *
         MVC   LIST(L'MSG003),MSG003   PUT failed
         CVD   R5,DBLE                 Convert block number
         MVC   LIST+25(8),=X'4020202020202120'  Move edit mask
         ED    LIST+25(8),DBLE+4       Edit block count
         USING IFGRPL,R6
         UNPK  TWRK(9),RPLFDBWD(5)
         TR    TWRK(8),HEXTRAN-240
         MVC   LIST+48(2),TWRK+2       Move RTNCD value to line
         MVC   LIST+50(2),TWRK+6       Move FDBK value to line
         DROP  R6
         BAL   R14,PUT                 Write open fail msg
         B     EXIT8
*
GETFAIL  EQU   *
         MVC   LIST(L'MSG007),MSG007   Get failed
         CVD   R3,DBLE                 Convert block number
         MVC   LIST+25(8),=X'4020202020202120'  Move edit mask
         ED    LIST+25(8),DBLE+4       Edit block count
         USING IFGRPL,R6
         UNPK  TWRK(9),RPLFDBWD(5)
         TR    TWRK(8),HEXTRAN-240
         MVC   LIST+48(2),TWRK+2       Move RTNCD value to line
         MVC   LIST+50(2),TWRK+6       Move FDBK value to line
         DROP  R6
         BAL   R14,PUT                 Write open fail msg
         B     EXIT8
*
PUTFAIL2 EQU   *
         MVC   LIST(L'MSG008),MSG008   PUT failed
         CVD   R5,DBLE                 Convert block number
         MVC   LIST+26(8),=X'4020202020202120'  Move edit mask
         ED    LIST+26(8),DBLE+4       Edit block count
         USING IFGRPL,R6
         UNPK  TWRK(9),RPLFDBWD(5)
         TR    TWRK(8),HEXTRAN-240
         MVC   LIST+49(2),TWRK+2       Move RTNCD value to line
         MVC   LIST+51(2),TWRK+6       Move FDBK value to line
         DROP  R6
         BAL   R14,PUT                 Write open fail msg
         B     EXIT8
*
PUT      EQU   *
         ST    R14,SV14                Save return addr
         PUT   SYSPRINT,LIST
         MVC   LIST,BLANKS
         L     R14,SV14                Load return addr
         BR    R14                     Return
*
EXIT8    EQU   *
         BAL   R14,PUT                 Write blank
         MVC   LIST(L'MSG999),MSG999   Exited with errors
         BAL   R14,PUT                 Write msg
*
         LA    R15,8
         B     QUIT000
*
EXIT0    EQU   *
         BAL   R14,PUT                 Write blank
         MVC   LIST(L'MSG900),MSG900   Exited with success
         BAL   R14,PUT                 Write msg
*
         SR    R15,R15
*
QUIT000  EQU   *
         LR    R5,R15                  Copy exit RC
*
         TM    FLAGS1,FL1OPEN          Is ACB open?
         BZ    QUIT010                 No, skip close
         MVC   MACLIST(CLOSEL),CLOSE   Move close list
         L     R7,ACB                  -> ACB
         CLOSE ((R7)),                 Close ACB                       X
               MF=(E,MACLIST)
*
QUIT010  EQU   *
         MVC   MACLIST(CLOSEL),CLOSE   Move close list
         CLOSE (SYSPRINT),                                             X
               MF=(E,MACLIST)
*
         LM    R0,R1,RPLL
         FREEMAIN RU,LV=(0),A=(1)
*
         LM    R0,R1,ACBL
         FREEMAIN RU,LV=(0),A=(1)
*
         L     R1,BLK
         FREEMAIN RU,LV=4089,A=(1)
*
         LR    R1,R10                  -> NJEFWK work area
         L     R13,4(,R13)             -> CALLER'S SA
         FREEMAIN RU,                  Free the work area              X
               LV=NJEFSZ,                                              X
               A=(1)
*
         ST    R5,16(,R13)             Save R15 RC
         LM    R14,R12,12(R13)         RELOAD SYSTEM'S REGS
         BR    R14                     Return
*
         LTORG
*
DMYPRT   DCB   DDNAME=SYSPRINT,                                        X
               MACRF=(PM),                                             X
               DSORG=PS,                                               X
               LRECL=80,                                               X
               RECFM=FB,                                               X
               BLKSIZE=800
DMYPRTL  EQU   *-DMYPRT
*
OPEN     OPEN  0,MF=L
OPENL    EQU   *-OPEN
CLOSE    CLOSE 0,MF=L
CLOSEL   EQU   *-CLOSE
*
WTORDMY  WTOR  'NJEFMT - Reply U to proceed with format, or CANCEL',   x
               MF=L
WTORDMYL EQU   *-WTORDMY
*
MSG001   DC    C'NJEFMT - NJE38 NETSPOOL FORMAT UTILITY'
*                0123456789012345678901234567890123456789012 345 6789
MSG002   DC    C'Open failed for NETSPOOL, RC=xx,ACBERFLG=X''xx'''
*                012345678901234567890123456789012345678901234567 8901
MSG003   DC    C'PUT failed writing record xxxxxxx, RTNCD-FDBK=X''xxxx'x
               ''
MSG004   DC    C'NETSPOOL dataset definition error:'
MSG005   DC    C'  CONTROLINTERVALSIZE must be exactly 4096 bytes'
MSG006   DC    C'Formatting terminated by system operator'
MSG007   DC    C'GET failed reading record xxxxxxx, RTNCD-FDBK=X''xxxx'x
               ''
MSG008   DC    C'PUT failed updating record xxxxxxx, RTNCD-FDBK=X''xxxxX
               '''
MSG900   DC    C'Format utility completed successfully'
MSG999   DC    C'Format utility terminated with errors'
*
BLANKS   DC    CL80' '
HEXTRAN  DC    CL16'0123456789ABCDEF'
*
*
*
*
BLK1     DC    A(DATA1),A(DATA1L)      Addr and length
DATA1    DC    F'2'                    Blk # of current directory
         DC    F'4'                    Blk # of allocation map
         DC    F'0'                    # blks in dataset
         DC    F'0'                    Last assigned spool file id #
DATA1L   EQU   *-DATA1
*
BLK2     DC    A(DATA2),A(DATA2L)      Addr and length
DATA2    EQU   *
         DC    AL2(NSDIRLN)     LEN    Length of record
         DC    AL2(0)           RESV1  reserved
         DC    F'2'             BLK    blk # of 1st block of file
         DC    CL8'NETSPOOL'    INLOC
         DC    CL16' '          LINK/INTOD
         DC    CL8'DIR'         INVM
         DC    AL4(1)           RECNM  No. records in the file
*                                      Remainder of block is zeros
*
DATA2L   EQU   *-DATA2
*
BLK3     DC    A(DATA3),A(DATA3L)      Addr and length
DATA3    EQU   *
         DC    AL2(NSDIRLN)     LEN    Length of record
         DC    AL2(0)           RESV1  reserved
         DC    F'3'             BLK    blk # of 1st block of file
         DC    CL8'NETSPOOL'    INLOC
         DC    CL16' '          LINK/INTOD
         DC    CL8'DIR'         INVM
         DC    AL4(1)           RECNM  No. records in the file
*                                      Remainder of block is zeros
DATA3L   EQU   *-DATA3
*
DATA4    DC    B'11111110'             Blocks initially allocated are
*                                        blocks 1-7
*
* The rest of blocks 4 and 5,6,7 are computed at FMT250 and written
* at FMT270.
*
*
*
NJEFWK   DSECT
NJEEYE   DS    CL4'NJEF'               EYECATCHER
NJEWKLEN DS    F                       SIZE OF WORK AREA
*
NJESA    DS    18F
DBLE     DS    D
TWRK     DS    XL16
MACLIST  DS    XL128
LIST     DS    CL80                    PRINT LINE
SV14     DS    F                       R14 save area
OPECB    DS    F                       Operator reply ECB
BLK      DS    A                       -> NETSPOOL block stg area
KEY      DS    F                       Relative block number key
ACBL     DS    F                       ACB length
ACB      DS    A                       -> ACB
RPLL     DS    F                       RPL length
RPL      DS    A                       -> RPL
HIRBA    DS    F                       High allocated RBA
CISZ     DS    F                       CI Size
BLKS     DS    F                       Number of relative blocks
*
FLAGS1   DS    X
FL1OPEN  EQU   X'80'      1... ....    ACB is open
*
SYSPRINT DS    (DMYPRTL)X              SYSPRINT DCB
         DS    0D                      Force doubleword boundary
NJEFSZ   EQU   *-NJEFWK                Size of work area
*
         COPY  NETSPOOL
         IFGACB
         IFGRPL
         END
./ ADD NAME=NJEINIT
*
*
*-- NJE38 - Initialization and start up
*
*
*
* Change log:
*
*
* 03 Mar 22 - Avoid 0C4 if no links in CONFIG, APF check, F NJE.   v230
* 10 Dec 20 - Support for registered users and message queuing     v220
* 04 Dec 20 - Expanded internal trace table support                v212
* 29 Nov 20 - Use text-based configuration; alternate routes       v211
* 02 Oct 20 - Use actual length for MGCR SEND cmds                 v210
* 01 Oct 20 - Put ENQ existence check in common module             v210
* 10 Aug 20 - Use single NJESPOOL load for all STC NJE38 modules.  v210
* 22 Jul 20 - Make non-swappable to eliminate long-wait delays     v200
* 21 Jul 20 - Slightly delay auto-start of links on start-up.      v200
* 02 Jul 20 - Default userid to CSA in support of TRANSMIT/RECEOVE v200
* 20 May 20 - Dont pass new file WREs for local node to cmd proc'g v120
* 05 May 20 - Abend SD23 if SVC 34 parmlist >=130 bytes.           v102
* 04 May 20 - Show CONFIG assembly date and time on start up.      v102
*
*
*
*
*
*
         PRINT GEN
         REGEQU                        REGISTER EQUATES
         GBLC  &VERS
*
* User abend codes
*  U0038 - Unsupported/unrecognized CIB
*  U0039 - VSAM error on NETSPOOL
*
* MSG numbers used:
*
*     0-34      used
*     35 - 39   available
*     42-79     used
*     163       used
*
*-- Program limits
*
TRACESZ  EQU   64                      Size in K of trace table    v212
RQELIM   EQU   256                     # of preallocated RQEs
*
*
NJEINIT  CSECT
         NJEVER
         STM   R14,R12,12(R13)         SAVE CMS REGS
         LR    R12,R15                 BASE
         USING NJEINIT,R12             ADDRESS IT
*
         GETMAIN RU,                   Get local stg area              X
               LV=4096,                                                X
               BNDRY=PAGE
         LR    R10,R1
         LR    R1,R0                   Copy length
         LR    R2,R0                   Copy length
         LR    R0,R10                  -> new stg area
         SR    R15,R15                 set pad
         MVCL  R0,R14                  Clear the page
*
         USING NJEMWK,R10
         ST    R13,NJESA+4             SAVE prv S.A. ADDR
         LA    R1,NJESA                -> my save area
         ST    R1,8(,R13)              Plug it into prior SA
         LR    R13,R1
*
         MVC   NJEEYE,=CL4'NJEM'       Work area eyecatcher
         ST    R2,NJEWKLEN             Save size of area in area
*
         L     R11,=A(NJECOM)          -> common csect
         USING NJECOM,R11
         ST    R11,ANJECOM             Save in main work area
         MVC   CMDBLNK,BLANKS          Init field
         MVC   RELAYID,=CL8'RELAY'     Set RELAY entity id         v220
         LA    R1,LINKS                -> LINKTABL anchor word     v211
         ST    R1,ALINKS               Plug it into param list     v211
         LA    R1,ROUTES               -> RTE anchor word          v211
         ST    R1,AROUTES              Plug it into param list     v211
         LA    R1,AUTHS                -> AUTHLIST anchor word     v211
         ST    R1,AAUTHS               Plug it into param list     v211
         LA    R1,REGUSER              -> REGUSER anchor word      v220
         ST    R1,AREGUSER             Plug it into param list     v220
*
INIT000  EQU   *                                                   v200
         SR    R1,R1                   Dont return spool DSN       v210
         L     R15,=V(NJESYS)          -> ENQ finder               v210
         BALR  R14,R15                 Check if NJE38 already act  v210
         LTR   R15,R15                 Look for RC=0=ENQ was found v210
         BZ    ERR999                  Branch if NJE38 active      v210
*
         MVC   MACLIST(WTOMSGL),WTOMSG
         MVC   MACLIST+4(L'NJE000I),NJE000I   NJE38 v xx.xx
         WTO   ,MF=(E,MACLIST)
*
         TESTAUTH FCTN=1               Are we authorized on entry? v230
         LTR   R15,R15                 Check result                v230
         BZ    INIT005                 Branch if authorized        v230
         WTO   'NJE034I NJE38 is not APF-authorized'               v230
         B     QUIT000                                             v230
*
INIT005  EQU   *                                                   v230
         SR    R1,R1                                               v200
         SYSEVENT TRANSWAP                                         v200
         CLM   R1,1,=X'00'             SYSEVENT RC=0?              v200
         BE    INIT010                 Yes                         v200
         WTO   'NJE032I NJE38 could not enter non-swappable state' v200
         B     INIT020                                             v200
*
INIT010  EQU   *                                                   v200
         WTO   'NJE031I NJE38 is non-swappable'                    v200
*
INIT020  EQU   *                                                   v200
         MVC   MACLIST(ESTAEL),ESTAE   Move ESTAE parm list
         L     R6,=A(NJEDMP)           Point to local ESTAE rtn
         ESTAE (R6),                   Issue ESTAE                     X
               CT,                                                     X
               TERM=YES,                                               X
               PARAM=(R10),            PARAM is work area address      X
               MF=(E,MACLIST)
*
*-- Scan the configuration and build control blocks
*
         MODESET MODE=SUP
         SR    R0,R0                   R0=0 scan entire configuration
         LA    R1,INITPARM             -> parm list to pass to NJESCN
         L     R15,=V(NJESCN)
         BALR  R14,R15
         LTR   R15,R15
         BNZ   QUIT000
*
         L     R1,LINKS                Get LINKTABL anchor         v210
         USING LINKTABL,R1
         MVC   LCLNODE,LINKID          Set LCLNODE in param list   v210
         DROP  R1
*
*-- Issue STIMER for keep alive to avoid S 522 abends
*
         L     R0,=A(NJETMR)           -> Timer expiration exit
         L     R1,=A(INTVL)            -> interval
         STIMER REAL,                  Set timer                       X
               (0),                                                    X
               DINTVL=(1)
*
         LOAD  EP=NJESPOOL             Load spool interface        v210
         ST    R0,ANJESPL              Store entry addr            v210
*
         LOAD  EP=NJECMX               Load command processor
         ST    R0,ANJECMX              Store entry addr of processor
*
         BAL   R14,NET000              Check NETSPOOL status
         BNZ   QUIT000                 Exit if NETSPOOL is not ready
*
INIT030  EQU   *
         MODESET MODE=SUP,KEY=ZERO
         L     R1,PSATOLD-PSA(0)                                   v230
         L     R1,TCBJSCB-TCB(,R1)                                 v230
         L     R1,JSCBCSCB-IEZJSCB(,R1)                            v230
         USING CSCB,R1                                             v230
         MVC   CHUNIT(3),=C'NJE'                                   v230
         DROP  R1                                                  v230
*
         STIDP CPUID                   Get the CPU ID
*
         GETMAIN RU,                   Get CSA communication area      x
               LV=NJ38CSAZ,                                            x
               SP=241
*
         ST    R1,CSABLK               Save addr of CSA stg area
         USING NJ38CSA,R1
         XC    0(NJ38CSAZ,R1),0(R1)    Clear area
         MVC   NJ38NODE,LCLNODE        Local node name to CSA
         MVC   NJ38DUSR,DEFUSER        Default userid to CSA       v200
         MVC   NJ38ASCB,PSAAOLD-PSA(0) Move ASCB addr of this space
         LA    R2,NJ38ECB              -> cross memory ECB
         ST    R2,CSAECBAD             Save address locally
         DROP  R1                      NJ38CSA
*
         SPKA  X'80'                    Back to user key
*
         MVC   NJERNAME(8),NJERCON     Set rname constant
         MVC   NJERNAME+8(4),CSABLK    CSA stg addr to Rname
*                                      JFCB DSN should already be here
         LA    R5,NJERNAME
         MVC   MACLIST(ENQL),ENQ       Move macro model
*
         ENQ   (NJE38Q,(5),E,56,SYSTEM),                               x
               RET=NONE,                                               x
               MF=(E,MACLIST)
         OI    NJFL1,NJF1ENQ           Set NJE38 ENQ active
*
         GETMAIN RU,                   Preallocate RQE storage         x
               LV=RQESZ*RQELIM
         ST    R1,ARQESTG              Save the address
         LR    R2,R1                   Copy length
         LR    R1,R0                   Copy length
         LR    R0,R2                   -> new stg area
         SR    R15,R15                 set pad
         MVCL  R0,R14                  Clear the stg
         LA    R0,RQELIM               Get RQE limit
         ST    R0,RQENUM               Save the value
*
*
*- Build trace table                                               v212
*
         GETMAIN RU,                   Get stg for trace table     v212X
               LV=TRACESZ*1024,                                    v212X
               BNDRY=PAGE                                          v212
         ST    R1,ATRACE               Save ptr to trace table     v212
         MVC   0(5,R1),=CL5'TRACE'                                 v212
         MVI   5(R1),C'T'              So eyecatcher TRACETAB      v212
         MVI   6(R1),C'A'               wont show in a dump        v212
         MVI   7(R1),C'B'                in this load module       v212
         USING TRCCTL,R1                                           v212
         ST    R1,TRCSTRT              Set start                   v212
         ST    R1,TRCCURR              Set current                 v212
         AR    R0,R1                   -> end                      v212
         ST    R0,TRCEND               Set end                     v212
         L     R15,=A(NJETRC)          -> Trace CSECT              v212
         ST    R15,TRCRTN              Set trace routine EPA       v212
         DROP  R1                                                  v212
*
*
*-- Initialize console processing to allow MVS modify and stop
*-- commands to control this address space
*
INIT040  EQU   *
         MVC   MACLIST(EXTRACTL),EXTRACT Move macro model
         LA    R3,COMMAREA             -> area to place comm area addr
         EXTRACT (3),                  Get ptr to comm area            X
               FIELDS=COMM,                                            X
               MF=(E,MACLIST)
*
         L     R3,COMMAREA             -> ptrs to COMM CIB and ECB
         USING IEZCOM,R3               Map the communication area
         MVC   COMMECBA,COMECBPT       Save off addr of COMM ECB
         ICM   R4,15,COMCIBPT          Get addr of CIB ptr
         BZ    INIT060                 No CIB, go get one
         USING CIBNEXT,R4              Map the CIB
*
         CLI   CIBVERB,CIBSTART        Is this a START CIB?
         BNE   INIT060                 No, set up CIB count
*
         QEDIT ORIGIN=COMCIBPT,        Free the CIB from the START cmd X
               BLOCK=(4)                that started this space
*
INIT060  EQU   *
         QEDIT ORIGIN=COMCIBPT,        Set CIB limit to 1              X
               CIBCTR=1
         DROP  R4                      IEZCIB
         DROP  R3                      IEZCOM
*
*
*
*- Initialization Completed
*
INIT090  EQU   *
         MVC   MACLIST(WTOMSGL),WTOMSG
         MVC   MACLIST+4(L'NJE001I),NJE001I   Move msg text
         MVC   MACLIST+51(8),LCLNODE
         WTO   ,MF=(E,MACLIST)
*
*- Start any auto-startable links
*
*
         L     R2,LINKS                -> 1st entry (LOCAL entry)  v211
         USING LINKTABL,R2
         ICM   R2,15,LNEXT             -> first remote link        v22x
         BZ    MAIN000                 No auto if no links         v22x
*
AUTO000  EQU   *
         TM    LFLAG,LAUTO             Is link autostartable?
         BZ    AUTO010                 No
         BAL   R14,SLNK000             Try to start the link
*
         STIMER WAIT,DINTVL=ATTDLY     Pause briefly               v200
*
AUTO010  EQU   *
         ICM   R2,15,LNEXT             -> next LINKTABL entry
         BNZ   AUTO000                 Look for another link
         DROP  R2                      LINKTABL
*
*
*
MAIN000  EQU   *
         BAL   R14,BLDL000             Go build the ECB list
         BZ    QUIT000                 No ECBS in list; terminate
*
         SPKA  0                       Use key 0 for CSA ECB
         WAIT  1,ECBLIST=ECBLIST
*
*-- Identify the ECB that was posted
*
MAIN010  EQU   *
         LA    R1,ECBLIST              -> our ECBLIST
*
MAIN050  EQU   *
         ICM   R2,15,0(R1)             -> ECB                      v211
         BZ    MAIN055                 Skip ECB if empty slot      v211
         TM    0(R2),X'40'             Was this ECB posted?
         BO    MAIN060                 Yes
*
MAIN055  EQU   *                                                   v211
         TM    0(R1),X'80'             Last ECB addr in list?
         BO    MAIN000                 Nothing to do, go WAIT
         LA    R1,4(,R1)               -> next ECB addr
         B     MAIN050                 Keep looking
*
*
MAIN060  EQU   *
         CLM   R2,7,CSAECBAD+1         Was the WRE work ECB posted?
         BE    WRK000                  Hey!  We have something to do
*
         SPKA  X'80'                   Back to user key for the rest
         CLM   R2,7,COMMECBA+1         Was the COMM ECB posted?
         BE    COMM000                 Yes
*
***      L     R3,0(,R2)               Load the ECB content        v211
         XC    0(4,R2),0(R2)           Clear the ECB
         LA    R0,LTRMECB-LINKTABL     Offset of ECB in LINKTABL   v211
         SR    R2,R0                   -> LINKTABL entry           v211
         USING LINKTABL,R2
***      CLM   R3,7,=AL3(255)          ECB post code 255?          v211
***      BE    MAIN080                 Yes, LINKTABL entry delete  v211
*
         DETACH LTCBA                  Detach the subtask
         XC    LTCBA,LTCBA             Mark task terminated
         MVI   LFLAG,X'00'             Clear status flags
*
         MVC   MACLIST(WTOMSGL),WTOMSG
         MVC   MACLIST+4(L'NJE010I),NJE010I   Line is drained
         UNPK  DBLE(4),LACTLINE(3)     Convert CUU of line
         TR    DBLE(3),HEXTRAN-240
         MVC   MACLIST+17(3),DBLE
         WTO   ,MF=(E,MACLIST)         Line xxx is drained
         B     MAIN010                 Look for more work
*
*-- Here to delete a LINKTABL entry (from LINK OFF command)        v211
*-- We arrive here from POST code 255. NJESCN LOFF000 does the POSTv211
*
         DROP  R2                      LINKTABL                    v211
*
*-- Build a new ECBLIST before the wait
*
BLDL000  EQU   *
         SR    R1,R1                   Init: no ECBs in list
         LA    R15,ECBLIST-4           -> 0th ECB list entry
         TM    NJFL1,NJF1STOP          Is main task termination set?
         BO    BLDL010                 Yes, dont add COMM ECBs to list
         LA    R15,4(,R15)             -> next available ECB list slot
         L     R1,COMMECBA             -> COMM ECB
         ST    R1,0(,R15)              Set addr in ECB list
         LA    R15,4(,R15)             -> next available ECB list slot
         L     R1,CSAECBAD             -> WRE work ECB
         ST    R1,0(,R15)              Set addr in ECB list
*
BLDL010  EQU   *
         L     R2,LINKS                -> 1st entry (LOCAL entry)  v211
         USING LINKTABL,R2
         L     R2,LNEXT                -> first remote link        v211
*
BLDL020  EQU   *
         CLC   LTCBA,=A(0)             Is task active for link?
         BE    BLDL030                 Zero, skip this one
         LA    R15,4(,R15)             -> next available ECB list slot
         LA    R1,LTRMECB              -> task's termination ECB
         ST    R1,0(,R15)              Set ECB addr in ECB list
*
BLDL030  EQU   *
         ICM   R2,15,LNEXT             -> next LINKTABL entry
         BNZ   BLDL020                 Scan them all
         DROP  R2                      LINKTABL
         LTR   R1,R1                   Any ECB in the list?
         BZR   R14                     No, return with CC=0 set
         OI    0(R15),X'80'            Mark end of list
         BR    R14                     Return with ECB list built
*
**********************************************************************
*                                                                    *
*                           WRE FLOWS                                *
*                                                                    *
**********************************************************************
*
* When WREs are created by out-of-address space tasks (such as by
* modules NJE38 by TSO users, or NJ38XMIT by jobs) they are
* created in CSA and chained off the NJE38 CSA block NJ38CSA.  The
* WRE ECB is posted via cross memory post.  Any WRE posted in this
* manner will first end up here, at WRK000 below.
*
* WRK000 will pull the entire chain of WREs and get it off that queue
* so that these can be processed one at a time while outside tasks may
* continue to add new WREs to the CSA chain.
*
* Each WRE is examined for its destination.  If the WRE has a
* destination link id in the LINKs table, or via a route that can be
* forwarded via a destination link, the WRE will be requeued to that
* particular link task at WRK120.
*
*  When the link task gets the WRE, it will be processed by NJEDRV
*  label COMM000, which will dequeue it and flow continues to
*  label WRK000 in that same module.  After processing the WRE stg
*  is freed.
*
* Back in NJEINIT, if the WRE is destined for the local link (at
* WRK030) flow proceeds to WRK200 where the command processor NJECMD
* is called to examine and process the action.  Upon return, the
* WRE storage is freed and the next WRE on the chain is examined,
* if any.
*
* Notes:
*  1. WREs are created in subpool 2 which is shared by other TCBs.
*       (Except for out-of-address-space WREs, which are in CSA).
*  2. WREs are sometimes created internally:
*     a). in NJEINIT STOP000 to queue a WRE to each active link task
*         in order to stop the link.
*     b). in NJEINIT CCD000 in order to queue a command that was
*         input from the system console to a remote link task.
*  3. Whether the WRE is created from an outside address space or
*     internally, they all flow the same way, via the post to the
*     ECB in NJ38CSA and being placed on the queue anchor in NJ38CSA.
*
*
*
* Summary:
*
*  1. WRE gets created and posted to CSA anchor
*  2. NJEINIT WRK000 sees the WRE first
*  3. WRE is requeued to a link or handled by NJEINIT/NJECMD
*  4. WRE is freed.
*
*
*
*
*
*
*
*-- WRE work ECB was posted
*
WRK000   EQU   *
         SPKA  0                       This routine must run key=0
         XC    0(4,R2),0(R2)           Reinit WRE work ECB
         L     R2,CSABLK               -> CSA communications area
         USING NJ38CSA,R2
*
         LM    R6,R7,NJ38SWAP          Get WRE anchor, sync count
*
WRK010   EQU   *
         LTR   R6,R6                   Was WRE Q empty?
         BZ    MAIN010                 Yes, nothing else to do
         SR    R14,R14                 Zero out the WRE Q anchor
         LR    R15,R7                  Copy same sync count
         CDS   R6,R14,NJ38SWAP         Try to empty the WRE Q
         BC    7,WRK010                Can't yet, try again
         DROP  R2                      NJ38CSA
*
*-- Distribute the WREs to the various links
*
*-- R6 -> start of WRE chain we dequeued from WRE Q
*
         USING WRE,R6
*
*
WRK030   EQU   *
         NJETRACE TYPE=TRCIWRE     Trace incoming WRE
         STCM  R10,7,1(R14)            Identify trace entry        v220
         LA    R15,*               -> here                         v220
         ST    R15,4(,R14)         Save addr of trace request      v220
         ST    R6,8(,R14)          Trace WRE addr                  v220
         MVC   12(4,R14),WRETYPE   Trace type code,len,subpool     v220
         MVC   16(8,R14),WRELINK   link dest                       v220
         MVC   24(8,R14),WREUSER   userid dest                     v220
         NJETRACE TYPE=TRCIWRE     Trace incoming WRE follow on    v220
         OI    0(R14),X'80'        Indicate follow on              v220
         STCM  R10,7,1(R14)            Identify trace entry        v220
         MVC   4(8,R14),WREORIG    Originator userid               v220
         MVC   12(20,R14),WRETXT   Trace WRE content               v220
*
         CLC   WRELINK,LCLNODE         Is this WRE for the local node?
         BE    WRK200                  Yes, don't queue it to a link
*
WRK040   EQU   *
         LA    R1,WRELINK              -> destination link of WRE
         BAL   R14,FLNK000             Locate the LINKTABL entry
         BZ    WRK050                  No link found, check routes
*
         USING LINKTABL,R2
         TM    LFLAG,LCONNECT          Is link connected?
         BO    WRK120                  Yes, post the link task
*
*-- Otherwise, look at routes.  R1-> WRELINK
*
WRK050   EQU   *
         BAL   R14,RLNK000             Find matching route
         BZ    WRK150                  No matching routes
         BAL   R14,FLNK000             Locate the LINKTABL entry
         BZ    WRK150                  No link found for this WRE
         TM    LFLAG,LCONNECT          Is link connected?
         BZ    WRK150                  No, skip this WRE
*
*
*-- Here to requeue the WRE to the link WRE chain
*
WRK120   EQU   *
         NJETRACE TYPE=TRCOWRE     Trace outgoing WRE
         STCM  R10,7,1(R14)            Identify trace entry        v220
         LA    R15,*               -> here                         v220
         ST    R15,4(,R14)         Save addr of trace request      v220
         ST    R6,8(,R14)          Trace WRE addr                  v220
         MVC   12(4,R14),WRETYPE   Trace type code,len,subpool     v220
         MVC   16(8,R14),WRELINK   link dest                       v220
         MVC   24(8,R14),WREUSER   userid dest                     v220
         NJETRACE TYPE=TRCOWRE     Trace outgoing WRE follow on    v220
         OI    0(R14),X'80'        Indicate follow on              v220
         STCM  R10,7,1(R14)            Identify trace entry        v220
         MVC   4(8,R14),WREORIG    Originator userid               v220
         MVC   12(20,R14),WRETXT   Trace WRE content               v220
*
         L     R8,WRENEXT              -> next WRE in CSA chain
*
         LM    R0,R1,LWRESWAP          Get first WRE ptr, sync count
WRK130   EQU   *
         ST    R0,WRENEXT              First WRE becomes next
         LR    R4,R6                   -> WRE to be added as first
         LA    R5,1(,R1)               Incr synchronization count
         CDS   R0,R4,LWRESWAP          Update LINK WRE anchor, sync
         BC    7,WRK130                Gotta try again
*
         LA    R1,LECB                 -> link task notification ECB
         POST  (1)                     Tell task
         B     WRK290                  Go get another WRE
*
*-- Release WRE that we cant distribute to a link
*
WRK150   EQU   *
         B     WRK290
         DROP  R2                      LINKTABL
*
*-- Here if WRE is intended for the local node
*
WRK200   EQU   *
         SR    R15,R15                 Clear for IC                v220
         IC    R15,WRETYPE             Get WRE type code           v220
         CLM   R15,1,=AL1(WRK210HI)    Check against highest code  v220
         BH    WRK280                  Dispose of invalid WRE      v220
         B     WRK210(R15)             Branch into table           v220
*
WRK210   EQU   *                                                   v220
         B     WRK280            X'00'  Invalid; just delete WRE   v220
         B     WRK280            X'04'  WRENEW; ignore for LCL nodev220
         B     WRK215            X'08'  WRECMD                     v220
         B     WRK220            X'0C'  WREMSG                     v220
         B     WRK240            X'10'  WRESTAR                    v220
         B     WRK300            X'14'  WREREG                     v220
         B     WRK350            X'18'  WREDREG                    v220
         B     WRK400            X'1C'  WREQRM                     v220
         B     WRK450            X'20'  WREDRM                     v220
WRK210HI EQU   (*-WRK210-4)      Highest code supported            v220
*
*
WRK215   EQU   *
         SPKA  X'80'
         MVC   CMDAREA,BLANKS          Init receiving area
         SR    R2,R2                   Clear for IC
         IC    R2,WRETXTLN             Get cmd image length
         EX    R2,MVTXT1               Move cmd image
         STC   R2,CMNDBLEN             IBM length of image to CMDBLOK
         MVC   CMNDLINK,LCLNODE        This node is the issuer
         MVC   CMNDUSER,WREUSER        Copy TSO id of issuer
*
         L     R15,=A(NJECMD)          -> command processor
         BALR  R14,R15                 Go there
         SPKA  X'00'
         B     WRK280
*
MVTXT1   MVC   CMDAREA(0),WRETXT       Executed instr
*
*-- Send the msg response to a local TSO user
*
WRK220   EQU   *
         CLC   WREUSER,=CL8'OP'        Message destined for operator?
         BE    WRK230                  Yes
         LA    R15,WREUSER              -> userid to locate
         BAL   R14,REG000               See if user registered     v220
         BNZ   WRK280                   Yes it was; we queued it   v220
         BAL   R14,USR800               See if TSO user logged on
         BZ    WRK280                   Skip msg if not
         MVC   MACLIST(80),BLANKS       Init first part
         MVC   MACLIST+4(9),=C'SE ''From '
         MVC   MACLIST+13(8),WREORIG
         TRT   MACLIST+13(9),BLANK     Look for end of orig userid
         MVI   0(R1),C':'
         LA    R1,2(,R1)               -> area for msg
         MVC   0(104,R1),WRETXT        Move msg text               v102
         LA    R2,MACLIST+111      -> last byte from MTEXT area    v210
         LA    R0,32               # char to check backwards       v210
*
WRK223   EQU   *                   Only look backwards to col 80   v210
         CLI   0(R2),C' '          Try to find last non-blank      v210
         BNE   WRK226              Found it                        v210
         BCTR  R2,0                -> prev char                    v210
         BCT   R0,WRK223           Keep scanning                   v210
*
WRK226   EQU   *                                                   v210
         LA    R2,1(,R2)           -> first blank after last char  v210
         MVC   0(8,R2),=C''',USER=('                               v210
         MVC   8(12,R2),BLANKS      Ensure trailer initted         v210
         MVC   8(7,R2),WREUSER      Max for TSO userid is 7        v210
         LA    R1,8+7(,R2)          -> max end of trt              v210
         TRT   8(7,R2),BLANK        Look for end of userid         v210
         MVI   0(R1),C')'           Move closing                   v210
         MVI   1(R1),C' '           Plus 1 blank                   v210
         LA    R0,MACLIST           -> start of msg area           v210
         SR    R1,R0                Compute length of msg          v210
         LA    R1,1(,R1)            Account for blank at end       v210
         XC    MACLIST(4),MACLIST   Clear len, flags               v210
         STH   R1,MACLIST           Insert the msg length          v210
*
         LA    R1,MACLIST
         SR    R0,R0
         SVC   34                      Issue MGCR SVC
         B     WRK280
*
*-- Send the msg response to the system operator
*
WRK230   EQU   *
         MVC   MACLIST(WTOMSGL),WTOMSG
         MVC   MACLIST+4(4),=C'From'
         MVC   MACLIST+9(8),WREORIG    Move originating userid
         TRT   MACLIST+9(9),BLANK      Look for end of orig userid
         MVI   0(R1),C':'
         LA    R1,2(,R1)               -> area for msg
         MVC   0(104,R1),WRETXT        Move msg text               v102
         WTO   ,MF=(E,MACLIST)
         B     WRK280
*
*-- Start a link (via a local or remote command)
*
WRK240   EQU   *
         L     R2,WREUSER              -> LINKTABL entry of START cmd
         BAL   R14,SLNK000             Attach the link driver
         B     WRK280
*
*-- Clean up spent WRE
*
WRK280   EQU   *
         SPKA  0                       In case WRE isin CSA        v220
         L     R8,WRENEXT              -> next WRE in chain
         SR    R15,R15                 Clear for IC                v220
         IC    R15,WRESP               Get subpool number          v220
         LA    R0,WRESIZE              Size of this WRE            v220
*
         NJETRACE TYPE=TRCFWRE                                     v220
         STCM  R10,7,1(R14)            Identify trace entry        v220
         LA    R2,*                                                v220
         STCM  R2,7,5(R14)             Addr of Freemain to trace   v220
         ST    R0,8(,R14)              Len to trace                v220
         ST    R6,12(,R14)             addr to trace               v220
         STC   R15,8(,R14)             Trace subspool              v220
         MVI   WRESP,X'FF'             Mark stg as freed           v220
*
         FREEMAIN RU,                  Free the  WRE                   x
               LV=(0),                                                 x
               A=(6),                                                  x
               SP=(15)                                             v220
         SPKA  X'80'                                               v220
*
*-- Done processing a WRE; get another
*
WRK290   EQU   *
         LTR   R6,R8                   Get next WRE to distribute
         BNZ   WRK030                  Yes have an addr            v220
         B     MAIN010                 All done with WREs
*
*
* Registered User Service Support Notes                            v220
*
* The registered user service allows an outside address space
* operating in the same MVS system as NJE38, to 'register' or
* establish a relationship with NJE38 where messages that would
* ordinarily be sent to a user terminal are instead queued in
* storage and presented to the outside address space upon request.
*
* Users wishing to use this service call the NJERLY interface which
* is responsible for establishing the relationship with NJE38. This
* is done using WREs and cross-memory POST.  In this way, a batch,
* TSO, or STC address space can capture message traffic destined
* for it before it would arrive at a terminal, and thereby process
* this message or display it in the manner of their choosing.
*
* WREs created by NJERLY are always in CSA.  When they are used to
* request service of NJE38, they place the WRE on the NJ38SWAP
* compare and swap chain just like any other outside requester and
* post NJEINIT's CSA ECB.  NJEINIT then acts on the request.
*
* NJEINIT never frees the WRE created by NJERLY.  That is NJERLY's
* responsibility.
*
* For some functions of the service, the request is ignored if
* important information is missing (unlikely) such as ASCB address
* of NJERLY, or the WRE address.  Ignoring the request is all that
* can be done since without either of those pieces, NJEINIT cannot
* issue CM POST back to the NJERLY space to let it know of the error.
*
* When a user joins the service, he registers.  NJEINIT will create
* a REGUSERB control block to establish the registration and hold
* the NJERLY requester'e WRE and ASCB address.
*
* Once a user (userid) has registered, any message traffic inbound
* destined for that user will be queued in NJE38 storage and chained
* from REGUSERB,  The user can then request a message be returned
* one per request.  A post code of 4 (ERNOMSG) is used to indicate
* no messages are queued.
*
* When the user wants to stop using the service, it 'deregisters',
* causing NJEINIT to freemain any queued messages for the user and
* releasing the REGUSERB.  Message traffic destined for that user
* resumes being presented to the terminal as before.
*
* In the comments below, the 'registered user WRE' refers to the
* WRE created by NJERLY in CSA by the user address space.
*
*
*
*- WREREG
*- Register a user for queued message services
*
*- Who requests this service: user address space via NJERLY
*
*- Steps:
*    1. Ensure userid is not already registered on REGUSERB chain.
*    2. Create a new REGUSERB for this user
*    3. Issue CM POST to registered user space, function complete.
*
*
*  Notes: - On entry, registered user WRE is in R6.
*         - Registered users WREs are not freemained; we are not the
*            owner.
*         - If the registered user WRE has no ASCB addr, we have no
*            choice but to ignore the request.
*
WRK300   EQU   *
         L     R8,WRENEXT              -> next WRE                 v220
         XC    WRENEXT,WRENEXT         Clear next next ptr because v220
*                                       this is a registration WRE v220
*                                       and wont be freemained herev220
         CLC   WREASCB,=A(0)           Is ASCB present?            v220
         BE    WRK810                  No, invalid. Can't respond  v220
*
         ICM   R1,15,REGUSER           -> first REGUSER            v220
         BZ    WRK320                  None, let's start a chain   v220
         USING REGUSERB,R1                                         v220
         LA    R0,ERDUPUSR             Assume duplicate user error v220
*
WRK310   EQU   *                                                   v220
         CLC   REGUSRID,WREUSER        Is this user already reg?   v220
         BE    WRK800                  Yes, post the error in R0   v220
         ICM   R1,15,REGNEXT           Keep looking                v220
         BNZ   WRK310                                              v220
*
WRK320   EQU   *                                                   v220
         GETMAIN RU,                   Get storage for a REGUSER   v220x
               LV=REGSIZE,                                         v220x
               SP=2                                                v220
         XC    0(REGSIZE,R1),0(R1)     Init stg                    v220
         MVC   REGEYE,=CL4'REGU'       Set eye                     v220
         MVC   REGUSRID,WREUSER        Userid to be registered     v220
         ST    R6,REGWRE               Save ptr to registration WREv220
         MVC   REGNEXT,REGUSER         Chain other REGUSERs to thisv220
         ST    R1,REGUSER              This REGUSER is first       v220
         DROP  R1                      REGUSERB                    v220
         SR    R0,R0                   Set RC=0 success            v220
         B     WRK800                  User successfully registeredv220
*
*- WREDREG
*- Deregister a user from queued message services
*
*- Who requests this service: user address space via NJERLY
*
*- Steps:
*    1. Locate the REGUSERB for the userid
*    2. Get the chain anchor for queued message WREs, if any
*    3. Freemain the REGUSERB.
*    4. Freemain each queued message WRE
*    5. Issue CM POST to registered user space, function complete.
*
*  Notes: - On entry, registered user WRE is in R6.
*         - Registered users WREs are not freemained; we are not the
*            owner.
*         - If the registered user WRE has no ASCB addr, we have no
*            choice but to ignore the request.
*
WRK350   EQU   *
         L     R8,WRENEXT              -> next WRE                 v220
         XC    WRENEXT,WRENEXT         Clear next next ptr because v220
*                                       this is a registration WRE v220
*                                       and wont be freemained herev220
         CLC   WREASCB,=A(0)           Is ASCB present?            v220
         BE    WRK810                  No, invalid. Can't respond  v220
*
         LA    R0,ERUSERNF             Assume user not found       v220
         LA    R2,REGUSER              -> 0th REGUSER entry        v220
         ICM   R1,15,REGUSER           -> first REGUSER            v220
         BZ    WRK800                  None, user indeed isnt foundv220
         USING REGUSERB,R1                                         v220
*
WRK360   EQU   *                                                   v220
         CLC   REGUSRID,WREUSER        Is this user we want?       v220
         BE    WRK370                  Yes                         v220
         LR    R2,R1                   Save this REGUSER ptr       v220
         ICM   R1,15,REGNEXT           Get next REGUSER and continuv220
         BNZ   WRK360                                              v220
         B     WRK800                  Exit with user not found    v220
*
WRK370   EQU   *                                                   v220
         MVC   REGNEXT-REGUSERB(,R2),REGNEXT unchain R1 REGUSER    v220
         L     R2,REGMSGQ              -> MSG WRE chain for user   v220
         DROP  R1                      REGUSERB                    v220
*
         FREEMAIN RU,                  Free storage for a REGUSERB v220x
               LV=REGSIZE,                                         v220x
               A=(1),                                              v220x
               SP=2                                                v220
*
WRK380   EQU   *                                                   v220
         LTR   R1,R2                   Were any WREs chained?      v220
         BZ    WRK390                  No, we're done              v220
         L     R2,WRENEXT-WRE(,R2)     -> next WRE                 v220
         LA    R0,WRESIZE              Get size of WRE             v220
*
         NJETRACE TYPE=TRCFWRE                                     v220
         STCM  R10,7,1(R14)            Identify trace entry        v220
         LA    R15,*                                               v220
         STCM  R15,7,5(R14)            Addr of Freemain to trace   v220
         STM   R0,R1,8(R14)            Len, stg addr to trace      v220
         MVI   8(R14),2                Trace subspool              v220
         MVI   WRESP-WRE(R1),X'FF'     Mark stg as freed           v220
*
         FREEMAIN RU,                  Free storage for a WRE      v220x
               LV=(0),                                             v220x
               A=(1),                                              v220x
               SP=2                                                v220
         B     WRK380                  Free entire chain           v220
*
WRK390   EQU   *                                                   v220
         SR    R0,R0                   Set RC=0 success            v220
         B     WRK800                  User successfully deregisterv220
*
*
*- WREQRM
*- Queue a message destined for a registered user
*
*- Who requests this service: Internal by NJEINIT, NJECMX, NJEDRV
*   as message traffic arrives and needs to be queued.
*
*- Steps:
*    1. Locate the REGUSERB for the userid
*    2. If REGUSERB is not found, userid is not registered. Exit
*        with CC=0 and allow the message to go to the user terminal.
*    3. Get the registration WRE address from REGUSERB, exit if none.
*    4. Add this queued message WRE (in R6) to the queued message
*        chain REGMSGQ (in REGUSERB). Do not freemain this WRE!
*    5. Issue CM POST to registered user space that message is avail.
*
*  Notes: - On entry, a queued message WRE is in R6.
*         - The WREs are added to the start of the chain (REGMSGQ)
*           because they come to us in reverse order of issuance.
*           This puts them back in the right order
*
WRK400   EQU   *
         L     R8,WRENEXT              -> next WRE                 v220
         ICM   R3,15,REGUSER           -> first REGUSER            v220
         BZ    WRK810                  No one registered           v220
         USING REGUSERB,R3                                         v220
*
WRK410   EQU   *                                                   v220
         CLC   REGUSRID,WREUSER        Is this user the one?       v220
         BE    WRK420                  Yes                         v220
         ICM   R3,15,REGNEXT           Keep looking                v220
         BNZ   WRK410                                              v220
         B     WRK810                  Can't find REGUSER          v220
*
WRK420   EQU   *                                                   v220
         ICM   R4,15,REGWRE            -> user's registration WRE  v220
         BZ    WRK810                  Ignore if not there         v220
*
         MVC   WRENEXT,REGMSGQ         Add chain to new WRE        v220
         ST    R6,REGMSGQ              Add WRE to anchor           v220
         LR    R6,R4                   User registration WRE to R6 v220
         SR    R0,R0                   Indicate success            v220
         B     WRK800                  Tell user msg pending       v220
*                                                                  v220
*                                                                  v220
*- WREDRM
*- Dequeue message for a registered user when they request it
*
*- Who requests this service: user address space via NJERLY
*
*- Steps:
*    1. Locate the REGUSERB for the userid
*    2. If REGUSERB is not found, userid is not registered. Issue
*        error to requester.
*    3. Get the first queued message WRE from REGUSERB, issue
*        ERNOMSG error if nothing queued.
*    4. Copy the message text from the queued message WRE into the
*        registered user WRE.
*    5. Issue CM POST to registered user space, function complete.
*
*  Notes: - On entry, the registered user WRE is in R6.
*
*
WRK450   EQU   *
         L     R8,WRENEXT              -> next WRE                 v220
         XC    WRENEXT,WRENEXT         Clear next next ptr because v220
*                                       this is a registration WRE v220
*                                       and wont be freemained herev220
         ICM   R3,15,REGUSER           -> first REGUSER            v220
         BZ    WRK810                  No one registered           v220
         USING REGUSERB,R3                                         v220
*
WRK460   EQU   *                                                   v220
         CLC   REGUSRID,WREUSER        Is this user the one?       v220
         BE    WRK470                  Yes                         v220
         ICM   R3,15,REGNEXT           Keep looking                v220
         BNZ   WRK460                                              v220
         B     WRK810                  Can't find REGUSER          v220
*
WRK470   EQU   *                                                   v220
         LA    R0,ERNOMSG              Assume no msgs queued       v220
         ICM   R5,15,REGMSGQ           -> first queued msg WRE     v220
         BZ    WRK800                  No msgs available           v220
*
         MVC   REGMSGQ,WRENEXT-WRE(R5) Remove 1st queued from chainv220
         DROP  R3                      REGUSERB                    v220
*
         MVC   WRETXT,WRETXT-WRE(R5)   Copy queued msg text to     v220
*                                       registered user WRE        v220
*
         LA    R0,WRESIZE              Get size of WRE             v220
         NJETRACE TYPE=TRCFWRE                                     v220
         STCM  R10,7,1(R14)            Identify trace entry        v220
         LA    R15,*                                               v220
         STCM  R15,7,5(R14)            Addr of Freemain to trace   v220
         ST    R0,8(,R14)              Len to trace                v220
         MVI   8(R14),2                Trace subspool              v220
         ST    R5,12(,R14)             Addr to trace               v220
         MVI   WRESP-WRE(R5),X'FF'     Mark stg as freed           v220
*
         FREEMAIN RU,                  Free Queued msg WRE         v220x
               LV=(0),                                             v220x
               A=(5),                                              v220x
               SP=2                                                v220
*
         SR    R0,R0                   Indicate success            v220
         B     WRK800                  Tell user msg pending       v220
*
*
WRK800   EQU   *                       USING WRE,R6                v220
         L     R7,WREASCB              -> ASCB of requestor        v220
         LA    R1,WREECB               -> WRE's ECB                v220
*
         MVC   MACLIST(POSTL),POST     Move macro model            v220
         POST  (1),(0),                Post requestor's ECB        v220x
               ASCB=(7),                                           v220x
               ERRET=WRK810,                                       v220x
               ECBKEY=0,                                           v220x
               MF=(E,MACLIST)                                      v220
*
WRK810   EQU   *                                                   v220
         B     WRK290                  All done with WRE           v220
         DROP  R6                      WRE                         v220
*
*-- Address space Communications ECB was posted
*
COMM000  EQU   *
         L     R4,COMMAREA             -> Communications area
         USING IEZCOM,R4
         L     R5,COMCIBPT             -> CIB
         USING CIBNEXT,R5
         CLI   CIBVERB,CIBMODFY        Modify cmd?
         BE    MOD000                  Yes
         CLI   CIBVERB,CIBSTOP         Stop cmd?
         BE    STOP000                 Yes, let subtasks know
U0038    ABEND 38,DUMP,STEP            Shouldnt happen
*
MOD000   EQU   *
         MVC   CMDAREA,BLANKS          Init receiving area
         LH    R2,CIBDATLN             Get cmd image length
         BCTR  R2,0                    Adjust for execute
         EX    R2,MVMOD1               Move cmd image
         STC   R2,CMNDBLEN             IBM length of image to CMDBLOK
*
         QEDIT ORIGIN=COMCIBPT,BLOCK=(5)     Purge the CIB
*
         MVC   CMNDLINK,LCLNODE        Console operator
         MVC   CMNDUSER,=CL8'OP'        should get any responses
         L     R15,=A(NJECMD)          -> command processor
         BALR  R14,R15                 Go there
         B     MAIN010
*
MVMOD1   MVC   CMDAREA(0),CIBDATA      Executed instr
*
*
*
STOP000  EQU   *
         QEDIT ORIGIN=COMCIBPT,BLOCK=(5)     Purge the CIB
         DROP  R4                      IEZCOM
         DROP  R5                      IEZCIB
*
STOP010  EQU   *
         OI    NJFL1,NJF1STOP          Indicate STOP ordered
         L     R2,LINKS                -> 1st entry (LOCAL entry)  v211
         USING LINKTABL,R2
         L     R2,LNEXT                -> first remote link        v211
*
STOP020  EQU   *
         CLC   LTCBA,=A(0)             Is task active for link?
         BE    STOP030                 Zero, skip this one
*
         BAL   R14,GTW000              Get a WRE
         LR    R4,R1                   -> WRE
         USING WRE,R4
         MVI   WRECODE,X'81'           Code for drain link
         DROP  R4
         BAL   R14,PST000              Queue the WRE to link
*
STOP030  EQU   *
         ICM   R2,15,LNEXT             -> next LINKTABL entry
         BNZ   STOP020                 Scan them all
         DROP  R2                      LINKTABL
*
         B     MAIN010
*
*
*-- Open then Close NETSPOOL dataset to determine status
*
* NCBRTNCD/ERRCD after call to NCBOPEN
*    0474 = dataset not closed properly (do verify)
*    0874 = dataset not formatted
*
NET000   EQU   *
         ST    R14,SV14                Save return
*
         MVC   JFCBDCB(NSPOOLN),NSPOOL Move DCB for RDJFCB use
         LA    R1,JFCB                 -> JFCB return area
         ST    R1,JEXLST               Set addr in exit list
         MVI   JEXLST,X'87'            Set exlst for JFCB return
         LA    R1,JFCBDCB              -> DCB
         USING IHADCB,R1
         LA    R0,JEXLST               -> exit list
         STCM  R0,7,DCBEXLSA           Store it into DCB
         DROP  R1
*
         MVC   MACLIST(RDJFCBL),RDJFCB Move model
         RDJFCB JFCBDCB,MF=(E,MACLIST) Get NETSPOOL DSN
*
         LA    R3,NCB1
         USING NCB,R3
*
         NSIO  TYPE=OPEN,              Open NETSPOOL                   x
               NCB=(R3),                                           v210x
               ENTRY=ANJESPL                                       v210
         LTR   R15,R15
         BZ    NET040
         BAL   R14,FMT000
*
NET040   EQU   *
         NSIO  TYPE=CLOSE,                                             x
               NCB=(R3),                                           v210x
               ENTRY=ANJESPL                                       v210
         DROP  R3
         TM    NJFL1,NJF1VSER          Did VSAM error occur?
         BZ    NET090                  No
         CLC   LASTRC(2),=X'0474'      NETSPOOL needs verify?
         BE    NET080
         CLC   LASTRC(2),=X'0874'      NETSPOOL not formatted?
         BNE   NET070
         MVC   MACLIST(WTOMSGL),WTOMSG Move macro model
         MVC   MACLIST+4(L'NJE007I),NJE007I  Not formatted msg
         WTO   ,MF=(E,MACLIST)
         B     NET090
*
NET070   EQU   *
         MVC   MACLIST(WTOMSGL),WTOMSG Move macro model
         MVC   MACLIST+4(L'NJE006I),NJE006I  Open failed
         WTO   ,MF=(E,MACLIST)
         B     NET090
*
NET080   EQU   *
         MVC   MACLIST(WTOMSGL),WTOMSG Move macro model
         MVC   MACLIST+4(L'NJE008I),NJE008I  Do verify
         WTO   ,MF=(E,MACLIST)
         MVC   MACLIST(WTOMSGL),WTOMSG Move macro model
         MVC   MACLIST+4(L'NJE009I),NJE009I  verify complete
         WTO   ,MF=(E,MACLIST)
*
NET090   EQU   *
         TM    NJFL1,NJF1VSER          Set CC: Did VSAM error occur?
         L     R14,SV14                Reload return
         BR    R14                     Return
*
ERR999   EQU   *
         WTO   'NJE999I NJE38 is already active'
*
QUIT000  EQU   *
         ESTAE 0                       Turn off ESTAE
*
         TTIMER CANCEL                 Cancel the timer
*
         FREEMAIN RU,SP=1              Free all CONFIG related stg
         FREEMAIN RU,SP=2              Free all WRE related stg
*
QUIT020  EQU   *
         DELETE EP=NJECMX              Delete command processor
         DELETE EP=NJESPOOL            Delete spool interface      v210
*
         ICM   R1,15,ARQESTG           -> RQE stg area
         BZ    QUIT030                 Skip free if none           v212
         FREEMAIN RU,                  Free it                         x
               LV=RQESZ*RQELIM,                                        x
               A=(1)
*
QUIT030  EQU   *                                                   v212
         ICM   R1,15,ATRACE            -> Trace table stg          v212
         BZ    QUIT070                 Skip free if none           v212
         FREEMAIN RU,                  Free it                     v212x
               LV=TRACESZ*1024,                                    v212x
               A=(1)                                               v212
*
QUIT070  EQU   *
         TM    NJFL1,NJF1ENQ           Is NJE38 ENQ active?
         BZ    QUIT080                 No
         LA    R5,NJERNAME             -> RNAME
         MVC   MACLIST(ENQL),ENQ       Move macro model
         DEQ   (NJE38Q,(5),56,SYSTEM),                                 x
               RET=NONE,                                               x
               MF=(E,MACLIST)
*
QUIT080  EQU   *
         ICM   R5,15,CSABLK            -> CSA stg area
         BZ    QUIT090                 Not present
*
         SPKA  0
*
         FREEMAIN RU,LV=NJ38CSAZ,A=(5),SP=241  Free CSA area
         XC    CSABLK,CSABLK
*
         SPKA  X'80'
*
QUIT090  EQU   *
         LR    R1,R10                  -> NJEWK main work area page
         L     R13,4(,R13)             -> caller's sa
         FREEMAIN RU,                                                  x
               LV=4096,                                                x
               A=(1)
         LM    R14,R12,12(R13)         Reload system's regs
         XR    R15,R15                 RC=0
         BR    R14                     Return
*
U0039    EQU   *
         STM   R0,R1,DBLE              Save regs across abend SVC
         ABEND 39,DUMP,STEP
*
         LTORG
*                  HHMMSSTH
         DS    0D                                                  v200
ATTDLY   DC    CL8'00000050'           1/2 sec
*
EXTRACT  EXTRACT MF=L
EXTRACTL EQU   *-EXTRACT
ESTAE    ESTAE 0,MF=L
ESTAEL   EQU   *-ESTAE
*
ENQ      ENQ   (0),MF=L
ENQL     EQU   *-ENQ
*
DEQ      DEQ   (0),MF=L
DEQL     EQU   *-DEQ
*
RDJFCB   RDJFCB 0,MF=L
RDJFCBL  EQU   *-RDJFCB
*
NJE38Q   DC    CL8'NJE38'
NJERCON  DC    CL8'NJEINIT'
*
NSPOOL   DCB   DDNAME=NETSPOOL,DSORG=PS,MACRF=GL,EXLST=0
NSPOOLN  EQU   *-NSPOOL
*
*                456789012345678901234567890123456789012345678901
NJE000I  DC    C'NJE000I NJE38  &VERS'
NJE001I  DC    C'NJE001I Initialization complete for local node'
NJE006I  DC    C'NJE006I Open failed for DD NETSPOOL'
NJE007I  DC    C'NJE007I NETSPOOL dataset has not been formatted'
NJE008I  DC    C'NJE008I The NETSPOOL dataset required verification befx
               ore start-up'
NJE009I  DC    C'NJE009I Verification complete.  Please restart NJE38'
NJE010I  DC    C'NJE010I Line xxx is drained'
*
         DROP  R12
*
*********************
*  N J E C O M      *               NJECOM hosts small routines and
*                   *               frequently used constants that
*  Common routines  *               are available to all NJExxx csects
*  and constants    *               via base register 11
*                   *
*********************
*
NJECOM   CSECT
         DC    A(0)                 No branch around constants
         DC    AL1(23)                LENGTH OF EYECATCHERS
         DC    CL9'NJECOM'
         DC    CL9'&SYSDATE'
         DC    CL5'&SYSTIME'
         USING NJECOM,R11
         USING NJEMWK,R10
*
* FLNK000 - Locate a link table entry by link name
*
*  Entry:  R1 -> Link name to find (CL8 field padded with blanks)
*  Exit:   CC=0 link was not found
*          CC<>0 link table entry address is in R2
*
*
*
FLNK000  EQU   *
         L     R2,LINKS                -> 1st entry (LOCAL entry)  v211
         USING LINKTABL,R2
         L     R2,LNEXT                -> first remote link        v211
*
FLNK010  EQU   *
         CLC   LINKID,0(R1)            Find the link entry by name
         BE    FLNK020                 Got it
         ICM   R2,15,LNEXT             -> next LINKTABL entry
         BZR   R14                     Exit CC=0 if not found
         B     FLNK010                 Keep searching
         DROP  R2                      LINKTABL
*
FLNK020  EQU   *
         LTR   R2,R2                   Set CC non-zero
         BR    R14                     Return w/LINKTABL entry -> R2
*
* RLNK000 - Locate a name in the route table
*
*  Entry:  R1 -> Routed name to find (CL8 field padded with blanks)
*  Exit:   CC=0 link was not found
*          CC<>0 Associated link name address is in R1
*          CC<>0 Named route address is in R15
*
*-- First determine if the route name we are looking up is actually
*-- a link name.
*
RLNK000  EQU   *
         ICM   R15,15,ROUTES       -> RTE list                     v211
         BZR   R14                 Exit CC=0 if no RTE list        v211
         USING RTE,R15                                             v211
*
         L     R2,LINKS            1st entry (LOCAL entry)         v211
         USING LINKTABL,R2
         ICM   R2,15,LNEXT         Skip over local entry           v211
         BZR   R14                 Fail the request if none        v211
         SR    R0,R0               R0=0 assume name not a link     v211
*
RLNK010  EQU   *                                                   v211
         CLC   LINKID,0(R1)        Find the link entry by name     v211
         BE    RLNK020             Got it                          v211
         ICM   R2,15,LNEXT         -> next LINKTABL entry          v211
         BNZ   RLNK010             Keep looking                    v211
         B     RLNK030             Didn't find a matching link     v211
         DROP  R2                  LINKTABL                        v211
*
*-- Here if route we want is a link name too (dont use wildcards)  v211
*
RLNK020  EQU   *                                                   v211
         BCTR  R0,0                Indic route is explicit link nm v211
*                                                                  v211
*-- Search the RTEs for the route name                             v211
*                                                                  v211
RLNK030  EQU   *
         STM   R4,R7,12(R13)       Save work regs                  v211
*
RLNK040  EQU   *                                                   v211
         LA    R4,ROUTNAME         -> name from route list         v211
         LA    R5,8                max length                      v211
         LR    R6,R1               -> selected name to locate      v211
         LR    R7,R5               copy length                     v211
         CLCL  R4,R6               Did we locate the name?         v211
         BE    RLNK400             Yes, exact match                v211
         LTR   R0,R0               Must be explicit link name?     v211
         BNZ   RLNK050             Yes, no wildcard checking       v211
         CLI   0(R4),C'*'          Wildcard was in the name?       v211
         BE    RLNK400             Then we matched to that point   v211
*
RLNK050  EQU   *
         ICM   R15,15,ROUTPTR      -> Next route entry             v211
         BNZ   RLNK040             Keep looking                    v211
         LM    R4,R7,12(R13)       Restore work regs               v211
         BR    R14                 No matching route               v211
*
*-- Found the RTE with a matching name, now determine what link    v211
*-- to route to.                                                   v211
*
RLNK400  EQU   *                                                   v211
         LM    R4,R7,12(R13)       Restore work regs               v211
         LA    R0,4                # possible routed-to names      v211
         LA    R1,ROUTNEXT         -> first possible name          v211
*
RLNK410  EQU   *                                                   v211
         L     R2,LINKS            -> first LINKTABL entry         v211
         USING LINKTABL,R2                                         v211
         ICM   R2,15,LNEXT         Skip over local entry           v211
         BZR   R14                 Fail the request if none        v211
*
RLNK420  EQU   *                                                   v211
         CLC   0(8,R1),BLANKS      No route-to name?               v211
         BE    RLNK499             Fail the request                v211
         CLC   0(8,R1),LINKID      Look for destination link       v211
         BE    RLNK440             Found it                        v211
         ICM   R2,15,LNEXT         -> next LINKTABL entry          v211
         BNZ   RLNK420             Keep searching                  v211
*
RLNK430  EQU   *                                                   v211
         LA    R1,8(,R1)           Next alternate route-to         v211
         BCT   R0,RLNK410          Rescan for matching link        v211
         B     RLNK499             None found, fail the request    v211
*
RLNK440  EQU   *                                                   v211
         TM    LFLAG,LCONNECT      Is the link active?             v211
         BZ    RLNK430             N, try next route-to link       v211
         DROP  R2,R15              LINKTABL, RTE                   v211
*
RLNK490  EQU   *                                                   v211
         CLI   *,0                 Set CC to non-zero              v211
         BR    R14                 Return with link name -> R1     v211
*
RLNK499  EQU   *                                                   v211
         CLI   *+1,0               Set CC to 0                     v211
         BR    R14                 No matching route/act link foundv211
*
* SLNK000 - Start a link
*
*  Entry:  R2 -> LINKTABL entry to be started
*  Exit:   CC=0 link was started
*          CC<>0 link was already started
*
*
*
         USING LINKTABL,R2
SLNK000  EQU   *
         STM   R14,R9,BALRSAVE         Save regs used
         CLC   LTCBA,=A(0)             Is link already started?
         BNE   SLNK090                 Exit w/ CC<>0 if addr present
*
         XC    LTRMECB,LTRMECB         Clear from any prior use
         LA    R1,INITPARM             -> INITPARM mapping area
         ST    R1,LPOINTER             Pass addr of area to subtask
         L     R5,=A(NJEDMP)           -> ESTAI exit
         LA    R9,LTRMECB
         LR    R1,R2                   LINKTABL entry is parameter
*
         MVC   MACLIST(ATTACHL),ATTACH Move macro model
         ATTACH EP=NJEDRV,             Attach                          X
               SZERO=YES,              Ok to share SP 0                X
               SHSPL=SPLIST,           Shared subpool list         v220X
               DPMOD=0,                Run task same prty              X
               SM=SUPV,                Run task in Supervisor state    X
               KEY=PROP,               Run task in key 8               X
               ECB=(R9),               Subtask termination ECB         X
               ESTAI=((5),(10)),       ESTAI exit, work area is param  X
               SF=(E,MACLIST),         Attach macro plist              X
               MF=(E,(1))              Param plist area
*
         ST    R1,LTCBA                Save attached TCB address
         SR    R15,R15                 Set CC=0
         B     SLNK090                 Exit with task attached
         DROP  R2                      LINKTABL
*
SLNK090  EQU   *
         LM    R14,R9,BALRSAVE         Restore caller regs
         BR    R14                     Exit with CC set
*
SPLIST   DC    X'02'                   Number of shared subpools   v220
         DC    X'01'                    Share SP 1                 v220
         DC    X'02'                    Share SP 2                 v220
         DS    X                        Reserved                   v220
*
*-- Get a new command type WRE
*
*-- Entry:  None
*   Exit:   R1 -> WRE
*
*
GTW000   EQU   *
         ST    R14,SV14            Save return addr
         GETMAIN RU,               Get CSA for WRE TYPE=WRECMD         x
               LV=WRESIZE,                                         v220x
               SP=2                                                v220
         XC    0(WRESIZE,R1),0(R1)    Clear stg area               v220
         USING WRE,R1
         MVI   WRESP,2             Save subpool                    v220
         MVI   WRETYPE,WRECMD      CMD/MSG WRE
*
         NJETRACE TYPE=TRCGWRE
         STCM  R10,7,1(R14)        Identify trace entry            v220
         MVC   5(3,R14),SV14+1     Addr of GTW000 caller           v220
         STM   R0,R1,8(R14)        Len, stg addr to trace          v220
         MVI   8(R14),2            Trace subpool #                 v220
         DROP  R1
         L     R14,SV14            Load return addr
         BR    R14
*
*-- Queue the WRE on the Link and post link's ECB
*-- Caller must be PSW key 0
*
*-- Entry:  R2 -> LINKTABL entry
*--         R4 -> WRE
*-- Exit:   None
*
PST000   EQU   *
         USING LINKTABL,R2
         USING WRE,R4
         ST    R14,SV14            Save return addr
         LM    R0,R1,LWRESWAP      Get first WRE ptr, sync count
*
PST020   EQU   *
         ST    R0,WRENEXT          First WRE becomes next
         LA    R5,1(,R1)           Incr synchronization count
         CDS   R0,R4,LWRESWAP      Update LINK WRE anchor, sync
         BC    7,PST020            Gotta try again
*
         LA    R1,LECB             -> link task notification ECB
         POST  (1)                 Tell subtask WRE is queued
         L     R14,SV14            Load return addr
         BR    R14
*
         DROP  R2                  LINKTABL
         DROP  R4                  WRE
*
*
*-- Message response to console or local TSO user
*
*=== NOTE ===
*=== At present this routine (RSP000) is not called or used, but
*=== is retained here for possible future use.
*
*
*-- Entry:  Area "MACLIST" contains a WTO format msg
*           Area CMNDUSER=BLANKS send to console
*           Area CMNDUSER=userid send to that userid
*-- Exit:   None
*
*           Area "CMDAREA" is used by this call.
*
*
RSP000   EQU   *
         ST    R14,SV14                 Save return addr
         CLC   CMNDUSER,BLANKS          Is there a userid?
         BE    RSP010                   No, respond to console
         CLC   CMNDUSER,=CL8'OP'        Respond to operator
         BE    RSP010                   Y
*
         LA    R15,CMNDUSER             -> userid to locate
         BAL   R14,USR800               See if TSO user logged on
         BZ    RSP090                   Skip msg if not
         MVC   CMDAREA,MACLIST+4        Save message text
         MVC   MACLIST+4(4),=C'SE '''
         MVC   MACLIST+8(104),CMDAREA                              v102
         MVC   MACLIST+112(8),=C''',USER=('                        v102
         MVC   MACLIST+120(12),BLANKS     Ensure trailer initted   v102
         MVC   MACLIST+120(7),CMNDUSER    Max for TSO userid is 7  v102
         LA    R1,MACLIST+127                                      v102
         TRT   MACLIST+120(7),BLANK                                v102
         MVI   0(R1),C')'
         MVI   1(R1),C' '
         MVC   MACLIST(4),=AL2(129,0)   max len + 4 overhead       v102
*
         SPKA  0
         LA    R1,MACLIST
         SR    R0,R0
         SVC   34                       Issue MGCR SVC
         SPKA  X'80'
         B     RSP090
*
RSP010   EQU   *
         WTO   ,MF=(E,MACLIST)
*
RSP090   EQU   *
         L     R14,SV14                 Reload return addr
         BR    R14
*
*-- Search CSCB chain to see if TSO user is logged on
*-- Entry:  R15->8-byte padded field containing TSO userid to find
*-- Exit:  CC=0  user was not logged on
*--        CC<>0 user is logged on
*
USR800   EQU   *
         CLC   =CL8'OP',0(R15)     Is the userid the operator?
         BE    USR890              Yes, let it thru
         L     R1,16               Get CVT ptr
         USING CVT,R1
         L     R1,CVTASCBH         -> highest prty ASCB
         USING ASCB,R1
*
USR810   EQU   *
         L     R2,ASCBCSCB         -> CSCB
         USING CSCB,R2
         LTR   R2,R2               Is there a CSCB?
         BZ    USR840              No, get next ASCB
*
USR820   EQU   *
         CLC   CHKEY,=XL8'00'      Jobname zeroed?
         BE    USR830              Y, skip this CSCB
         CLC   CHKEY,=CL8' '       Jobname is blank?
         BE    USR830              Y, skip this CSCB
         CLC   CHKEY,0(R15)        Is this the userid?
         BE    USR890              Yes
USR830   EQU   *
         L     R2,CHPTR            -> next CSCB
         LA    R2,0(,R2)           Clear high order
         LTR   R2,R2               Last CSCB?
         BNZ   USR820              No
         BR    R14                 Return with CC=0 (not found)
*
USR840   EQU   *
         L     R1,ASCBFWDP         -> next ASCB
         LTR   R1,R1               last one?
         BNZ   USR810              No
         BR    R14                 Return with CC=0 (not found)
*
USR890   EQU   *
         LTR   R14,R14             Set CC=non zero (userid found)
         BR    R14                 Return to caller
*
         DROP  R1                  ASCB
         DROP  R2                  CSCB
*
*-- Special code to intercept messages destined for                v220
*-- registered users                                               v220
*
*
REG000   EQU   *                                                   v220
         L     R2,AREGUSER         -> registered user anchor word  v220
         ICM   R2,15,0(R2)         -> registered user queue        v220
         BZR   R14                 No registered users             v220
*
         USING REGUSERB,R2                                         v220
REG010   EQU   *                                                   v220
         CLC   REGUSRID,0(R15)     Find a matching registered user v220
         BE    REG020              Found it                        v220
         ICM   R2,15,REGNEXT       -> next REGUSER entry           v220
         BNZ   REG010              Keep looking                    v220
         BR    R14                 Userid was not registered       v220
*
REG020   EQU   *                                                   v220
         ST    R14,SVR14R          Save return addr                v220
         BAL   R14,GTW000          Get a WRE                       v220
         LR    R4,R1                                               v220
         USING WRE,R4                                              v220
         MVI   WRETYPE,WREQRM      Queue registered msg WRE        v220
*
         MVC   WRELINK,LCLNODE     Target WRE to local node task   v220
         MVC   WREUSER,REGUSRID    Dest= registered user id        v220
         MVC   WREORIG,BLANKS      No originating node             v220
         MVC   WRETXT,BLANKS       Init first part                 v220
         MVC   WRETXT(5),=C'From '                                 v220
         MVC   WRETXT+5(8),WREORIG-WRE(R6)  From original msg      v220
         TRT   WRETXT+5(9),BLANK   Look for end of orig userid     v220
         MVI   0(R1),C':'                                          v220
         LA    R1,2(,R1)           -> area for msg                 v220
         MVC   0(104,R1),WRETXT-WRE(R6)  Copy msg text             v220
         MVI   WRETXTLN,L'WRETXT   Set the max possible len        v220
*
         SPKA  0                                                   v220
         L     R15,CSABLK          -> NJE38 CSA block              v220
         USING NJ38CSA,R15                                         v220
         LM    R0,R1,NJ38SWAP      Get first WRE ptr, sync count   v220
*
REG030   EQU   *                                                   v220
         ST    R0,WRENEXT          First WRE becomes next          v220
         LA    R5,1(,R1)           Incr synchronization count      v220
         CDS   R0,R4,NJ38SWAP      Update LINK WRE anchor, sync    v220
         BC    7,REG030            Gotta try again                 v220
*
         LA    R1,NJ38ECB          -> main task notification ECB   v220
         POST  (1)                 Wake him up                     v220
*
         SPKA  X'80'                                               v220
*
         DROP  R2,R4,R15           REGUSERB,WRE,NJ38CSA            v220
*                                                                  v220
REG090   EQU   *                                                   v220
         L     R14,SVR14R          Load return addr                v220
         LTR   R14,R14             Set non-zero CC                 v220
         BR    R14                 Ret w/CC non-zero (msg queued)  v220
*
*
*-- Format and display VSAM errors
*
FMT000   EQU   *
         STM   R14,R2,BALRSAVE         Save regs used
         MVC   MACLIST(WTOMSGL),WTOMSG
         MVC   MACLIST+4(L'NJE079I),NJE079I   Move msg text
         MVC   MACLIST+55(8),5(R12)    Move csect name
         TRT   MACLIST+55(9),BLANK     Look for end of csect name
         MVI   0(R1),C'+'
*
         LA    R15,0(,R14)  Clear high, Get addr of call to this rtn
         LA    R12,0(,R12)             Clear high byte
         SR    R15,R12                 Compute offset of call
         ST    R15,DBLE                Save to work area
         UNPK  TWRK(5),DBLE+2(3)       Add zones
         TR    TWRK(4),HEXTRAN-240     Display hex
         MVC   1(4,R1),TWRK            Move call offset to msg
*
         LA    R15,NCB1
         UNPK  TWRK(5),NCBRTNCD-NCB(3,R15)  Add zones
         TR    TWRK(4),HEXTRAN-240
         MVC   MACLIST+35(4),TWRK      Move rtncd/errcd
*
         UNPK  TWRK(3),NCBREQ-NCB(2,R15)  Add zones
         TR    TWRK(2),HEXTRAN-240
         MVC   MACLIST+45(2),TWRK      Move req code
*
         L     R1,NCBMACAD-NCB(,R15)   Get failing VSAM macro addr
         LA    R1,0(,R1)               Clear high byte
         S     R1,ANJESPL              offset into NJESPOOL rtn v210
         ST    R1,DBLE
         UNPK  TWRK(5),DBLE+2(3)       Add zones
         TR    TWRK(4),HEXTRAN-240     Display hex
         MVC   MACLIST+50(4),TWRK      Move NJESPOOL offset to msg
*
         MVC   LASTRC(2),NCBRTNCD-NCB(R15)  Save off rtncd/errcd
         OI    NJFL1,NJF1VSER          Indicate VSAM error occurred
*
         WTO   ,MF=(E,MACLIST)
*
FMT090   EQU   *
         LM    R14,R2,BALRSAVE         Restore caller regs
         BR    R14                     Exit with CC set
*
*
*
ATTACH   ATTACH SF=L
ATTACHL  EQU   *-ATTACH
POST     POST  0,ASCB=0,ERRET=0,MF=L                               v220
POSTL    EQU   *-POST                                              v220
WTOMSG   WTO   '                                                       x
                                             ',MF=L
WTOMSGL  EQU   *-WTOMSG
*
BLANKS   DC    CL120' '
NONBLANK DC    64X'FF',X'00',191X'FF'   TR Table to locate nonblank
BLANK    DC    64X'00',X'FF',191X'00'   TR Table to locate blanks
ASTER    DC    92X'00',X'FF',163X'00'   TR Table to locate asteriskv211
HEXTRAN  DC    CL16'0123456789ABCDEF'  Translate table
*                      1         2         3           4         5
*                456789012345678901234567890123 45678 90123456789012345
NJE079I  DC    C'NJE079I NETSPOOL RTNCD/ERRCD=X''0000'',REQ=01,O=1234,Mx
               MMMMMMM     '
*
         LTORG
*
*                                                                     *
***********************************************************************
**                                                                   **
**                        TASK ESTAI EXIT                            **
**                                                                   **
** This csect handles all abends trapped by ESTAE during the normal  **
** execution of the subtask.          This exit does not attempt     **
** any recovery other than to terminate processing.                  **
** An SVC dump is taken on abends.                                   **
**                                                                   **
** On entry:  R0=ESTAE provide entry code                            **
**            R1=SDWA address                                        **
**            R2=parameter passed on ESTAE macro                     **
**                                                                   **
**                                                                   **
** On exit: If SDWACLUP is 1, then no retry is allowed and this      **
**             exit will allow percolation back to system routines   **
**             to terminate the task.                                **
**                                                                   **
**          If SDWACLUP is 0, then retry is allowed.                 **
**                                                                   **
** Security:  N/A.                                                   **
**                                                                   **
** Register usage:                                                   **
**                                                                   **
**   R1  = SDWA address                                              **
**   R3  = SDWA address                                              **
**   R10 = Dynamic storage area base                                 **
**   R12 = This program base                                         **
**                                                                   **
**                                                                   **
**                                                                   **
***********************************************************************
*
NJEDMP   CSECT
         B     28(,R15)               BRANCH AROUND EYECATCHERS
         DC    AL1(23)                LENGTH OF EYECATCHERS
         DC    CL9'NJEDMP'
         DC    CL9'&SYSDATE'
         DC    CL5'&SYSTIME'
*
         LR    R12,R15                SET UP BASE REG
         USING NJEDMP,R12             ESTABLISH ADDRESSABILITY
         LR    R8,R14                 SAVE RETURN ADDRESS TO SYSTEM
*
         L     R10,0(,R1)             GET VALUE PASSED TO US (WORKA)
         USING NJEMWK,R10
         L     R11,ANJECOM            -> common code and constants
         USING NJECOM,R11
*
         LR    R3,R1                  SAVE R1 ENTRY CONTENTS
         USING SDWA,R3
         LR    R5,R0                  Save R0 entry code
*
         LTR   R3,R3                  Do we have an SDWA?
         BZ    NOSDWA                 Exit if no SDWA
         LA    R13,MVSSAVE            Save area
*
         MODESET MODE=SUP,            Run this ESTAI exit privileged   x
               KEY=ZERO                to access PSW -> storage
*
         MVC   MACLIST(WTOMSGL),WTOMSG
         L     R6,PSATOLD-PSA(0)      -> my TCB
         L     R5,TCBTIO-TCB(,R6)     -> TIOT
         MVC   MACLIST+4(8),0(R5)         Plug in job name
         MVC   MACLIST+14(5),=C'LINK '
         MVC   LKNAME,=CL8' '           Init receiving field
*
         L     R2,LINKS                -> 1st entry (LOCAL entry)  v211
         USING LINKTABL,R2
         ICM   R2,15,LNEXT             -> 1st non-lcl LINKTABL     v211
         BZ    LNK005                  Skip if not there           v211
*
LNK000   EQU   *
         CLM   R6,7,LTCBA+1             Look for TCB of failing link
         BE    LNK010                   Found it
         ICM   R2,15,LNEXT              -> next LINKTABL entry
         BNZ   LNK000                   Keep searching
*
LNK005   EQU   *                                                   v211
         MVC   MACLIST+14(5),=C'LMOD '
         MVC   MACLIST+19(8),=CL8'NJEINIT' Else it is main task
         OI    NJFL1,NJF1INIT           This is the NJEINIT task
         B     LNK020                   No TCB/link found
*
LNK010   EQU   *
         MVC   MACLIST+19(8),LINKID     Move link name
         MVC   LKNAME,LINKID            Save copy of link name
         DROP  R2
*
LNK020   EQU   *
         MVC   MACLIST+29(5),=C'ABEND'
         L     R5,SDWAABCC              GET ABEND CODE INFO WORD
         N     R5,=X'00FFF000'          KEEP ONLY THE SYSTEM CODE
         BZ    USERCDE                  NONE THERE, MUST BE A USER CODE
         C     R5,=X'00222000'          Operator cancel, no dump?
         BE    SDUMP040                 no
         C     R5,=X'00013000'          013-OPEN abend?            v211
         BE    SDUMP040                 no dump                    v211
*
         MVI   MACLIST+35,C'S'          INDICATE SYSTEM CODE
         UNPK  FWORK(5),SDWACMPC(3)     GET SYSTEM CMP CODE
         TR    FWORK(3),HEXTRAN-240
         MVC   FWORK+3(5),=CL5' '       CLEAR REST OF ABEND CODE
         B     NOREAS
*
USERCDE  EQU   *
         MVI   MACLIST+35,C'U'         INDICATE USER ABEND CODE
         L     R5,SDWAABCC             GET ABEND CODE
         N     R5,=X'00000FFF'         KEEP USER ABEND CODE
         CVD   R5,FSAVE                CONVERT CODE TO DECIMAL
         UNPK  FWORK(4),FSAVE          UNPK THE CODE
         OI    FWORK+3,X'F0'           FIX SIGN
         MVC   FWORK+4(2),=CL2' '      BLANKS AT END OF ABEND CODE
*
NOREAS   EQU   *
         MVC   MACLIST+36(6),FWORK     MOVE ABEND-REASON TO LINE
         MVC   ABCODE,MACLIST+36       Save a copy of formatted abcode
*
         WTO   ,MF=(E,MACLIST)
*
         MVC   MACLIST(WTOMSGL),WTOMSG
         MVC   MACLIST+4(3),=C'PSW'
         UNPK  FSAVE(9),SDWAEC1(5)    Add zones to PSW word 1
         TR    FSAVE(8),HEXTRAN-240
         MVC   MACLIST+10(8),FSAVE
         UNPK  FSAVE(9),SDWAEC1+4(5)  Add zones to PSW word 2
         TR    FSAVE(8),HEXTRAN-240
         MVC   MACLIST+19(8),FSAVE
*
         SR    R5,R5                   CLEAR FOR IC
         IC    R5,SDWAILC1             GET THE ILC
         CVD   R5,FWORK                MAKE DECIMAL
         MVC   MACLIST+29(3),=C'ILC'
         UNPK  MACLIST+33(2),FWORK     UNPK
         OI    MACLIST+34,X'F0'        FIX THE SIGN
*
         MVC   MACLIST+37(4),=C'INTC'
         UNPK  FWORK(5),SDWAINC1(3)    MAKE INTC DISPLAYABLE
         TR    FWORK(4),HEXTRAN-240
         MVC   MACLIST+42(4),FWORK     MOVE INTC TO LINE
*
         WTO   ,MF=(E,MACLIST)
*
         MVC   MACLIST(WTOMSGL),WTOMSG
         MVC   MACLIST+4(13),=C'DATA NEAR PSW'
         MVC   MACLIST+19(8),=CL8'UNAVAIL'  ASSUME WE CANT GET DATA
         L     R4,SDWAEC1+4            Get PSW IA
         LA    R4,0(,R4)               Clear high bit
         C     R4,=F'8'                1st 8 bytes of storage?
         BH    LOC010                  No, its higher than that
         SR    R4,R4                   Yes, just use 0
         B     LOC020
*
LOC010   EQU   *
         S     R4,=F'8'                BACK UP BEFORE INTERRUPT ADDR
*
LOC020   EQU   *
         LRA   R0,0(,R4)               Do we have access?
         BNZ   UNAVAIL                 No translation, better not
         LRA   R0,14(,R4)              Do we have access?
         BNZ   UNAVAIL                 No translation, better not
*
         ST    R4,FWORK                SAVE FOR CONVERSION
         UNPK  FSAVE(9),FWORK(5)       ADD ZONES TO ADDRESS
         TR    FSAVE(8),HEXTRAN-240    MAKE DISPLAYABLE HEX
         MVC   MACLIST+19(8),FSAVE     MOVE DISPLAYABLE
*
         MVC   FWORK(4),0(R4)          MOVE 4 WORDS AT PSW
         UNPK  FSAVE(9),FWORK(5)       ADD ZONES
         TR    FSAVE(8),HEXTRAN-240    MAKE DISPLAYABLE HEX
         MVC   MACLIST+29(8),FSAVE     MOVE TO LINE
*
         MVC   FWORK(4),4(R4)          MOVE 4 WORDS AT PSW
         UNPK  FSAVE(9),FWORK(5)       ADD ZONES
         TR    FSAVE(8),HEXTRAN-240    MAKE DISPLAYABLE HEX
         MVC   MACLIST+38(8),FSAVE     MOVE TO LINE
*
         MVC   FWORK(4),8(R4)          MOVE 4 WORDS AT PSW
         UNPK  FSAVE(9),FWORK(5)       ADD ZONES
         TR    FSAVE(8),HEXTRAN-240    MAKE DISPLAYABLE HEX
         MVC   MACLIST+47(8),FSAVE     MOVE TO LINE
*
         MVC   FWORK(4),12(R4)         MOVE 4 WORDS AT PSW
         UNPK  FSAVE(9),FWORK(5)       ADD ZONES
         TR    FSAVE(8),HEXTRAN-240    MAKE DISPLAYABLE HEX
         MVC   MACLIST+56(8),FSAVE     MOVE TO LINE
*
UNAVAIL  EQU   *
         WTO   ,MF=(E,MACLIST)
*----
         LA    R4,4                    4 ROWS OF REGISTERS
         LA    R5,SDWAGR00             POINT TO ABEND REGS
         LA    R6,REGLIST              POINT TO REGISTER ID LITERALS
*
GPR000   EQU   *                                                   v220
         MVC   MACLIST(WTOMSGL),WTOMSG
         MVC   MACLIST+4(8),0(R6)      MOVE REGISTERS ID
         LA    R15,MACLIST+13          WHERE 1ST REG GOES ON LINE
         LA    R14,4                   4 REGS PER LINE
*
GPR010   EQU   *                                                   v220
         UNPK  FSAVE(9),0(5,R5)        UNPK A REGISTER
         TR    FSAVE(8),HEXTRAN-240    MAKE DISPLAYABLE HEX
         MVC   0(8,R15),FSAVE          MOVE TO THE LINE
         LA    R15,10(,R15)            NEXT SPOT ON PRINT LINE
         LA    R5,4(,R5)               NEXT REGISTER
         BCT   R14,GPR010              KEEP DOING REGS             v220
         WTO   ,MF=(E,MACLIST)
         LA    R6,8(,R6)               NEXT REGISTER ID
         BCT   R4,GPR000               GO DISPLAY THE NEXT ROW     v220
*
*
SDUMP000 EQU   *
         MVI   DHDR,C' '
         MVC   DHDR+1(29),DHDR
         MVI   DHDR,29                IBM length of header
         L     R5,PSATOLD-PSA(0)      -> my TCB
         L     R5,TCBTIO-TCB(,R5)     -> TIOT
         MVC   DHDR+1(8),0(R5)        Use jobname in description
         MVC   DHDR+11(8),LKNAME      Use link name
         MVC   DHDR+21(7),ABCODE
*
         MVC   MACLIST(SDUMPL),SDUMP    MOVE SDUMP LIST TO WORK
         LA    R1,MACLIST
         SDUMP HDRAD=DHDR,              ISSUE SDUMP TO RECORD STATUS   x
               BUFFER=NO,                                              x
               QUIESCE=NO,                                             x
               SDATA=(RGN,CSA,LPA,SUM),                                x
               MF=(E,(1))
*
*
SDUMP040 EQU   *
         TM    NJFL1,NJF1INIT          Is this the NJEINIT task?
         BZ    SDUMP090                No
         ICM   R5,15,CSABLK            -> CSA stg area
         BZ    SDUMP090                Not present
*
         FREEMAIN RU,LV=16,A=(5),SP=241  Free CSA area
         XC    CSABLK,CSABLK
*
SDUMP090 EQU   *
         LR    R1,R3                  SDWA BACK TO R1
*                                 **  SDWA ADDR MUST BE IN R1 FOR SETRP
         SETRP RC=0,                  No retry                         X
               DUMP=NO                Suppress any further dumps
*
NOSDWA   EQU   *                  **  NO RETRY AVAILABLE (OR DESIRED)
         SR    R15,R15                REQUEST PERCOLATION
         LR    R14,R8                 RESTORE RETURN ADDRESS
         BR    R14                    RETURN TO SYSTEM
*
         LTORG
*
SDUMP    SDUMP MF=L
SDUMPL   EQU   *-SDUMP
*
REGLIST  DC    CL8'GR 0-3'
         DC    CL8'GR 4-7'
         DC    CL8'GR 8-11'
         DC    CL8'GR 12-15'
*
         LTORG
*
*
*
*********************
*  N J E C M D      *       Commands issued by TSO users via command
*                   *       module NJE38 also arrive here
*  MVS Modify cmd   *
*  processing       *
*                   *
*********************
*
NJECMD   CSECT
         B     28(,R15)               BRANCH AROUND EYECATCHERS
         DC    AL1(23)                LENGTH OF EYECATCHERS
         DC    CL9'NJECMD'
         DC    CL9'&SYSDATE'
         DC    CL5'&SYSTIME'
         STM   R14,R12,12(R13)
         LR    R12,R15                 Base
         USING NJECMD,R12              ADDRESS IT
         USING NJECOM,R11
         USING NJEMWK,R10
*
         ST    R13,NJECMDSA+4
         LA    R13,NJECMDSA
*
CMD000   EQU   *
         BAL   R14,LOC000          Announce command being executed
*
CMD010   EQU   *
         LA    R0,TGTCONS          Console gets response
         LA    R1,CMNDBLOK         -> local CMDBLOK area
         ST    R1,ACMDBLOK         Set addr in cmd parm list
         LA    R1,INITPARM         -> parm list
         L     R15,ANJECMX         -> Command processor
         BALR  R14,R15
         B     XITCMD00
*
*
LOC000   EQU   *
         CLC   CMNDUSER,=CL8'OP'       Command from operator?
         BER   R14                     Yes, skip location msg
*
         ST    R14,SV14                 Save return addr
         MVC   MACLIST(WTOMSGL),WTOMSG
         MVC   MACLIST+4(L'NJE005I),NJE005I
         LA    R1,MACLIST+4+L'NJE005I   -> next byte
         MVC   0(8,R1),LCLNODE         Local node
         TRT   0(9,R1),BLANK           Look for end
         MVI   0(R1),C'('
         MVC   1(8,R1),CMNDUSER        Local userid
         TRT   1(9,R1),BLANK           Look for end
         MVC   0(12,R1),=CL12') executing:'
         LA    R1,13(,R1)              -> area for msg
         SR    R15,R15                 Clear for IC
         IC    R15,CMNDBLEN            Len of cmd text
         C     R15,=F'50'              Allow 50 char max
         BL    *+8                     We're ok
         LA    R15,50                  Use 50
         EX    R15,MVCMTXT1            Move command text to msg
*
         WTO   ,MF=(E,MACLIST)         Issue location executing msg
*
LOC090   EQU   *
         L     R14,SV14                Reload return
         BR    R14                     Return
*
MVCMTXT1 MVC   0(0,R1),CMDAREA         executed instr
*
*
*
*
*
XITCMD00 EQU   *
         L     R13,4(,R13)         -> NJEREQ save area
         LM    R14,R12,12(R13)     Reload callers regs
         SR    R15,R15
         BR    R14                 Return to NJEREQ
*
         LTORG
*
*                456789012345678901234567890123456789012345678901
NJE005I  DC    C'NJE005I Location '             Location executing
*
*
*
*
***************
* TIMER       *                        THIS EXIT WILL KEEP THE JOB
* EXPIRATION  *                        ACTIVE EVERY 20 MINUTES, AND
* EXIT        *                        WILL KEEP THE JOB FROM ABENDING
***************                        WITH AN S 522 ABEND (WAIT LIMIT)
*
NJETMR   CSECT
         B     28(,R15)                BRANCH AROUND EYECATCHERS
         DC    AL1(23)                 LENGTH OF EYECATCHERS
         DC    CL9'NJETMR'
         DC    CL9'&SYSDATE'
         DC    CL5'&SYSTIME'
         STM   R14,R12,12(R13)
         LR    R12,R15
         USING NJETMR,R12
*
         STIMER REAL,                  RESET THE TIMER AGAIN           X
               (12),                   POINT TO THE EXIT ROUTINE       X
               DINTVL=INTVL            INTERVAL
*
         LM    R14,R12,12(R13)         RELOAD REGS
         SR    R15,R15
         BR    R14                     RETURN TO SYSTEM
*
         DS    0D
*                  HHMMSSTH
INTVL    DC    CL8'00200000'           20 MINUTE TIMER
*
         DROP  R12
         LTORG
*
*
***************                                                    v212
* GET         *                                                    v212
* TRACE       *                                                    v212
* ENTRY       *                                                    v212
***************                                                    v212
*
NJETRC   CSECT                                                     v212
         B     28(,R15)                BRANCH AROUND EYECATCHERS   v212
         DC    AL1(23)                 LENGTH OF EYECATCHERS       v212
         DC    CL9'NJETRC'                                         v212
         DC    CL9'&SYSDATE'                                       v212
         DC    CL5'&SYSTIME'                                       v212
         USING NJETRC,R15                                          v212
         LR    R0,R14                  Save return addr            v212
*
TRC000   EQU   *                                                   v212
         USING TRCCTL,R2                                           v212
         L     R1,TRCCURR              -> current trace slot       v212
         LA    R14,TRCSZ(,R1)          -> next slot                v212
         C     R14,TRCEND              At end of table?            v212
         BL    TRC010                  No                          v212
         L     R14,TRCSTRT             Y, wrap to beginning        v212
         LA    R14,TRCSZ(,R14)         -> Skip over first slot     v212
*
TRC010   EQU   *                                                   v212
         CS    R1,R14,TRCCURR          Set new current             v212
         BC    4,TRC000                CC=1; no match; try again   v212
*
         XC    0(TRCSZ,R14),0(R14)     Clear slot                  v212
         DROP  R2,R15                                              v212
*
         LR    R15,R0                  Load return addr to.. R15  !v212
         LM    R0,R2,20(R13)           Reload the rest             v212
         BR    R15                     Return via R15;             v212
*                                       New trace entry -> R14     v212
*
*
*
****  Main work area common
****  to all NJExxx CSECTs.
*
NJEMWK   DSECT
NJEEYE   DS    CL4'NJEM'           Eyecatcher; main task work area
NJEWKLEN DS    F                   Getmain size of this area
*
DEFUSER  DS    CL8                 Default userid from CONFIG      v200
RELAYID  DS    CL8                 Relay entity id                 v220
DBLE     DS    D                   Work area
TWRK     DS    2D                  Work area
NCB1     DS    XL48                NETSPOOL CB
*
         NJEPARMS                  Define passed parameter list    v220
*
MACLIST  DS    XL160               Macro expansion area
ANJECOM  DS    A                   -> NJECOM csect
COMMAREA DS    A                   -> Console communications area
COMMECBA DS    A                   -> Console communications ECB
REGUSER  DS    A                   -> REGUSER chain anchor         v220
LINKS    DS    A                   -> LINKTABL chain anchor        v211
ROUTES   DS    A                   -> RTE chain anchor             v211
AUTHS    DS    A                   -> AUTHLIST chain anchor        v211
CSAECBAD DS    A                   -> WRE ECB in CSA (same as NJ38ECB)
*
ECBLIST  DS    66A                 ECB list, 64 links + 2 COMM ECBs
*
NJFL1    DS    X                   Flag byte
NJF1STOP EQU   X'80'   1... ....    Console STOP issued
NJF1ENQ  EQU   X'40'   .1.. ....    NJE38 system ENQ issued
NJF1VSER EQU   X'02'   .... ..1.    NETSPOOL VSAM error occurred
NJF1INIT EQU   X'01'   .... ...1    NJEINIT task in RTM
*                      ..xx xx..    Available
*
NJFL2    DS    X                   Flag byte
*                      xxxx xxxx    Available
*
LASTRC   DS    X                   Last RC from NCBRTNCD
LASTERRC DS    X                   Last errcd from NCBERRCD
*
FSAVE    DS    2D
FWORK    DS    D
DHDR     DS    CL30
ABCODE   DS    CL7
FLAGS    DS    X
LKNAME   DS    CL8                 Name of failing link
*
*
*                                  Command response target
TGTUSER  EQU   0                    remote user
TGTCONS  EQU   4                    MVS system console
CMNDBLOK DS    0XL140              CMDBLOK
CMNDBLEN DS    AL1                 Command image ibm length
CMNDDMY  DS    XL3                 Rest of CMDBLOK (unused here)
CMNDLINK DS    CL8                 Node of issuer
CMNDUSER DS    CL8                 yserid of issuer
CMDAREA  DS    CL120               Modify command image
*
CMDBLNK  DS    CL120               For TRT overflow, all blanks
*
JFCBDCB  DS    (NSPOOLN)X          Space for DCB
JEXLST   DS    A                   DCB EXLST
*
NJERNAME DS    CL12                12 ENQ RNAME,+44 for DSN in JFCB
JFCB     DS    XL176               Space for JFCB
*
SV14     DS    A                   General use R14 save
SVR14R   DS    A                   General use R14 save
NJESA    DS    18F                 NJEINIT OS save area
NJECMDSA DS    18F                 NJECMD OS save area
MVSSAVE  DS    18F                 ESTAE exit OS save
BALRSAVE DS    16F                 Local register save area
*
         DS    0D                      Force doubleword size
NJEWKSZ  EQU   *-NJEMWK
*
*
*-- System DSECTs
*
*
IEZCOM   DSECT
         IEZCOM
IEZCIB   IEZCIB
         IHAPSA
         IHASDWA
         IKJTCB
         IHAASCB
         IEZJSCB
*
CSCB     DSECT
         IEECHAIN                      MAP FOR A CSCB
         CVT   DSECT=YES,LIST=YES
         DCBD  DEVD=DA,DSORG=PS
*
         COPY  LINKTABL
         COPY  RTE
         COPY  AUTHLIST
         COPY  NETSPOOL
*
*-- NJE38 DSECTs
*
         NJEWRE                                                    v220
         NJERUSER                                                  v220
         NJETRACE TYPE=DSECT                                       v220
*
         END   NJEINIT
./ ADD NAME=NJERCV
*
*-- NJE38 - TSO RECEIVE
*
*   Command line format (all parameters are optional):
*
*   RECEIVE  filenum
*            DATASET( )
*            VOLSER( )
*            UNIT( )
*            DIR( )
*            INDATASET( )
*            PURGE  | NOPURGE
*            PROMPT | NOPROMPT
*            QUIET
*
*   where:
*
*    filenum        - specifies a specific NJE38 spool file number
*                     to be received.  If not specified, the next
*                     available spool file is received.  Ignored if
*                     INDATASET is specified.
*
*    DATASET( )     - specifies the dsname of the dataset to be
*                     created; the received data will be placed within.
*                     If not specified, the dataset name will be
*                     derived from the incoming dataset name, with
*                     the first qualifer being replaced by the
*                     receiver's TSO userid.
*
*    VOLSER( )      - specifies a volume where DATASET should be
*                     created.  If not specified, a PUBLIC volume will
*                     be chosen based on the receiving dataset's
*                     attributes.
*
*    UNIT( )        - specifies a unit name where DATASET should be
*                     created.  If not specified, SYSDA is the default
*                     unit name.
*
*    DIR( )         - specifies a number of directory blocks if
*                     incoming file was a PDSE.
*
*    INDATASET( )  -  optional. Specifies that the encoded named
*                     dataset is to be received.  The encoded dataset
*                     was previously created by TRANSMIT using
*                     OUTDATASET.  May optionally specify a membername.
*
*    PURGE          - DEFAULT.  Indicates that RECEIVE is to purge
*                     the spool file after successful retrieval. Has
*                     no meaning if INDATASET is specified.
*
*    NOPURGE        - Indicates that RECEIVE is to retain the spool
*                     file.  The file can be received again or must be
*                     removed from the spool by other means.  Has
*                     no meaning if INDATASET is specified.
*
*    PROMPT         - DEFAULT.  Indicates that RECEIVE is to prompt
*                     the TSO user to respecify DATASET or VOLSER
*                     after learning the incoming dataset name. The
*                     user can then choose to change the name or
*                     volume.
*
*    NOPROMPT       - Indicates that no prompts are to be issued.  If
*                     errors are encountered, such as the incoming
*                     dataset name already existing, then RECEIVE is
*                     terminated without any opportunity to change
*                     the parameters.
*
*    QUIET          - If specified, indicates that all informational
*                     messages from  RECEIVE are suppressed.  Error
*                     messages will always be displayed. QUIET also
*                     forces on NOPROMPT.
*
*
* Change log:
*
*
* 21 Oct 21 - Temp dataset on IEBCOPY type receive not using vol   v230
*              identified by GETVOL (instead uses hi-cuu PUBLIC)   v230
* 22 Jul 21 - Typo could cause alloc error with user coded volume  v230
* 24 Apr 21 - Use TSO userid as default user if no security and    v222
*              NJE38 is not active.                                v222
* 15 Feb 21 - Not picking up jobname when run as an STC.           v221
* 01 Oct 20 - Put ENQ existence check in common module             v210
* 09 Aug 20 - Improve TSO attention key handling                   v201
* 13 Jul 20 - Flat file with JCL sneaks by NETDATA checks, causing v200
*             loss of first record in result.                      v200
* 12 Jul 20 - Add support for DIR( ) command line parameter        v200
* 10 Jul 20 - Add support for UNIT( ) command line parameter       v200
* 08 Jul 20 - IEBCOPY failures if netdata records shorter than 80  v200
* 15 May 20 - Initial creation
*
*
         GBLC  &VERS
         REGEQU
NJERCV   CSECT                                                          NJE00020
         NJEVER
         STM   R14,R12,12(R13)         Save Regs                        NJE00050
         LR    R12,R15                 Base                             NJE00060
         USING NJERCV,R12                                               NJE00070
         LR    R8,R1                   Copy input parm addr
*
         GETMAIN RU,                   Get local stg area              X
               LV=4096,                                                X
               BNDRY=PAGE
         LR    R10,R1
         LR    R1,R0                   Copy length
         LR    R2,R0                   Copy length
         LR    R0,R10                  -> new stg area
         SR    R15,R15                 set pad
         MVCL  R0,R14                  Clear the page
*
         USING NJEWK,R10
         ST    R13,NJESA+4             SAVE prv S.A. ADDR               NJE00080
         LA    R1,NJESA                -> my save area
         ST    R1,8(,R13)              Plug it into prior SA
         LR    R13,R1
*
         MVC   NJEEYE,=CL4'NJER'       Work area eyecatcher
         ST    R2,NJEWKLEN             Save size of area in area
         L     R11,=A(NJECOM)          -> common csect
         USING NJECOM,R11
         ST    R8,CPARMS               Save ptr to input parms
         MVC   OLD,=F'1'               Set number of PUTGET segments
         OI    FLAGS3,F3PURGE          Set default: PURGE
*
INIT000  EQU   *
         MVC   MACLIST(ESTAEL),ESTAE   Move ESTAE parm list
         L     R6,=A(NJEDMP)           Point to local ESTAE rtn
         ESTAE (R6),                   Issue ESTAE                     X
               CT,                                                     X
               TERM=YES,                                               X
               PARAM=(R10),            PARAM is work area address      X
               MF=(E,MACLIST)
*
*-- Establish TSO userid issuing this command
*
         TESTAUTH FCTN=1               Are we authorized on entry?
         LTR   R15,R15                 Check result
         BNZ   INIT010                 Branch if not authorized
         OI    FLAGS1,F1APF            Indicate authorized on entry
*
INIT010  EQU   *
         L     R2,PSATOLD-PSA(0)       -> my TCB
         L     R2,TCBTIO-TCB(R2)       -> my TIOT
         LA    R4,TIOCNJOB-IEFTIOT(R2) -> TIOT jobname             v221
         LR    R3,R4                   Assume will use jobname     v222
*
         L     R2,PSAAOLD-PSA(0)       -> my ASCB
         L     R6,ASCBTSB-ASCB(,R2)    -> TSB (or 0)
         L     R2,ASCBASXB-ASCB(,R2)   -> my ASXB
         ICM   R2,15,ASXBSENV-ASXB(R2) -> my ACEE
         BZ    INIT015                 Exit if no ACEE
*
         USING ACEE,R2
         CLI   ACEEUSRL,X'00'          No userid available?
         BE    INIT015                 Exit if unavail
         CLI   ACEEUSR,X'00'           Userid not formed correctly?
         BE    INIT015                 Exit if unavail
         LA    R3,ACEEUSR              -> Userid
         OI    FLAGS1,F1ACEE           Valid ACEE found
         CLC   ACEEUSR,=CL8'STC'       Is this a started task?     v221
         BNE   INIT015                 No, use ACEEUSR id          v221
         LR    R3,R4                   Make the TIOT jobname the idv221
         DROP  R2                      ACEE
*
INIT015  EQU   *
         MVC   USERID,0(R3)            Set the userid
         TM    FLAGS1,F1APF            Authorized at entry?
         BO    INIT040                 yes.
         CLC   USERID,=CL8'HERC01'     Special access id?
         BE    INIT020                 Yes
         CLC   USERID,=CL8'HERC02'     Special access id?
         BNE   INIT030                 No
*
INIT020  EQU   *
         OI    FLAGS1,F1AUSR           Indicate special authorized user
         SR    0,0                     Use authorization SVC
         LA    1,1                      For TK4- HERC01/HERC02 only
         SVC   244                     Get authorized
         B     INIT040
*
INIT030  EQU   *
         TM    FLAGS1,F1APF            Authorized at entry?
         BZ    ERR006                  No, issue error
*
INIT040  EQU   *
         LA    R6,0(,R6)               Clear high order byte
         LTR   R6,R6                   Was there a TSB address
         BNZ   INIT045                 There was. Running in TSO userid
         OI    FLAGS1,F1BATCH          Indicate batch TSO
         TM    FLAGS1,F1ACEE           Valid ACEE found?
         BO    INIT045                 Yes, go with ACEE userid
         BAL   R2,CHK000               See if NJE38 is active      v210
         BNZ   INIT045                 NJE38 not active; use jobnamv222
         MVC   USERID,DEFUSER          Use default userid
*
INIT045  EQU   *
         L     R2,4(,R8)               -> UPT from input parms
         USING UPT,R2
         MVC   PREFIX,BLANKS           Init receiving field
         SR    R1,R1                   Clear for IC
         ICM   R1,1,UPTPREFL           Get prefix length
         BZ    INIT050                 No prefix value in use
         BCT   R1,*+10                 Adjust for execute
         MVC   PREFIX(0),UPTPREFX      executed instr
         EX    R1,*-6                  Copy the prefix value
         DROP  R2                      UPT
*
INIT050  EQU   *
         MVC   STAXLIST(STAXL),STAX    Move STAX parm list
         LA    R5,LIST                 -> input buffer from attn
         LA    R6,STAXXIT              Point to local exit
         STAX  (R6),                   Set exit for attention          X
               OBUF=(ATTNMSG,L'ATTNMSG),                               x
               IBUF=((5),80),                                          x
               USADDR=(10),            Parameter is our work area      x
               MF=(E,MACLIST)
*
*-- Parse command line
*
         SR    R0,R0                   Code 0: parse command line
         L     R15,=A(NJEPAR)          -> parse routine
         BALR  R14,R15
*
         TM    FLAGS4,F4ATTN           Was ATTN pressed?           v201
         BO    EXIT08                  Y, immediate exit           v201
         LTR   R15,R15                 Any errors?
         BNZ   ERR001                  Display IJKPARS RC
*
*-- Issue hello msgs
*
INIT060  EQU   *
         LA    R2,MSG000               Issue hello msg
         BAL   R14,PUTLINE
         LA    R2,MSGBLNK              Issue blank line
         BAL   R14,PUTLINE
*
*-- Are we reading from the NJE38 spool or an INDATASET?
*
         TM    FLAGS3,F3INDS           INDATASET specified?
         BZ    OPN000                  No, use NETSPOOL
*
*-- Set up INDATASET
*
INIT080  EQU   *
         MVC   TDSNAME,USRINDS         Set DSNAME of INDATASET
*
         LA    R0,DYNINDS         24   allocate INDATASET
         L     R15,=A(NJEDYN)          -> dynamic allocation rtns
         BALR  R14,R15
         LTR   R15,R15                 Any errors?
         BNZ   EXIT08                  Exit if allocation error
*
         MVC   NETDATA(DMYNPOL),DMYNPO Set up DCB for PDS
         CLI   TDSORG,X'02'            Was DSORG=PO ?
         BE    *+10                    Yes
         MVC   NETDATA(DMYNPSL),DMYNPS Set up DCB for SEQL
*
         MVC   DDNETDAT,TDDNAME        Save off the DDNAME returned
         MVC   DECB(READL),READ        Set up DECB
         LA    R6,NETDATA              -> DCB
         USING IHADCB,R6
         MVC   DCBDDNAM,DDNETDAT       Set DCB DDNAME
*
         MVC   MACLIST(OPENL),OPEN     Move OPEN list
         OPEN  (NETDATA,INPUT),        Open the NETDATA dataset        X
               MF=(E,MACLIST)
         OI    FLAGS2,F2NETOPN         Indicate DCB is open
*
         CLC   DCBLRECL,=Y(80)         Is LRECL 80?
         BNE   ERR009                  No, cant be netdata file
         TM    DCBRECFM,DCBRECF        Fixed length records?
         BZ    ERR009                  No, cant be netdata file
*
         LH    R0,DCBBLKSI             Get physical blksize
         ST    R0,BLOCKLEN             Save it
         GETMAIN RU,LV=(0)             Get buffer to read blocks
         ST    R1,BLOCK                Save buffer addr
         DROP  R6
*
         CLI   TDSORG,X'40'            Was DSORG=PS ?
         BE    INIT100                 Yes, don't do the FIND
*
         FIND  NETDATA,USRMEM,D        Point to the member
         LTR   R15,R15                 Any errors?
         BNZ   ERR004                  Exit if member not found
*
*-- Process the initial NETDATA control records from INDATASET
*
INIT100  EQU   *
         SR    R0,R0                   Code 0, process initial NETDATA
         L     R15,=A(NJENET)          -> NETDATA parsing routines
         BALR  R14,R15                 Process the control records
*
         B     INIT110(R15)            Branch based on error
INIT110  B     USR000              00  Normal, proceed.
         B     ERR008              04  File is not NETDATA
         B     EXIT08              08  Invalid NETDATA encountered
         B     ERR005              0C  Unexpected EOF on INDATASET
         B     ERR007              10  READ i/o error on INDATASET
         B     ERR030              14  INMTEXT detected, not supported
         B     ERR038              18  Record segments exceed LRECLv222
*
*-- Open NETSPOOL
*
OPN000   EQU   *
         BAL   R2,CHK000               Get NJE38 Spool DSN         v210
         BNZ   ERR013                  NJE38 is not active         v210
*
         MVC   DDNETSPL,=CL8'NETSPOOL' Set NETSPOOL DDN (for unalloc)
         MVC   TDDNAME,DDNETSPL        NETSPOOL DD
         LA    R0,DYNETSPL        28   allocate NETSPOOL
         L     R15,=A(NJEDYN)          -> dynamic allocation rtns
         BALR  R14,R15
         LTR   R15,R15
         BNZ   EXIT08                  Exit with dynalloc error
*
         LA    R8,NCB1                 -> NCB
         USING NCB,R8
*
         LA    R6,TAGDATA              -> area to hold tag data
         USING TAG,R6
*
         NSIO  TYPE=OPEN,                                              x
               NCB=(R8),                                               x
               TAG=(R6),               -> Where tag data will be       x
               EODAD=EOD000
         C     R15,=F'4'               NETSPOOL needs verify?
         BE    ERR025                  Yes
         BL    OPN010                  Everything is good
         BAL   R14,FMT000              Display Open error
         CLC   NCBRTNCD(2),=AL1(8,152) X'0898' security denied access?
         BE    ERR032                  Yes, special msg
         B     EXIT08                  Exit on VSAM error
*
OPN010   EQU   *
         OI    FLAGS2,F2NCBOPN         Indicate NETSPOOL is open
         TM    FLAGS3,F3FILEID         Specific file # specified?
         BO    OPN020                  Yes
*
*-- Here for 'next' available spool file
*
         NSIO  TYPE=CONTENTS,          Get list of files               x
               NCB=(R8)
         LTR   R15,R15                 Any errors?
         BZ    OPN030                  No
         CLC   NCBRTNCD(2),=AL1(12,6)  No files in directory?
         BE    ERR010                  Close up and indicate no files
         BAL   R14,FMT000              Display error
         B     EXIT08                  Exit on VSAM error
*
*-- Here for 'specific' spool file number
*
OPN020   EQU   *
         MVC   TAGID,FILEID+2          Set file # to find
*
         NSIO  TYPE=FIND,              get directory entry             x
               NCB=(R8),                                               x
               TAG=(R6)                Where to place tag data
         LTR   R15,R15                 Any errors?
         BZ    OPN200                  No, process file
         CLC   NCBRTNCD(2),=AL1(12,4)  Was file id not found?
         BE    ERR011                  Yes
         BAL   R14,FMT000              Otherwise, display error
         B     EXIT08                  Exit on VSAM error
*
*-- Look for next available in contents directory
*
OPN030   EQU   *
         L     R2,NCBAREA              Get a list of spool content
         USING NSDIR,R2
         SR    R5,R5
         ICM   R5,3,NCBRECCT           # of returned entries
         SR    R6,R6                   Indicate nothing found yet
*
OPN040   EQU   *
         CLC   LCLNODE,NSTOLOC         Is this file for this link?
         BNE   OPN160                  no, skip this file
         TM    FLAGS1,F1ACEE           Was security available?
         BZ    OPN150                  No; do not enforce selection
         CLC   USERID,NSTOVM           Is this file for this userid?
         BNE   OPN160                  no, skip this file
*
OPN150   EQU   *
         LA    R6,TAGDATA              -> tag data area for file
         USING TAG,R6
         XC    TAGDATA(TAGLEN),TAGDATA
         MVC   TAGINLOC(TAGUSELN),NSINLOC  Copy tag datq
         B     OPN170                  Go process the file
*
OPN160   EQU   *
         LA    R2,NSDIRLN(,R2)         Next NETSPOOL dir entry
         BCT   R5,OPN040               Continue thru the contents
         DROP  R2                      NSDIR
*
*
OPN170   EQU   *
         LM    R0,R1,NCBAREAL          Get list length and address
         XC    NCBAREA,NCBAREA         Clear obsolete ptr
         FREEMAIN RU,LV=(0),A=(1)
*
         LTR   R6,R6                   Did we obtain tag data?
         BZ    ERR010                  No, no files available
         B     OPN300
*
*-- validate specific file owner
*
OPN200   EQU   *
         CLC   LCLNODE,TAGTOLOC        Is this file for this link?
         BNE   ERR016                  no, skip this file
         TM    FLAGS1,F1ACEE           Was security available?
         BZ    OPN300                  No; do not enforce selection
         CLC   USERID,TAGTOVM          Is file for this userid?
         BNE   ERR016                  no, skip this file
         DROP  R6                      TAG
         DROP  R8                      NCB
*
*-- Process the initial NETDATA control records from NETSPOOL
*
OPN300   EQU   *
         SR    R0,R0                   Code 0, process initial NETDATA
         L     R15,=A(NJENET)          -> NETDATA parsing routines
         BALR  R14,R15                 Process the control records
*
         B     OPN310(R15)             Branch based on error
OPN310   B     USR000              00  Normal, proceed.
         B     OPN400              04  File is not NETDATA
         B     EXIT08              08  Invalid NETDATA encountered
         B     ERR005              0C  Unexpected EOF on NETSPOOL
         B     ERR007              10  READ i/o error on NETSPOOL
         B     ERR030              14  INMTEXT detected, not supported
         B     ERR038              18  Record segments exceed LRECLv222
*
OPN400   EQU   *
         OI    FLAGS2,F2FLAT           Indicate file is a flat file
*
*-- Notify user of dataset and prompt for changes
*
*-- This routine will:
*   1. Obtain or make the dataset name that came from the Tag/NETDATA
*   2. Tell user that name and prompt for changes
*   3. Parse the changes
*
USR000   EQU   *
         LA    R7,INMF02A              -> 1st INMR02 record        v200
         USING INMFIELD,R7                                         v200
         NC    DSTYPE(2),DSTYPE        Was a DSTYPE key detected?  v200
         BZ    USR020                  No, we're good              v200
         CLI   DSTYPE+2,X'40'          PDSE program library?       v200
         BE    ERR035                  Can't support it            v200
         DROP  R7                      INMFIELD                    v200
*
USR020   EQU   *                                                   v200
         MVI   FLAGS4,X'00'            Reinit parse results flags
         L     R15,=A(NJENOT)          -> Notify user and parse rtn
         BALR  R14,R15
*
         LR    R1,R15                  RC to R1
         LR    R15,R0                  Any secondary RC to R15
         B     USR080(R1)              Branch based on error in R1
USR080   B     USR100              00  Normal, proceed.
         B     RCV920              04  User specified "END"
         B     RCV910              08  User specified "PURGE"
         B     ERR001              0C  IKJPARS err, RC in R15
         B     ERR026              10  PUTGET errr, RC in R15
*
*-- Did user enter a dataset name -and- member name on the prompt?
*-- If so, warn him that we are ignoring the member name.
*
USR100   EQU   *
         TM    FLAGS4,F4MEMINV         Was a member name specified?
         BZ    USR110                  No
*
         LA    R2,MSG021               msg: member name ignored
         BAL   R14,PUTLINE             Inform user
*
USR110   EQU   *
         TM    FLAGS2,F2FLAT           Flat non-NETDATA type file?
         BZ    RCV000                  No, process NETDATA
*
*-- Prepare attributes for a flat file
*
FLT000   EQU   *
         LA    R7,INMF02A              -> 1st INMR02 record
         USING INMFIELD,R7
         MVC   TDSNAME,FINALDS         Set up DSNAME to build
         MVI   DSNAME+1,44             Set DSNAME length for dynalloc
         MVC   DSORG+2(2),=X'4000'     Set DSORG=PS
         MVC   BLKSIZE+6(4),=F'0'      Set BLKSIZE to 0 to be computed
         MVI   RECFM+2,DCBRECF+DCBRECBR  Indicate RECFM=FB
         LA    R6,TAGDATA              -> TAG data
         USING TAG,R6
         LA    R1,80                   Assume punch data length
         TM    TAGINDEV,TYPPUN         Is this punch data?
         BO    FLT010                  Yes
         LA    R1,133                  Assign print data length
         OI    RECFM+2,DCBRECCA        Use ASA ctl char
*
FLT010   EQU   *
         STCM  R1,15,LRECL+6           Set LRECL
         SR    R0,R0                   Clear for multiply
         M     R0,TAGRECNM             Compute size of file
         ST    R1,FILESIZE+6           Set size in bytes for space calc
         DROP  R6,R7                   TAG,INMFIELD
*
*-- Prepare to receive the data
*
RCV000   EQU   *
         LA    R7,INMF02A              -> 1st INMR02 record
         USING INMFIELD,R7                                         v222
         ICM   R0,15,BLKSIZE+6         Get blocksize to use in srchv222
         C     R0,=F'32760'            BLKSIZE > 32760 MVS limit?  v222
         BH    ERR023                  Exit if invalid blksize     v222
         CLC   LRECL+6(4),=F'32760'    LRECL > 32760 MVS limit?    v222
         BH    ERR023                  Exit if invalid LRECL       v222
*
         TM    FLAGS1,F1INMR2B         Was there a second INMR02?
         BZ    RCV030                  No
         LA    R7,INMF02B              -> 2nd INMR02 record
*
*-- Locate a suitable volume to hold the new dataset
*
RCV030   EQU   *
         MVC   TVOLSER,USRVOL          Assume user specified volser
         TM    FLAGS3,F3VOLSER         Did user specify a volser?
         BO    RCV040                  Yes, we'll use that
         TM    FLAGS4,F4VOLSER         user specify a volser at prompt?
         BO    RCV040                  Yes, we'll use that
         TM    FLAGS2,F2UNIT           user specify a unit?        v200
         BO    RCV040                  Y, dont select a volume     v200
*
*                                      R0 must contain BLKSIZE or 0
         BAL   R14,GETVOL              Find a volume for allocation
         BZ    ERR022                  No volume found
*
*-- Start computing values and filling dynamic allocation text units
*
RCV040   EQU   *
         LA    R1,TVOLSER              -> selected volser          v200
         BAL   R14,FNDVOL              Get track sz of selected volv200
         BZ    ERR036                  Volume not online           v200
         LA    R1,INMF02A              -> 1st INMR02 record        v200
         L     R1,BLKSIZE+6-INMFIELD(,R1) Get target DSN blksize   v200
         CR    R1,R15                  Will block fit on track?    v200
         BH    ERR037                  No; were done here          v200
*
         BAL   R14,GETBSZ              Obtain final sizes, format
         STH   R1,TBLKSIZE             Set dynalloc block size
         STCM  R1,7,TBLKLEN            Set dynalloc space blk len
         STH   R2,TLRECL               Set dynalloc lrecl
         STC   R3,TRECFM               Set dynalloc recfm
*
         BAL   R14,GETSPACE            Compute space parameters
         STCM  R1,7,TPRIME             Set primary space in blocks
         STCM  R2,7,TSECND             Set secondary space in blocks
*
         MVC   TDSORG,DSORG+2          NETDATA DSORG to text unit
         MVC   TDSNAME,FINALDS         Set DSNAME to allocate
*
*
*
*-- Call NJEDYN to allocate the dataset
*
         LA    R0,DYNINMCP        04   allocate dataset for SEQL file
         L     R15,=A(NJEDYN)          -> dynamic allocation rtns
         BALR  R14,R15
*
         B     RCV060(R15)             Branch on RC
RCV060   B     RCV200              00  Normal, proceed
         B     USR000              04  Dataset exists, reprompt
         B     EXIT08              08  All other errors
*
*
*-- Open the dataset
*
RCV200   EQU   *
         MVC   DDSYSUT1,TDDNAME        Save off the DDNAME returned
         MVC   NEWDS(DMYSEQL),DMYSEQ   Set up DCB
         LA    R6,NEWDS                -> DCB
         USING IHADCB,R6
         MVC   DCBBLKSI,TBLKSIZE       Set block size
         MVC   DCBLRECL,TLRECL         Set length
         MVC   DCBRECFM,TRECFM         Set format
         MVC   DCBDDNAM,DDSYSUT1       Set Dynamic DD name
         TM    DCBRECFM,DCBRECU        Using undefined records?
         BNO   RCV210                  No
*
         LH    R0,DCBBLKSI             Get dataset block size
         GETMAIN RU,LV=(0)             Get recd build buffer for RECFMU
         STM   R0,R1,NEWLEN            Save length and addr
         DROP  R6                      IHADCB
*
RCV210   EQU   *
         MVC   MACLIST(OPENL),OPEN     Move OPEN list
         OPEN  (NEWDS,OUTPUT),         Open the NEWDS dataset          X
               MF=(E,MACLIST)
         OI    FLAGS2,F2NEWOPN         Indicate DCB is open
*
         LA    R0,4                    Code 4, process NETDATA
         TM    FLAGS2,F2FLAT           Flat non-NETDATA type file?
         BZ    RCV220                  No, proceed with NETDATA
         LA    R0,8                    Code 8, process PRT/PUN file
*
RCV220   EQU   *
         L     R15,=A(NJENET)          -> data retreival routines
         BALR  R14,R15                 Process the records
*
         B     RCV230(R15)             Branch based on result RC
RCV230   B     RCV240              00  Normal, proceed.
         DC    AL4(0)              04  Not used
         B     EXIT08              08  Invalid NETDATA encountered
         B     ERR005              0C  Unexpected EOF on INDATASET
         B     ERR007              10  READ i/o error on INDATASET
         B     ERR030              14  INMTEXT detected, not supported
         B     ERR038              18  Record segments exceed LRECLv222
*
RCV240   EQU   *
         MVC   MACLIST(CLOSEL),CLOSE   Move close list
         CLOSE (NEWDS),                Close it                        X
               MF=(E,MACLIST)
         NI    FLAGS2,255-F2NEWOPN     Indicate file closed
*
         TM    FLAGS3,F3INDS           INDATASET specified?
         BZ    RCV250                  No, skip close
*
         MVC   MACLIST(CLOSEL),CLOSE   Move close list
         CLOSE (NETDATA),              Close it                        X
               MF=(E,MACLIST)
         NI    FLAGS2,255-F2NETOPN     Indicate NETDATA file closed
*
*
*
*-- If two INMR02 control records were found, then we need to run
*-- IEBCOPY to load a PDS from the unloaded file just processed above.
*
RCV250   EQU   *
         TM    FLAGS1,F1INMR2B         Was there a second INMR02?
         BZ    RCV950                  No. We're done
*
         LA    R7,INMF02A              -> 1st INMR02 record
         USING INMFIELD,R7
*
*-- Filling dynamic allocation text units for final dataset
*
         ICM   R1,15,BLKSIZE+6         Get the NETDATA blksize
         STH   R1,TBLKSIZE             Set dynalloc block size
         STCM  R1,7,TBLKLEN            Set dynalloc space blk len
         MVC   TLRECL,LRECL+8          Set dynalloc lrecl
         MVC   TRECFM,RECFM+2          Set dynalloc recfm
*
         BAL   R14,GETSPACE            Compute space parameters
         STCM  R1,7,TPRIME             Set primary space in blocks
         STCM  R2,7,TSECND             Set secondary space in blocks
*
         MVC   TDIRBLKS,DIRBLKS+7      Set directory blocks required
         TM    FLAGS2,F2DIR            Did user override with DIR? v200
         BZ    RCV255                  No                          v200
         MVC   TDIRBLKS,USRDIR+1       Set directory blocks req'd  v200
*
RCV255   EQU   *                                                   v200
         MVC   TDSORG,DSORG+2          NETDATA DSORG to text unit
         MVC   TDSNAME,FINALDS         Set DSNAME to allocate
*
*
*-- Call NJEDYN to allocate the final output dataset as "SYSUT2"
*
         LA    R0,DYNFINAL        10   allocate final dataset
         L     R15,=A(NJEDYN)          -> dynamic allocation rtns
         BALR  R14,R15
*
         B     RCV260(R15)             Branch on RC
RCV260   B     RCV400              00  Normal, proceed
         B     RCV300              04  Dataset exists, reprompt
         B     EXIT08              08  All other errors
*
*-- Notify user of existing dataset and prompt for changes
*
*-- This routine will:
*   1. Obtain or make the dataset name that came from the Tag/NETDATA
*   2. Tell user that name and prompt for changes
*   3. Parse the changes
*
RCV300   EQU   *
         MVI   FLAGS4,X'00'            Reinit parse results flags
         L     R15,=A(NJENOT)          -> Notify user and parse rtn
         BALR  R14,R15
*
         LR    R1,R15                  RC to R1
         LR    R15,R0                  Any secondary RC to R15
         B     RCV310(R1)              Branch based on error in R1
RCV310   B     RCV320              00  Normal, proceed.
         B     RCV920              04  User specified "END"
         B     RCV910              08  User specified "PURGE"
         B     ERR001              12  IKJPARS err, RC in R15
         B     ERR026              16  PUTGET errr, RC in R15
*
*-- Did user enter a dataset name -and- and member name on the prompt?
*-- If so, warn him that we are ignoring the member name.
*
RCV320   EQU   *
         TM    FLAGS4,F4VOLSER         Was a new volser specified?
         BZ    RCV330                  No
         MVC   TVOLSER,USRVOL          Grab new volser
*
RCV330   EQU   *
         TM    FLAGS4,F4MEMINV         Was a member name specified?
         BZ    RCV250                  No, try to allocate again
*
         LA    R2,MSG021               msg: member name ignored
         BAL   R14,PUTLINE             Inform user
         B     RCV250                  Try to allocate again
*
*
*
*-- Prepare to launch IEBCOPY
*
RCV400   EQU   *
         MVC   DDSYSUT2,TDDNAME        Set replacement SYSUT2 DD
*
*-- Call NJEDYN to allocate the SYSIN dataset needed by IEBCOPY
*
         LA    R0,DYNSYSIN        08   allocate SYSIN for IEBCOPY
         L     R15,=A(NJEDYN)          -> dynamic allocation rtns
         BALR  R14,R15
         LTR   R15,R15
         BNZ   EXIT08                  Exit with dynalloc error
         MVC   DDSYSIN,TDDNAME         Save generated DDNAME
*
*-- Call NJEDYN to allocate the SYSPRINT dataset needed by IEBCOPY
*
         LA    R0,DYNSYSPR        12   allocate SYSPRINT for IEBCOPY
         L     R15,=A(NJEDYN)          -> dynamic allocation rtns
         BALR  R14,R15
         LTR   R15,R15
         BNZ   EXIT08                  Exit with dynalloc error
         MVC   DDSYSPR,TDDNAME         Save generated DDNAME
*
*-- Call NJEDYN to allocate the SYSUT3 dataset needed by IEBCOPY
*
         LA    R0,DYNSYSU3        14   allocate SYSUT3 temporary
         L     R15,=A(NJEDYN)          -> dynamic allocation rtns
         BALR  R14,R15
         LTR   R15,R15
         BNZ   EXIT08                  Exit with dynalloc error
         MVC   DDSYSUT3,TDDNAME        Set replacement SYSUT3 DD
*
*-- Invoke IEBCOPY
*
         MVC   CPYPLIST,COPYPARM       Move IEBCOPY parms to 24-bit stg
         MVC   DDLISTL,=AL2(DDLISTSZ)  Set IEBCOPY DD list length
         LA    R2,CPYPLIST
         LA    R3,DDLISTL
         MVC   MACLIST(LINKL),LINK     Move macro model
         LINK  EP=IEBCOPY,                                             x
               PARAM=((R2),(R3)),                                      x
               VL=1,                                                   x
               MF=(E,MACLIST)
         LTR   R5,R15                  Copy RC to R5
         BZ    RCV950                  Exit on success
*
*-- RECEIVE ended because IEBCOPY failed
*
RCV900   EQU   *
         LA    R2,MSGBLNK              -> blank line msg
         BAL   R14,PUTLINE
*
         MVC   LIST(4+L'MSG018T),MSG018 IEBCOPY fail msg
         CVD   R5,DBLE                 Convert IEBCOPY RC
         UNPK  LIST+37(2),DBLE
         OI    LIST+38,X'F0'           Fix sign
*
         LA    R2,LIST                 -> start of msg
         BAL   R14,PUTLINE             Display failure
         B     EXIT08
*
*-- User chose PURGE on the action prompt; purge the spool file
*-- (if not using INDATASET) and then exit.
*
RCV910   EQU   *
         TM    FLAGS3,F3INDS           Was INDATASET specified?
         BO    RCV920                  Y, exit with no action
         BAL   R14,PUR000              Purge spool file as requested
         LA    R2,MSGBLNK              -> blank line msg
         BAL   R14,PUTLINE
         LA    R2,MSG029               -> ended with nothing recv'd
         BAL   R14,PUTLINE
         B     EXIT00                  And we're done
*
*-- RECEIVE ended with no action taken
*
*-- Here if 'END' specified or attention received
*
RCV920   EQU   *
         LA    R2,MSGBLNK              -> blank line msg
         BAL   R14,PUTLINE
         LA    R2,MSG019               -> ended with no action
         BAL   R14,PUTLINE
         TM    FLAGS2,F2FEND           Was END forced in BATCH mode?
         BO    EXIT08                  Yes, force RC=8
         B     EXIT00
*
*-- RECEIVE ended successfully with dataset created and filled
*
*-- If the user at any time specified the PURGE option, remove
*-- the spool file that was received.
*
RCV950   EQU   *
*
RCV990   EQU   *
         LA    R2,MSGBLNK              -> blank line msg
         BAL   R14,PUTLINE
         MVC   LIST,BLANKS
         MVC   LIST(4+L'MSG017T),MSG017 Success msg
         LA    R1,LIST+4+L'MSG017T     -> next available byte
         MVI   0(R1),C''''             Move apost
         MVC   1(44,R1),FINALDS        Move final DSN
         TRT   1(45,R1),BLANK          Look for end of DSN
         MVI   0(R1),C''''             Move apost
         LA    R1,2(,R1)               -> skip over apost + 1 blank
         MVC   0(10,R1),=C'successful'
         LA    R1,10(,R1)              -> skip to end
         LA    R2,LIST                 -> start of msg
         SR    R1,R2                   Compute msg length
         STH   R1,LIST                 Set RDW
         BAL   R14,PUTLINE             Display success
*
         BAL   R14,PUR000              Purge the spool file if needed
         B     EXIT00
*
*
*-- Return the BLKSIZE value from the NETDATA, and adjust the
*-- RECFM and LRECL based on the NETDATA-unique variable formats when
*-- applicable.
*
*-- General guidelines and manipulations by this routine:
*
*-- 1. If the NETDATA LRECL is zero, this is unusual but don't alter
*--    any other DCB parameters; this covers the RECFM=U case.
*
*-- 2. If the NETDATA RECFM specifies the variable spanned records,
*--    leave all other parameters as is.  This file came from MVS.
*
*-- 3. If the NETDATA RECFM specifies the shortened variable format,
*--    e.g., RECFM=xx01 or xx02, then the LRECL must be increased
*--    by 4 bytes to account for a RDW to be inserted.
*
*-- 4. If the NETDATA RECFM specifies the shortened variable format,
*--    e.g., RECFM=xx01 or xx02, then the RECFM value used for
*--    dynamic allocation of the dataset must be modified to specify
*--    variable length records, as the variable X'40' bit may not
*--    be set in the NETDATA RECFM.
*
*-- 5. If the BLKSIZE is 0, the file probably came from VM; then
*--    do the following:
*--    a. Manufacture a suitable blksize as close to 4K as possible.
*--    b. If the LRECL > 4K, then make BLKSIZE=LRECL.
*--    c. For Fixed length records, force the RECFM X'10' bit to
*--       indicate blocked records, if BLKSIZE is not equal to LRECL.
*
*-- Entry: Fields BLKSIZE, LRECL, RECFM as decoded from NETDATA
*-- Exit:  R1 = BLKSIZE for use in dynamic allocation and DCB
*--        R2 = LRECL for use in dynamic allocation and DCB
*--        R3 = RECFM for use in dynamic allocation and DCB
*
GETBSZ   EQU   *
         ICM   R1,15,BLKSIZE+6         Get blocksize
         IC    R3,RECFM+2              Get DCB portion of NETDATA RECFM
         ICM   R2,15,LRECL+6           Get lrecl
         BZR   R14                     No LRECL?  leave everything be
         TM    RECFM+2,X'48'           Spanned variable records?
         BOR   R14                     Yes, use as specified
         TM    RECFM+3,X'03'           Shortened variable format?
         BZ    GETB010                 No
         LA    R2,4(,R2)               Add length to LRECL for RDW
         O     R3,=A(DCBRECV+DCBRECBR) Ensure DCB RECFM is VB
*
GETB010  EQU   *
         LTR   R1,R1                   Was there a blksize?
         BNZR  R14                     Use it if we have it
         TM    RECFM+2,X'40'           Variable format data?
         BO    GETB030                 Yes
         TM    RECFM+3,X'03'           Compressed variable format?
         BNZ   GETB030                 Yes, treat as variable
*fixed
         L     R1,=F'4096'             Get possible block size
         DR    R0,R2                   Compute # recs in 4096 block
         LTR   R1,R1                   Do any recs fit?
         BZ    GETB020                 No, so make blksize=lrecl
         SR    R0,R0                   Dispose of remainder
         MR    R0,R2                   Compute nearest block size
         O     R3,=A(DCBRECF+DCBRECBR) Set RECFM to FB
         BR    R14                     Return with BLKSIZE in R1
*
GETB020  EQU   *
         LR    R1,R2                   Make BLKSIZE=LRECL if LRECL>4096
         N     R3,=A(-1-DCBRECBR)      Turn off blocking
         BR    R14                     Return with BLKSIZE in R1
*
*variable
GETB030  EQU   *
         L     R1,=F'4096'             Get possible block size
         LA    R0,4092                 Possible size - 4 (for RDW)
         CR    R2,R0                   Will LRECL fit in possible size?
         BNHR  R14                     Yes, use the 4K blksize
*
GETB040  EQU   *
         LA    R1,4(,R2)               Mk BLKSIZE=LRECL+4 if LRECL>4092
         N     R3,=A(-1-DCBRECBR)      Turn off blocking
         BR    R14                     Return with BLKSIZE in R1
*
*-- Compute primary and secondary space values in # blocks
*
*-- Entry: R1 = blksize
*--        Field FILESIZE contains NETDATA estimated file size in bytes
*
*-- Exit:  R1 = # of primary blocks
*--        R2 = # of secondary blocks (always 10% of primary)
*
GETSPACE EQU   *
         ICM   R3,15,FILESIZE+6        Get approx size of file
         SR    R2,R2                   Clear for divide
         DR    R2,R1                   Compute # blocks needed
         LA    R3,1(,R3)               Always round up
         LR    R1,R3                   Return primary blocks in R1
         SR    R2,R2                   Clear for divide
         D     R2,=F'10'               Compute 1/10th of needed amt
         LA    R2,1(,R3)               Round up = secondary blks needed
         BR    R14                     Return with R1 & R2 values
         DROP  R7
*
*-- PURGE the spool file
*
*-- Conditions:
*-- 1.  If INDATASET was specified then there is no spool file to purge
*-- 2.  If PURGE was specified when the user was prompted for
*--     additional parameters, then purge the spool file and exit
*--     without receiving the file.
*-- 3.  If NOPURGE was specified on the command line (if not overridden
*--     by (2) above), then receive the file but do not purge it from
*--     the spool.
*-- 4.  Otherwise, PURGE is defaulted or explicity specified on the
*--     command line, receive the file and then purge it from spool.
*
PUR000   EQU   *
         TM    FLAGS3,F3INDS           INDATASET specified?
         BOR   R14                     Yes, PURGE has no meaning
         TM    FLAGS4,F4PURGE          PURGE specified on prompt?
         BO    PUR010                  Yes, do it
         TM    FLAGS3,F3PURGE          PURGE specified or defaulted?
         BZR   R14                     No; do not purge spool file
*
PUR010   EQU   *
         ST    R14,SV14PUR             Save return addr
         LA    R6,TAGDATA              -> area containing tag data
         USING TAG,R6
         LA    R8,NCB1                 -> NCB
         NSIO  TYPE=PURGE,             Purge the file                  x
               NCB=(R8),                                               x
               TAG=(R6)                -> Where tag data is
         LTR   R15,R15                 Any errors?
         BZ    PUR040                  No
         BAL   R14,FMT000              Display error
         B     EXIT08                  Exit on VSAM error
*
PUR030   EQU   *
         NSIO  TYPE=CLOSE,             Close the spool                 x
               NCB=(R8)
         NI    FLAGS2,255-F2NCBOPN     Indicate NETSPOOL closed
*
PUR040   EQU   *
         MVC   LIST(4+L'MSG028T),MSG028  Move file purged msg
         LH    R1,TAGID                Get the file ID
         DROP  R6                      TAG
         CVD   R1,DBLE
         UNPK  LIST+9(4),DBLE
         OI    LIST+12,X'F0'           Fix sign
         LA    R2,LIST                 -> msg text
         BAL   R14,PUTLINE             Inform user
         L     R14,SV14PUR             Reload return addr
         BR    R14                     Return
*
*
ERR001   EQU   *
         MVC   LIST(4+L'MSG001T),MSG001  Move msg to work area
         CVD   R15,DBLE                unpk IKJPARS RC
         UNPK  LIST+57(2),DBLE
         OI    LIST+58,X'F0'           Fix sign
         LA    R2,LIST                 -> msg
         B     ERRPUT                  Write msg                   v200
*
ERR004   EQU   *
         MVC   LIST(4+L'MSG004T),MSG004  Move msg to work area
         MVC   LIST+11(8),USRMEM       Plug in member name
         LA    R2,LIST                 -> msg
         B     ERRPUT                  Write msg                   v200
*
ERR005   EQU   *
         MVC   LIST(4+L'MSG005T),MSG005  Move msg text
         LA    R1,=CL9'INDATASET'      Assume reading from INDATASET
         TM    FLAGS3,F3INDS           Using INDATASET?
         BO    *+8                     We are
         LA    R1,=CL9'NETSPOOL'       NO, its NETSPOOL
         MVC   LIST+4+L'MSG005T(9),0(R1)  Move source of error
         LH    R1,LIST                 Get current msg length
         LA    R1,9(,R1)               Add on the source length
         STH   R1,LIST                 Put back
         LA    R2,LIST                 Unexpected EOF on xxxxxxxxx
         B     ERRPUT                  Write msg                   v200
*
ERR006   EQU   *
         LA    R2,MSG006               Not APF authorized
         B     ERRPUT                  Write msg                   v200
*
ERR007   EQU   *
         MVC   LIST(4+L'MSG007T),MSG007  Move msg text
         LA    R1,=CL9'INDATASET'      Assume reading from INDATASET
         TM    FLAGS3,F3INDS           Using INDATASET?
         BO    *+8                     We are
         LA    R1,=CL9'NETSPOOL'       NO, its NETSPOOL
         MVC   LIST+4+L'MSG007T(9),0(R1)  Move source of error
         LH    R1,LIST                 Get current msg length
         LA    R1,9(,R1)               Add on the source length
         STH   R1,LIST                 Put back
         LA    R2,LIST                 Read i/o error on INDATASET
         B     ERRPUT                  Write msg                   v200
*
ERR008   EQU   *
         LA    R2,MSG008               INDATASET is not NETDATA fmt
         B     ERRPUT                  Write msg                   v200
*
ERR009   EQU   *
         LA    R2,MSG009               INDATASET is not 80/F
         B     ERRPUT                  Write msg                   v200
*
ERR010   EQU   *
         LA    R2,MSG010               No files available to receive
         B     ERRPUT                  Write msg                   v200
*
ERR011   EQU   *
         LA    R2,MSG011               Specific file number not exis
         B     ERRPUT                  Write msg                   v200
*
ERR013   EQU   *
         LA    R2,MSG013               NJE38 is not active
         B     ERRPUT                  Write msg                   v200
*
ERR016   EQU   *
         LA    R2,MSG016               Cant receive another users file
         B     ERRPUT                  Write msg                   v200
*
ERR022   EQU   *
         LA    R2,MSG022               No suitable PUBLIC volume
         B     ERRPUT                  Write msg                   v200
*
ERR023   EQU   *
         LA    R2,MSG023               BLKSIZE/LRECL to large
         B     ERRPUT                  Write msg                   v200
*
ERR025   EQU   *
         LA    R2,MSG025               Need to run VERIFY
         B     ERRPUT                  Write msg                   v200
*
ERR026   EQU   *
         MVC   LIST(4+L'MSG026T),MSG026  Move msg to work area
         CVD   R15,DBLE                unpk PUTGET RC
         UNPK  LIST+49(2),DBLE
         OI    LIST+50,X'F0'           Fix sign
         LA    R2,LIST                 -> msg PUTGET failed
         B     ERRPUT                  Write msg                   v200
*
ERR030   EQU   *
         LA    R2,MSG030               INMTEXT detected not supported
         B     ERRPUT                  Write msg                   v200
*
ERR032   EQU   *
         LA    R2,MSG032               Security denied access NETSPOOL
         B     ERRPUT                  Write msg                   v200
*
ERR035   EQU   *                                                   v200
         LA    R2,MSG035               Incoming is a PDSE Prog Lib v200
         B     ERRPUT                  Write msg                   v200
*
ERR036   EQU   *                                                   v200
         LA    R2,MSG036               Volume not online           v200
         B     ERRPUT                  Write msg                   v200
*
ERR037   EQU   *                                                   v200
         LA    R2,MSG037               BLKSIZE to large for volume v200
         B     ERRPUT                  Write msg                   v200
*
ERR038   EQU   *                                                   v222
         LA    R2,MSG038               Input file recs exceed LRECLv222
         B     ERRPUT                  Write msg                   v222
*
ERRPUT   EQU   *                                                   v200
         BAL   R14,PUTLINE             Write error msg in R2       v200
         B     EXIT08                  Exit w RC=08                v200
*
EXIT00   EQU   *
         SR    R15,R15                 Set RC=0
         B     XIT000                  Clean up and exit
*
EXIT08   EQU   *
         LA    R15,8                   Set RC=8
         B     XIT000                  Clean up and exit
*
XIT000   EQU   *
         LA    R13,NJESA               Ensure using proper SA in case
*                                       we've come here due to ESTAE
         LR    R5,R15                  Save RC across shutdown
         ESTAE 0                       Disable ESTAE
*
         TM    FLAGS2,F2NETOPN         Is NETDATA open?
         BZ    XIT010                  No
         MVC   MACLIST(CLOSEL),CLOSE   Move close list
         CLOSE (NETDATA),              Close it                        X
               MF=(E,MACLIST)
*
XIT010   EQU   *
         TM    FLAGS2,F2NEWOPN         Is NEWDS open?
         BZ    XIT020                  No
         MVC   MACLIST(CLOSEL),CLOSE   Move close list
         CLOSE (NEWDS),                Close it                        X
               MF=(E,MACLIST)
*
XIT020   EQU   *
         TM    FLAGS2,F2NCBOPN         Is NETSPOOL open?
         BZ    XIT030                  No
         SR    R6,R6                   Ensure no tag data
         LA    R8,NCB1                 -> NCB
         NSIO  TYPE=CLOSE,             Close the spool                 x
               NCB=(R8)
*
XIT030   EQU   *
         L     R0,BLOCKLEN             Size of stg area
         ICM   R1,15,BLOCK             -> stg area
         BZ    XIT040                  Skip if never allocated
         FREEMAIN RU,LV=(0),A=(1)      Release it
*
XIT040   EQU   *
         L     R0,NEWLEN               Size of stg area
         ICM   R1,15,NEWBLK            -> stg area
         BZ    XIT050                  Skip if never allocated
         FREEMAIN RU,LV=(0),A=(1)      Release it
*                                                                       NJE00200
XIT050   EQU   *                                                        NJE00210
         LA    R3,DDLIST               -> list of DD's we allocated
         LA    R4,UNLISTSZ/8           # of DD list entries
*
XIT060   EQU   *
         CLC   =XL8'00',0(R3)          Unassigned DD?
         BE    XIT070                  Skip to next
*
         MVC   UDDNAME,0(R3)
         LA    R0,UNDYN           00   unalloc
         L     R15,=A(NJEDYN)          -> dynamic allocation rtns
         BALR  R14,R15
*
XIT070   EQU   *                                                        NJE00210
         LA    R3,8(,R3)               -> next DD entry
         BCT   R4,XIT060               Continue unallocation scan
*
XIT080   EQU   *                                                        NJE00210
         TM    FLAGS1,F1AUSR           Special authorized user?
         BZ    QUIT                    Y, Don't need Auth SVC
         SR    0,0                     Use authorization SVC
         SR    1,1                      For HERC01/HERC02 only
         SVC   244                     Get un-authorized
*
QUIT     EQU   *                                                        NJE00210
         LR    R1,R10                  -> NJEWK main work area page
         L     R13,4(,R13)             -> caller's sa                   NJE00210
         ST    R5,16(,R13)             Set exit RC
         FREEMAIN RU,                                                  x
               LV=4096,                                                x
               A=(1)
         LM    R14,R12,12(R13)         Reload system's regs             NJE00220
         BR    R14                     Return                           NJE00240
         DROP  R12
*
*-- STAX attention exit
*
*-- Just post the PUTGET ECB and return.  PUTGET will fail with RC=8.
*
STAXXIT  EQU   *
         STM   R14,R12,12(R13)         Save
         LR    R12,R15                 Get base
         USING STAXXIT,R12
         L     R10,8(,R1)              -> NJEWK area
         USING NJEWK,R10
         POST  PUTECB,16               Post the PUTGET ECB
         OI    FLAGS4,F4ATTN           Indicate ATTN pressed       v201
         LM    R14,R12,12(R13)         Load
         DROP  R12
         BR    R14                     Return
*
         LTORG ,
*
DMYNPO   DCB   DDNAME=NETDATA,                                         X
               MACRF=(R),                                              X
               DSORG=PO,                                               X
               EODAD=EOD000
DMYNPOL  EQU   *-DMYNPO
*
DMYNPS   DCB   DDNAME=NETDATA,                                         X
               MACRF=(R),                                              X
               DSORG=PS,                                               X
               EODAD=EOD000
DMYNPSL  EQU   *-DMYNPS
*
*
DMYSEQ   DCB   DDNAME=0,                                               X
               MACRF=(PL),                                             X
               DSORG=PS,                                               X
               BFTEK=A
DMYSEQL  EQU   *-DMYSEQ
*
*
OPEN     OPEN  0,MF=L
OPENL    EQU   *-OPEN
CLOSE    CLOSE 0,MF=L
CLOSEL   EQU   *-CLOSE
LINK     LINK  EP=0,SF=L
LINKL    EQU   *-LINK
READ     READ  DMYDECB,SF,DMYNPO,MF=L
READL    EQU   *-READ
ESTAE    ESTAE 0,MF=L
ESTAEL   EQU   *-ESTAE
STAX     STAX  0,OBUF=(0,0),IBUF=(0,0),USADDR=0,MF=L
STAXL    EQU   *-STAX
*
COPYPARM DC    AL2(L'COPYOPT)
COPYOPT  DC    C'WORK=0512K'
COPYPRML EQU   *-COPYPARM                 TOTAL LENGTH OF PARM OPTION
*
ATTNMSG  DC   C'COMMAND TERMINATED DUE TO ATTENTION; PRESS ENTER TWICE'
*                                                                  v201
*********************
*  N J E C O M      *               NJECOM hosts small routines and
*                   *               frequently used constants that
*  Common routines  *               are available to all NJERxx csects
*  and constants    *               via base register 11
*                   *
*********************
*
NJECOM   CSECT
         DC    A(0)                 No branch around constants
         DC    AL1(23)                LENGTH OF EYECATCHERS
         DC    CL9'NJECOM'
         DC    CL9'&SYSDATE'
         DC    CL5'&SYSTIME'
         USING NJECOM,R11
*
*-- GET000 is used to read a block from the INDATASET or to read
*-- a record from NETSPOOL.
*
*-- Entry:  INDATASET or NETSPOOL must be OPEN.
*-- Exit:  R0 = length of data read
*--        R1 -> data read
*--        R15= RC.  0=OK
*--                  4=Unexpected end of file
*--                  8=Read i/o error
*
GET000   EQU   *
         ST    R14,SV14GET
         TM    FLAGS3,F3INDS        INDATASET specified?
         BZ    GET030               No, use NETSPOOL
*
         LA    R2,NETDATA           -> DCB
         L     R0,BLOCK             -> read buffer
*
         READ  DECB,SF,(R2),(R0),'S',MF=E   Read block
         CHECK DECB
*
         CLI   DECB,X'7F'           Was read successful?
         BNE   GET090               No, read failed
*
         L     R0,BLOCKLEN          Get current block size
         L     R15,DECB+16          -> IOB addr
         SH    R0,14(,R15)          Compute size of block read
         L     R1,BLOCK             Return buffer addr
         SR    R15,R15              Set RC=0
         L     R14,SV14GET
         BR    R14                  Return w/len & addr in R0,R1
*
GET030   EQU   *
         LA    R1,NCB1              -> NCB
         NSIO  TYPE=GET,            TAG data contains file #           x
               NCB=(1),                                                x
               AREA=LIST                                           v200
         LTR   R15,R15              Any errors?
         BZ    GET040               No
         BAL   R14,FMT000           Display error
         B     GET090
*
GET040   EQU   *
         MVC   REC(133),BLANKS      Init receiving field           v200
         LH    R2,NCBRECLN-NCB(,R1) Get the record length          v200
         BCTR  R2,0                 Adjust for execute             v200
         EX    R2,MVSPL             Mv spool record to phy rec areav200
         LA    R1,REC               -> record
         LA    R0,80                Always 80
         SR    R15,R15              Set RC=0
         L     R14,SV14GET
         BR    R14                  Return w/len & addr in R0,R1
*
MVSPL    MVC   REC(0),LIST          executed instr                 v200
*
GET090   EQU   *
         LA    R15,8                Set RC=8 = Read error
         L     R14,SV14GET
         BR    R14                  Return
*
EOD000   EQU   *
         LA    R15,4                Set RC=4 = unexpected EOF
         L     R14,SV14GET
         BR    R14                  Return w/len & addr in R0,R1
*
*-- Find a PUBLIC volume for use in allocations
*
*-- Entry:  R0 = blksize of dataset to be allocated
*-- Exit:   CC=0 if no volume selected
*--         CC<>0 if volume selected, and,
*--           TVOLSER,DEVINFO fields are filled in.
*
*-- Uses R15-R3
*
GETVOL   EQU   *
         LA    R1,DISKS            -> dasd characteristics table
         USING DASDTAB,R1
*
GETV010  EQU   *
         SR    R3,R3               Clear for ICM
         L     R2,16               -> CVT
         USING CVT,R2
         L     R2,CVTILK2          -> UCB Lookup table
*
GETV020  EQU   *
         LA    R2,2(,R2)           -> first table entry
*
         CLC   0(2,R2),=X'FFFF'    End of UCBs?
         BE    GETV030             Y
         ICM   R3,3,0(R2)          -> UCB
         BZ    GETV020             Skip empty table slot
         USING IEFUCBOB,R3
         TM    UCBSTAT,UCBONLI     Is device online?
         BZ    GETV020             N, next UCB
         TM    UCBTBYT3,UCB3DACC   Direct access device?
         BZ    GETV020             N, next UCB
         CLC   UCBTBYT4,DASDTYPE   Preferred device type?
         BNE   GETV020             N, next UCB
         TM    UCBSTAB,UCBBPUB     PUBLIC volume?
         BZ    GETV020             N
         LA    R15,DASDSIZE        -> full track size for device
         CLC   DASDHTRK,=AL2(0)    Is a half-track blksize avail?
         BE    *+8                 No
         LA    R15,DASDHTRK        Yes, use 1/2 track for device
         CLM   R0,3,0(R15)         Will file blksize fit?
         BH    GETV030             Too large, get another dasd type
*
         ST    R1,DEVINFO          Save ptr to selected dev type
*                                  UCBNAME contains C'cuu'
         MVC   TVOLSER,UCBVOLI     Save selected volser to text unit
         CLI   *,1                 Set CC to non zero
         BR    R14
*
GETV030  EQU   *
         LA    R1,DASDLEN(,R1)     Next DASD device preference
         CLI   0(R1),X'FF'         End of DASD table?
         BER   R14                 Y, no suitable unit found, cc=0
         B     GETV010             Search again
         DROP  R3                  IEFUCBOB
         DROP  R2                  CVT                             v200
         DROP  R1                  DASDTAB
*
*-- Find a volser in the UCBs so we can get its devtype (cant use  v200
*-- DEVTYPE because it is not allocated yet) and determine its     v200
*-- maximum track size.                                            v200
*
*-- Entry:  R1 -> CL'volser' to be located                         v200
*-- Exit:   CC=0 if the volser was not found                       v200
*--         CC<>0 if volume found; and R15 = track size in bytes   v200
*
*-- Uses R15-R3                                                    v200
*
FNDVOL   EQU   *                                                   v200
         SR    R3,R3               Clear for ICM                   v200
         L     R2,16               -> CVT                          v200
         USING CVT,R2                                              v200
         L     R2,CVTILK2          -> UCB Lookup table             v200
         DROP  R2                  CVT                             v200
*
FNDV020  EQU   *                                                   v200
         LA    R2,2(,R2)           -> first table entry            v200
*                                                                  v200
         CLC   0(2,R2),=X'FFFF'    End of UCBs?                    v200
         BE    FNDV090             Y                               v200
         ICM   R3,3,0(R2)          -> UCB                          v200
         BZ    FNDV020             Skip empty table slot           v200
         USING IEFUCBOB,R3                                         v200
         TM    UCBSTAT,UCBONLI     Is device online?               v200
         BZ    FNDV020             N, next UCB                     v200
         TM    UCBTBYT3,UCB3DACC   Direct access device?           v200
         BZ    FNDV020             N, next UCB                     v200
         CLC   UCBVOLI,0(R1)       Selected volser?                v200
         BNE   FNDV020             No, next UCB                    v200
*
         LA    R1,DISKS            -> dasd characteristics table   v200
         USING DASDTAB,R1                                          v200
*
FNDV030  EQU   *                                                   v200
         CLI   0(R1),X'FF'         End of DASD types?              v200
         BE    FNDV090             Cant match volser vs devtype    v200
*
         CLC   UCBTBYT4,DASDTYPE   Match the device type?          v200
         BE    FNDV080             Yes                             v200
         LA    R1,DASDLEN(,R1)     Next DASD device in table       v200
         B     FNDV030             Look again                      v200
*
FNDV080  EQU   *                                                   v200
         SR    R15,R15             Clear for IC                    v200
         ICM   R15,3,DASDSIZE      Get full track size for device  v200
         CLI   *,1                 Set CC to non zero              v200
*
FNDV090  EQU   *                                                   v200
         BR    R14                 Return w CC=0 or CC<>0          v200
         DROP  R3                  IEFUCBOB                        v200
         DROP  R1                  DASDTAB                         v200
*
*
*-- Format VSAM NETSPOOL errors
*
*
FMT000   EQU   *
         STM   R14,R2,PARSA+12         Borrow NJEPAR save area
         LA    R15,0(,R14)  Clear high, Get addr of call to this rtn
         L     R2,NJESA+4              -> system provided FSA
         L     R2,16(,R2)              Get R15's entry point addr
         LA    R2,0(,R2)               Ensure high byte clear
         SR    R15,R2                  Compute offset of call
         MVC   LIST+0(4+L'MSG024T),MSG024 Move msg text
         MVC   LIST+55(8),5(R2)        Move csect name
         TRT   LIST+55(9),BLANK        Look for end of csect name
         MVI   0(R1),C'+'
*
         ST    R15,DBLE                Save call offset to work area
         UNPK  TWRK(5),DBLE+2(3)       Add zones
         TR    TWRK(4),HEXTRAN-240     Display hex
         MVC   1(4,R1),TWRK            Move call offset to msg
*
         LA    R15,NCB1
         UNPK  TWRK(5),NCBRTNCD-NCB(3,R15)  Add zones
         TR    TWRK(4),HEXTRAN-240
         MVC   LIST+35(4),TWRK         Move rtncd/errcd
*
         UNPK  TWRK(3),NCBREQ-NCB(2,R15)  Add zones
         TR    TWRK(2),HEXTRAN-240
         MVC   LIST+45(2),TWRK         Move req code
*
         L     R1,NCBMACAD-NCB(,R15)   Get failing VSAM macro addr
         LA    R1,0(,R1)               Clear high byte
         S     R1,=V(NJESPOOL)         Compute offset into NJESPOOL rtn
         ST    R1,DBLE
         UNPK  TWRK(5),DBLE+2(3)       Add zones
         TR    TWRK(4),HEXTRAN-240     Display hex
         MVC   LIST+50(4),TWRK         Move NJESPOOL offset to msg
*
         LA    R2,LIST
         BAL   R14,PUTLINE
*
FMT090   EQU   *
         LM    R14,R2,PARSA+12         Restore caller regs
         BR    R14                     Return
*
*-- Write a single line to terminal
*
*-- Entry: R2 -> output msg (RDW+msg text)
*-- Exit:  R15 = RC from PUTLINE
*
PUTLINE  EQU   *
         TM    FLAGS3,F3QUIET          QUIET mode enabled?
         BZ    PUT010                  No, proceed
         CLI   3(R2),1                 Suppress this msg in QUIET mode?
         BER   R14                     Yes
*
PUT010   EQU   *
         ST    R14,SV14LN              Save return
         XC    PUTECB,PUTECB           Clear PUTLINE ECB
         L     R15,CPARMS              -> command input CPPL
         USING CPPL,R15
         LA    R1,IOPLAREA             -> IOPL
         USING IOPL,R1
         MVC   IOPLUPT,CPPLUPT         Set UPT ptr
         MVC   IOPLECT,CPPLECT         Set ECT ptr
         DROP  R15                     CPPL
*
         MVC   TWRK(PBL),PB            Move macro model
         PUTLINE PARM=TWRK,            Write a line                    x
               ECB=PUTECB,                                             x
               OUTPUT=((R2),TERM,SINGLE,DATA),                         x
               MF=(E,(1))
         DROP  R1                      IOPL
         L     R14,SV14LN              Load return
         BR    R14
*
*
*-- Write a single line to terminal and prompt for response
*
*-- Entry: OLDMSGAD points to output message
*-- Exit:  R15 = RC from PUTGET
*--        PGPBIBUF -> input data (if any)
*
PUTGET   EQU   *
         ST    R14,SV14LN              Save return
         XC    PUTECB,PUTECB
         L     R15,CPARMS              -> command input CPPL
         USING CPPL,R15
         LA    R1,IOPLAREA             -> IOPL
         USING IOPL,R1
         MVC   IOPLUPT,CPPLUPT         Set UPT ptr
         MVC   IOPLECT,CPPLECT         Set ECT ptr
         DROP  R15                     CPPL
*
         MVC   MACLIST(PGTL),PGT       move macro model
         PUTGET PARM=MACLIST,                                          x
               ECB=PUTECB,                                             x
               OUTPUT=(OLD,SINGLE,PROMPT),                             x
               TERMPUT=(EDIT,WAIT,NOHOLD,NOBREAK),                     x
               TERMGET=(EDIT,WAIT),                                    x
               MF=(E,(1))
         DROP  R1                      IOPL
*
         LA    R5,MACLIST
         USING PGPB,R5
         L     R1,PGPBIBUF             -> input buffer acquired
         DROP  R5
         L     R14,SV14LN              Load return
         BR    R14
*
*-- Get status of NJE38
*
*-- Entry: R1=0 (no spool dsn needed), or, R1-> 44-char spool DSN area
*-- Exit:  RC=0  NJE38 is active; R1-> NJE38 CSA block
*--        RC<>0 NJE is not active.
*
CHK000   EQU   *
         LA    R1,TDSNAME              => where to place spool DSN v210
         L     R15,=V(NJESYS)          -> ENQ finder               v210
         BALR  R14,R15                 Check if NJE38 already act  v210
         LTR   R15,R15                 Set CC (RC=0 NJE38 active)  v210
         BNZR  R2                      Return if NJE38 inactive    v210
         MVC   LCLNODE,NJ38NODE-NJ38CSA(R1)  Save off lcl node namev210
         MVC   DEFUSER,NJ38DUSR-NJ38CSA(R1)  Save off default user v210
         BR    R2                      Return; NJE38 active        v210
*
         LTORG
*
PB       PUTLINE MF=L
PBL      EQU   *-PB
PGT      PUTGET MF=L
PGTL     EQU   *-PGT
*
NJE38Q   DC    CL8'NJE38'              QNAME
NJERCON  DC    CL8'NJEINIT'            RNAME (first 8 bytes)
*
*
*
BLANKS   DC    CL136' '                                            v200
NONBLANK DC    64X'FF',X'00',191X'FF'  TR Table to locate nonblank
BLANK    DC    64X'00',X'FF',191X'00'  TR Table to locate blanks
DOTS     DC    75X'00',X'FF',180X'00'  TR Table to locate '.' char
HEXTRAN  DC    CL16'0123456789ABCDEF'  Translate table
*
*-- RECEIVE messages
*
*-- Note:  a '1' after the length indicates suppress this msg if QUIET
*
MSGBLNK  DC    Y(4+L'MSGBLNKT,1)
MSGBLNKT DC    C' '
*
MSG000   DC    Y(4+L'MSG000T,1)
MSG000T  DC    C'NJE38 RECEIVE &VERS'
*
MSG001   DC    Y(4+L'MSG001T,0)
MSG001T  DC    C'Error parsing RECEIVE command parameters. IKJPARS RC=yx
               y (dec)'
*                456789012345678901234567890123456789012345678901234567
MSG002   DC    Y(4+L'MSG002T,0)
MSG002T  DC    C' '                   UNUSED - AVAILABLE
*
MSG003   DC    Y(4+L'MSG003T,0)
MSG003T  DC    C'Invalid or unsupported NETDATA detected; error code x,*
                record '
*
MSG004   DC    Y(4+L'MSG004T,0)
MSG004T  DC    C'Member xxxxxxxx was not found'
*                456789012345678901234567890123456789012345678901234567
*
MSG005   DC    Y(4+L'MSG005T,0)
MSG005T  DC    C'Unexpected end of file encountered reading '
*
MSG006   DC    Y(4+L'MSG006T,0)
MSG006T  DC    C'The RECEIVE command is not APF-authorized'
*
MSG007   DC    Y(4+L'MSG007T,0)
MSG007T  DC    C'I/O error reading '
*
MSG008   DC    Y(4+L'MSG008T,0)
MSG008T  DC    C'Specified INDATASET does not contain NETDATA formattedx
                records'
*
MSG009   DC    Y(4+L'MSG009T,0)
MSG009T  DC    C'Specified INDATASET must be LRECL=80, RECFM=F or FB'
*
MSG010   DC    Y(4+L'MSG010T,0)
MSG010T  DC    C'No files are available to receive'
*
MSG011   DC    Y(4+L'MSG011T,0)
MSG011T  DC    C'Specified file number does not exist'
*
MSG012   DC    Y(4+44+L'MSG012T,0)
MSG012T  DC    C'Allocation error xxxxxxxx, DSN='
*
MSG013   DC    Y(4+L'MSG013T,0)
MSG013T  DC    C'NJE38 is not active'
*
MSG014   DC    Y(4+L'MSG014T,1)
MSG014T  DC    C'Receiving '
*
MSG015   DC    Y(4+L'MSG015T,1)
MSG015T  DC    C' Enter receive parameters or ''PURGE'' or ''END'' +'
*
MSG016   DC    Y(4+L'MSG016T,0)
MSG016T  DC    C'Cannot receive file destined for another user'
*
MSG017   DC    Y(4+L'MSG017T,1)
MSG017T  DC    C'Receive into '
*
MSG018   DC    Y(4+L'MSG018T,0)
MSG018T  DC    C'Receive failed due to IEBCOPY RC=xx'
*                456789012345678901234567890123456789012345678901234567
*
MSG019   DC    Y(4+L'MSG019T,0)
MSG019T  DC    C'RECEIVE ended with no action taken'
*
MSG020   DC    Y(4+L'MSG020T,1)
MSG020T  DC    C' Enter receive parameters or ''END'' +'
*
MSG021   DC    Y(4+L'MSG021T,0)
MSG021T  DC    C'Member name ignored'
*
MSG022   DC    Y(4+L'MSG022T,0)
MSG022T  DC    C'No suitable PUBLIC volume found that can contain this x
               dataset'
*
MSG023   DC    Y(4+L'MSG023T,0)
MSG023T  DC    C'The BLKSIZE or LRECL of the received file exceeds the x
               32760-byte MVS limit'
*
MSG024   DC    Y(4+L'MSG024T,0)
MSG024T  DC    C'ERROR:  NETSPOOL RTNCD/ERRCD=X''0000'',REQ=01,O=1234,Mx
               MMMMMMM     '
*
MSG025   DC    Y(4+L'MSG025T,0)
MSG025T  DC    C'Unable to open NETSPOOL. Run IDCAMS VERIFY against thex
                NETSPOOL dataset'
*
MSG026   DC    Y(4+L'MSG026T,0)
MSG026T  DC    C'Error in terminal prompt message.  PUTGET RC=yy (dec)'
*                456789012345678901234567890123456789012345678901234567
*
MSG027   DC    Y(4+L'MSG027T,0)
MSG027T  DC    C' exists'
*
MSG028   DC    Y(4+L'MSG028T,1)
MSG028T  DC    C'File(xxxx) purged from NJE38 spool'
*
MSG029   DC    Y(4+L'MSG029T,0)
MSG029T  DC    C'RECEIVE ended without receiving anything'
*
MSG030   DC    Y(4+L'MSG030T,0)
MSG030T  DC    C'RECEIVE halted; unsupported message text (INMTEXT) detx
               ected'
*
MSG031   DC    Y(4+L'MSG031T,0)
MSG031T  DC    C' does not exist'
*
MSG032   DC    Y(4+L'MSG032T,0)
MSG032T  DC    C'Access to the NETSPOOL dataset denied due to security x
               settings'
*
MSG033   DC    Y(4+L'MSG033T,0)                                    v200
MSG033T  DC    C'Volume unavailable or conflicting with specified UNIT x
               name'                                               v200
*
MSG034   DC    Y(4+L'MSG034T,0)                                    v200
MSG034T  DC    C'The specified UNIT name is not defined in the system' x
                                                                   v200
*
MSG035   DC    Y(4+L'MSG035T,0)                                    v200
MSG035T  DC    C'Incoming file is a PDSE Program Library which cannot bx
               e supported'                                        v200
*
MSG036   DC    Y(4+L'MSG036T,0)                                    v200
MSG036T  DC    C'The selected volume is not online'                v200
*
MSG037   DC    Y(4+L'MSG037T,0)                                    v200
MSG037T  DC    C'The incoming file block size is too large to fit on thx
               e selected volume'                                  v200
*
MSG038   DC    Y(4+L'MSG038T,0)                                    v222
MSG038T  DC    C'The incoming file contains logical records that exceedx
                the LRECL of the dataset'                          v222
*                                                                       NJE00250
*                                                                       NJE00250
* DASD Characteristics in order of selection preference                 NJE00250
*                                                                       NJE00250
* NOTE:  3380 DASD exist in this table twice.  The reason for           NJE00250
*        this is to allow a better identification of the DASD           NJE00250
*        type required by "GETVOL" based on the received file's         NJE00250
*        BLKSIZE.  The file could be half-track blocked, so we          NJE00250
*        need to account for that in selecting a device type.           NJE00250
*        However, the file could be using a BLKSIZE that is             NJE00250
*        larger than the half track size despite the inefficiency.      NJE00250
*        For these cases, the last 3380 entry does not have             NJE00250
*        a half-track size value, allowing the GETVOL search to
*        succeed using the full track size which would accomodate
*        any MVS BLKSIZE that could be received.
*
*                                                                       NJE00250
DISKS    EQU   * TYP    CYLS    TRKS     BYTES    1/2-TRK
         DC    X'0E',AL2(885),AL1(15),AL2(47476),AL2(23476)  3380 A/D/J
         DC    X'0B',AL2(555),AL1(30),AL2(19069),AL2(0)      3350
         DC    X'0C',AL2(959),AL1(12),AL2(35616),AL2(17600)  3375
         DC    X'0F',AL2(1113),AL1(15),AL2(56664),AL2(27998) 3390-1
         DC    X'0D',AL2(808),AL1(19),AL2(13030),AL2(0)      3330-11
         DC    X'09',AL2(404),AL1(19),AL2(13030),AL2(0)      3330-1
         DC    X'0A',AL2(696),AL1(12),AL2(8368),AL2(0)       3340-70
         DC    X'08',AL2(200),AL1(20),AL2(7294),AL2(0)       2314
         DC    X'0E',AL2(885),AL1(15),AL2(47476),AL2(0)      3380 A/D/J
         DC    X'FF'                End of table
*                                                                       NJE00250
DASDTAB  DSECT
DASDTYPE DS    X                    Dasd UCB device type code
DASDCYLS DS    AL2                  Number of cylinders
DASDTRKS DS    AL1                  Number of tracks
DASDSIZE DS    AL2                  Bytes per track
DASDHTRK DS    AL2                  Bytes per half-track block or 0
DASDLEN  EQU   *-DASDTAB            Size of one DASDTAB entry
*
*                                                                       NJE00250
*********************
*  N J E N O T      *               NJENOT tells the user the chosen
*                   *               DSN of the file and prompts for
*  User notify and  *               changes
*  prompt           *
*                   *
*********************
*
*
NJENOT   CSECT
         B     28(,R15)               BRANCH AROUND EYECATCHERS
         DC    AL1(23)                LENGTH OF EYECATCHERS
         DC    CL9'NJENOT'
         DC    CL9'&SYSDATE'
         DC    CL5'&SYSTIME'
*
         STM   R14,R12,12(R13)         Save Regs                        NJE00050
         LR    R12,R15                 Base                             NJE00060
         USING NJENOT,R12                                               NJE00070
         USING NJEWK,R10
         ST    R13,NOTSA+4             SAVE prv S.A. ADDR               NJE00080
         LA    R2,NOTSA                -> my save area
         ST    R2,8(,R13)              Plug it into prior SA
         LR    R13,R2
*
NOT000   EQU   *
         BAL   R14,BDS000              Build final dataset name
         BAL   R14,NTF000              Build notification msg
*
         TM    FLAGS2,F2FEND           END forced previously?
         BO    XITNOT04                Force 'END' again
*
         LA    R2,LIST                 -> MSG014 receiving dataset...
         BAL   R14,PUTLINE             Notify user
*
         TM    FLAGS1,F1BATCH          Are we in BATCH mode?
         BO    NOT090                  Yes, special handling
         TM    FLAGS3,F3NPRMPT         Are we in NOPROMPT mode?
         BO    NOT090                  Yes, special handling
*
         LA    R1,MSG015               -> enter parameters prompt
         TM    FLAGS3,F3INDS           Was INDATASET specified?
         BZ    NOT010                  No
         LA    R1,MSG020               Use MSG020 if INDS in use
*
NOT010   EQU   *
         ST    R1,OLDMSGAD             Set it in the OLD
         BAL   R14,PUTGET              Prompt the user
         C     R15,=F'8'               PUTGET ECB posted (attn recv'd)?
         BE    XITNOT04                Yes, treat as 'END' specified
         LTR   R0,R15                  PUTGET RC to R0
         BNZ   XITNOT16                Exit if putget error
*
         ST    R1,OLDMSGAD             Temp save of PUTGET input ptr
         LA    R0,4                    Code 4: use prompt parameters
*                                      R1 -> PUTGET input buffer
         L     R15,=A(NJEPAR)          -> parse routine
         BALR  R14,R15
         LR    R5,R15                  Any errors to R5
*
         TM    FLAGS4,F4ATTN           Was ATTN pressed?           v201
         BO    XITNOT04                Y, immediate exit           v201
*
         L     R1,OLDMSGAD             -> PUTGET input buffer
         LH    R0,0(,R1)               Get length of area
         O     R0,=X'01000000'         Set SP=1
         FREEMAIN R,LV=(0),A=(1)       Free the PUTGET msg buffer
*
         LTR   R0,R5                   Now put IKJPARS RC in R0
         BNZ   XITNOT12                Display IJKPARS RC
         TM    FLAGS4,F4END            Was END specified?
         BO    XITNOT04                Exit if END
         TM    FLAGS4,F4PURGE          Was PURGE specified?
         BO    XITNOT08                Exit if PURGE
         B     XITNOT00
*
*-- If running BATCH, allow one trip through here to exit cleanly
*-- to simulate pressing "enter" with no parameters.  On all
*-- subsquent calls to NJENOT, F2END will be set (if BATCH) so
*-- we can force END in order to prevent looping in batch.
*
NOT090   EQU   *
         OI    FLAGS2,F2FEND           Indic force END from now on
         B     XITNOT00                Allow null prompt this time
*
*-- Build DSN
*
*-- DSN Strategy:  The DSN from the NETDATA will be extracted and
*-- the first qualifer eliminated, unless the DSN is only one
*-- qualifier.  Then, the remaining part of that DSN will be appended
*-- to the receiving user's userid  (the userid will be the new
*-- first qualifier.
*
*-- If the incoming file is a flat file (not NETDATA) the DSNAME is
*-- manufactured from the filename and filetype fields of the TAG data.
*
*-- If DATASET was specified on the command line (F3DS=1) then we
*-- will attempt to use that as is and exit the build DS routine.
*
BDS000   EQU   *
         TM    FLAGS3,F3DS             Is final dataset already set?
         BOR   R14                     Exit if we already have it
         MVC   FINALDS,BLANKS          Init
         MVC   FINALDS(8),USERID       Move userid
         TM    FLAGS2,F2FLAT           Is incoming file a flat file?
         BO    BDS020                  Yes, use tag data
*
         LA    R7,INMF02A              -> first INMR02 results
         USING INMFIELD,R7
*
         SR    R4,R4                   Clear for IC
         ICM   R4,3,DSNAME             Get NETDATA DSN length
         LA    R1,DSNAME+2             Assume DSN has 1 qualifier
         TRT   DSNAME+2(10),DOTS       Look for end of 1st qualifier
         BZ    BDS010                  Branch if only 1 qualifier
         LA    R1,1(,R1)               Skip the delim after 1st qualifr
         LR    R0,R1                   Copy position
         LA    R2,DSNAME+2             Start of DSN
         SR    R0,R2                   Compute length we are skipping
         SR    R4,R0                   Reduce remaining DSN length
*
BDS010   EQU   *
         LR    R3,R1                   Save start of NETDATA DSN
         TRT   FINALDS(9),BLANK        Look for end of userid
         MVI   0(R1),C'.'              Add delimiter
         LA    R1,1(,R1)               -> next available byte
         LA    R2,FINALDS              -> start of userid
         LR    R0,R1                   Copy next available byte addr
         SR    R0,R2                   Compute userid. length
         LA    R15,43                  Total DSN length -1 for execute
         SR    R15,R0                  Compute remaining available
         CR    R15,R4                  Use lesser remaining length
         BL    *+6                     Br if TDSNAME length is less
         LR    R15,R4                  No, NETDATA DSN len is less
         EX    R15,MVCDSN              Move the rest of it
*MVCDSN  MVC   0(0,R1),0(R3)
         CLI   FINALDS+43,C'.'         Last char of DSN is a delim?
         BNER  R14                     No
         MVI   FINALDS+43,C' '         Blank it out
         DROP  R7                      INMFIELD
         BR    R14                     Return
*
BDS020   EQU   *
         LA    R4,TAGDATA              -> Spool file's tag data
         USING TAG,R4
*
         LA    R1,FINALDS              -> final dsname area
         TRT   0(9,R1),BLANK           Look for end of userid
         MVI   0(R1),C'.'              Add delimiter
         LA    R1,1(,R1)               -> next available byte
         MVC   0(8,R1),TAGNAME         Insert tag's file name
         TRT   0(9,R1),BLANK           Find the end of it
         MVI   0(R1),C'.'              Add delimiter
         LA    R1,1(,R1)               -> next available byte
         MVC   0(8,R1),TAGTYPE         Insert tag's file name
         DROP  R4                      TAG
         BR    R14                     Return
*
*
MVCDSN   MVC   0(0,R1),0(R3)           executed instr
*
*
*-- Build msg containing incoming dataset name from the netdata
*
NTF000   EQU   *
         MVC   LIST,BLANKS
         MVC   LIST(4+L'MSG014T),MSG014  'Receiving ...'
         LA    R1,LIST+4+L'MSG014T     -> next available byte
         MVI   0(R1),C''''             Move apost
         LA    R1,1(,R1)               Next byte
*
         TM    FLAGS2,F2FLAT           Is incoming file a flat file?
         BO    NTF020                  Yes, use tag data
*
         LA    R7,INMF02A              -> First INMR02 data
         USING INMFIELD,R7
         MVC   0(44,R1),DSNAME+2       Move incoming DSN
         TRT   0(45,R1),BLANK          Look for end of DSN
         MVI   0(R1),C''''             Move apost
         LA    R1,2(,R1)               -> skip over apost + 1 blank
         MVC   0(4,R1),=C'from'
         LA    R1,5(,R1)               -> where to put node id
         LA    R7,INMF01               -> INMR01 data
         USING INMFIELD,R7
         MVC   0(8,R1),FNODE+2         Move from node name
         TRT   0(9,R1),BLANK           Look for end of nodeid
         MVI   0(R1),C'('              Insert (
         MVC   1(8,R1),FUSER+2         Move from user name
         DROP  R7                      INMFIELD
         TRT   1(9,R1),BLANK           Look for end of userid
         MVI   0(R1),C')'              Insert )
         LA    R1,1(,R1)               -> end of msg
         LA    R0,LIST                 -> start of msg
         ST    R0,OLDMSGAD             Set msg ptr
         SR    R1,R0                   Compute length of msg
         STH   R1,LIST                 Set length of msg for PUTGET
         BR    R14                     Return
*
*-- Build msg containing incoming dataset name from the tag data
*
NTF020   EQU   *
         LA    R4,TAGDATA              -> Spool file's tag data
         USING TAG,R4
*
         MVC   0(8,R1),TAGNAME         Insert tag's file name
         TRT   0(9,R1),BLANK           Find the end of it
         LA    R1,1(,R1)               -> next available byte
         MVC   0(8,R1),TAGTYPE         Insert tag's file name
         TRT   0(9,R1),BLANK           Find the end of it
         MVI   0(R1),C''''             Move apost
         LA    R1,2(,R1)               -> skip over apost + 1 blank
         MVC   0(4,R1),=C'from'
         LA    R1,5(,R1)               -> where to put node id
         MVC   0(8,R1),TAGINLOC        Move from node name
         TRT   0(9,R1),BLANK           Look for end of nodeid
         MVI   0(R1),C'('              Insert (
         MVC   1(8,R1),TAGINVM         Move from user name
         DROP  R4                      TAG
         TRT   1(9,R1),BLANK           Look for end of userid
         MVI   0(R1),C')'              Insert )
         LA    R1,1(,R1)               -> end of msg
         LA    R0,LIST                 -> start of msg
         ST    R0,OLDMSGAD             Set msg ptr
         SR    R1,R0                   Compute length of msg
         STH   R1,LIST                 Set length of msg for PUTGET
         BR    R14                     Return
*
*-- Exit
*
XITNOT00 EQU   *
         SR    R0,R0               Set secondary RC=0;
         SR    R15,R15             Set RC=0; normal
         B     XITNOT
*
XITNOT04 EQU   *
         SR    R0,R0               Set secondary RC=0;
         LA    R15,4               Set RC=4;  END specified
         B     XITNOT
*
XITNOT08 EQU   *
         SR    R0,R0               Set secondary RC=0;
         LA    R15,8               Set RC=8;  PURGE specified
         B     XITNOT
*
XITNOT12 EQU   *
         LA    R15,12              Set RC=12; secondary is IKJPARS RC
         B     XITNOT
*
XITNOT16 EQU   *
         LA    R15,16              Set RC=16; secondary is PUTGET RC
*
XITNOT   EQU   *
         L     R13,4(,R13)         -> prev s.a.
         L     R14,12(,R13)        Load r14
         LM    R1,R12,24(R13)      Reload callers regs
         BR    R14                 Return with RCs in R0/R15
*
         LTORG
*                                                                       NJE00250
*                                                                       NJE00250
*********************
*  N J E D Y N      *               NJEDYN handles the various
*                   *               dynamic allocations required
*  Handle DYNALLOC  *               and their unallocations as well.
*                   *
*********************
*
         USING INMFIELD,R7          -> R7 at entry
*
NJEDYN   CSECT
         B     28(,R15)               BRANCH AROUND EYECATCHERS
         DC    AL1(23)                LENGTH OF EYECATCHERS
         DC    CL9'NJEDYN'
         DC    CL9'&SYSDATE'
         DC    CL5'&SYSTIME'
*
         STM   R14,R12,12(R13)         Save Regs                        NJE00050
         LR    R12,R15                 Base                             NJE00060
         USING NJEDYN,R12                                               NJE00070
         USING NJEWK,R10
         ST    R13,DYNSA+4             SAVE prv S.A. ADDR               NJE00080
         LA    R1,DYNSA                -> my save area
         ST    R1,8(,R13)              Plug it into prior SA
         LR    R13,R1
*
         MVC   LS99RB,CPS99RB          init THE S99RB
         LA    R1,LS99RB               -> S99RB
         USING S99RB,R1
         ST    R1,LS99PTR              Set parameter word
         OI    LS99PTR,X'80'           Set VL
         LA    R6,TXTPTRS              -> start of text unit list
         ST    R6,S99TXTPP             Put in S99RB
         DROP  R1                      S99RB
*
UNDYN    EQU   0                   00  unallocate DDNAME
DYNINMCP EQU   4                   04  Allocate INMCOPY dataset
DYNSYSIN EQU   8                   08  Allocate SYSIN for IEBCOPY
DYNSYSPR EQU   12                  0C  Allocate SYSPRINT for IEBCOPY
DYNFINAL EQU   16                  10  Allocate final dataset IEBCOPY
DYNSYSU3 EQU   20                  14  Allocate SYSUT3 IEBCOPY
DYNINDS  EQU   24                  18  Allocate INDATASET
DYNETSPL EQU   28                  1C  Allocate NETSPOOL
*
         LR    R5,R0                   Copy action code
         B     DYN000(R5)              Branch into table
*
DYN000   B     DYN010              00  Perform DDNAME Unallocation
         B     DYN100              04  Allocate INMCOPY dataset
         B     DYN200              08  Allocate SYSIN for IEBCOPY
         B     DYN300              0C  Allocate SYSPRINT for IEBCOPY
         B     DYN400              10  Allocate final dataset IEBCOPY
         B     DYN500              14  Allocate SYSUT3 IEBCOPY
         B     DYN600              18  Allocate INDATASET
         B     DYN700              1C  Allocate NETSPOOL
*
DYN010   EQU   *
         MVC   UTXT,UTXTD              Init text unit
         LA    R1,LS99RB               -> S99RB
         USING S99RB,R1
         MVI   S99VERB,S99VRBUN        Set verb code to unallocation
         DROP  R1                      S99RB
*
         LA    R0,UTXT                 -> UNALLOC DD text unit
         ST    R0,0(,R6)               Plug into ptr list
         OI    0(R6),X'80'             End the parameter list
         B     DYN900                  Deallocate the DD
*
*-- Dataset created for INMCOPY INMR02 control record
*
*-- If there is no DSN, this is a temporary 'unloaded pds' dataset and
*-- no volser is used and can be allocated on a storage volume.
*
*   Equivalent JCL:
*   //SYS00000 DD DISP=(NEW,DELETE),UNIT=SYSDA,
*   //            SPACE=(blk,(pri,sec)),
*   //            DCB=(BLKSIZE=blk,LRECL=l,RECFM=f,DSORG=PS)
*
*-- If there is a DSN, then this is a final dataset, so use the
*-- dsname text unit and place it on the volser of choise.
*
*   Equivalent JCL:
*   //SYS00000 DD DISP=(NEW,CATLG),UNIT=SYSDA,
*   //            SPACE=(blk,(pri,sec)),
*   //            DCB=(BLKSIZE=blk,LRECL=l,RECFM=f,DSORG=PS),
*   //            DSN=dsname,VOL=SER=volser
*
DYN100   EQU   *
         MVC   TXT01,TXT01D            Init from the models
         MVC   TXT02,TXT02D
         MVC   TXT03,TXT03D
         MVC   TXT04,TXT04D
         MVC   TXT05,TXT05D
         MVC   TXT06,TXT06D
         MVC   TXT07,TXT07D
         MVC   TXT09,TXT09D
         MVC   TXT10,TXT10D
         MVC   TXT12,TXT12D
         MVC   TXT13,TXT13D
         MVC   TXT14,TXT14D
         MVC   TXT15,TXT15D
*
         LA    R0,TXT01                -> Return DDNAME text unit
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT03                -> DISP text unit 1
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT04                -> DISP text unit 2
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT12                -> BLKSIZE text unit
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT05                -> BLKLEN text unit
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT14                -> LRECL text unit
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT15                -> RECFM text unit
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT06                -> PRIMARY text unit
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT07                -> SECONDARY text unit
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT13                -> DSORG text unit
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT10                -> UNIT text unit
         ST    R0,0(,R6)               Plug into ptr list
*
         CLC   DSNAME(2),=AL2(0)       Was there a DSN?
         BNE   DYN120                  Yes, plug DSN & VOL text unit
         MVI   TXT04+6,X'04'           No, its a temp; set DISP=,DELETE
*v223    B     DYN190                  Then skip DSN text unit     v200
         B     DYN130                  Process remaining txt units v223
*
DYN120   EQU   *
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT02                -> DSN text unit
         ST    R0,0(,R6)               Plug into ptr list
*
DYN130   EQU   *                                                   v223
         TM    FLAGS2,F2UNIT           Was UNIT specified?         v200
         BZ    DYN170                  No, leave default           v200
         MVC   TUNIT,USRUNIT           Set user's unit name        v200
         TM    FLAGS3,F3VOLSER         Did user specify VOLSER?    v200
         BO    DYN170                  Yes, use what he coded      v200
         TM    FLAGS4,F4VOLSER         Did user specify VOLSER?    v200
         BO    DYN170                  Yes, use what he coded      v200
         B     DYN190                  UNIT without VOLSER specif'dv200
*
DYN170   EQU   *                       Use specified VOL or GETVOL v200
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT09                -> VOLSER text unit
         ST    R0,0(,R6)               Plug into ptr list
*
DYN190   EQU   *                                                   v200
         OI    0(R6),X'80'             End the parameter list
         B     DYN900                  Go allocate
*
*-- SYSIN for IEBCOPY
*
*   Equivalent JCL:
*   //SYS00000 DD DUMMY
*
*
DYN200   EQU   *
         MVC   TXT01,TXT01D            Init from the models
         MVC   TXT16,TXT16D
         LA    R0,TXT01                -> return DDNAME
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT16                -> DUMMY
         ST    R0,0(,R6)               Plug into ptr list
         OI    0(R6),X'80'             End the parameter list
         B     DYN900                  Go allocate
*
*-- SYSPRINT for IEBCOPY
*
*   Equivalent JCL:
*   //SYS00000 DD SYSOUT=*,TERM=TS
*
DYN300   EQU   *
         MVC   TXT01,TXT01D            Init from the models
         MVC   TXT16,TXT16D
         MVC   TXT17,TXT17D
         MVC   TXT18,TXT18D
         LA    R0,TXT01                -> return DDNAME
         ST    R0,0(,R6)               Plug into ptr list
*
         TM    FLAGS3,F3QUIET          QUIET mode enabled?
         BO    DYN310                  Yes, use DUMMY
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT17                -> SYSOUT=*
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT18                -> TERM=TS
         ST    R0,0(,R6)               Plug into ptr list
         B     DYN320
*
DYN310   EQU   *
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT16                -> DUMMY
         ST    R0,0(,R6)               Plug into ptr list
*
DYN320   EQU   *
         OI    0(R6),X'80'             End the parameter list
         B     DYN900                  Go allocate
*
*-- Final dataset that IEBCOPY will load
*
*   Equivalent JCL:
*   //SYS00000 DD DISP=(NEW,CATLG),UNIT=SYSDA,
*   //            SPACE=(blk,(pri,sec)),
*   //            DCB=(BLKSIZE=blk,LRECL=l,RECFM=f,DSORG=PO),
*   //            DSN=dsname,VOL=SER=volser
*
DYN400   EQU   *
         MVC   TXT01,TXT01D            Init from the models
         MVC   TXT02,TXT02D
         MVC   TXT03,TXT03D
         MVC   TXT04,TXT04D
         MVC   TXT05,TXT05D
         MVC   TXT06,TXT06D
         MVC   TXT07,TXT07D
         MVC   TXT08,TXT08D
         MVC   TXT09,TXT09D
         MVC   TXT10,TXT10D
         MVC   TXT12,TXT12D
         MVC   TXT13,TXT13D
         MVC   TXT14,TXT14D
         MVC   TXT15,TXT15D
*
         LA    R0,TXT01                -> Return DDNAME text unit
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT03                -> DISP text unit 1
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT04                -> DISP text unit 2
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT12                -> BLKSIZE text unit
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT05                -> BLKLEN text unit
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT14                -> LRECL text unit
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT15                -> RECFM text unit
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT06                -> PRIMARY text unit
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT07                -> SECONDARY text unit
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT08                -> DIRECTORY BLOCKS text unit
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT13                -> DSORG text unit
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT02                -> DSN text unit
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot       v200
         LA    R0,TXT10                -> UNIT text unit           v200
         ST    R0,0(,R6)               Plug into ptr list          v200
*
         TM    FLAGS2,F2UNIT           Was UNIT specified?         v200
         BZ    DYN470                  No, leave default           v200
         MVC   TUNIT,USRUNIT           Set user's unit name        v200
         TM    FLAGS3,F3VOLSER         Did user specify VOLSER?    v200
         BO    DYN470                  Yes, use what he coded      v200
         TM    FLAGS4,F4VOLSER         Did user specify VOLSER?    v200
         BO    DYN470                  Yes, use what he coded      v223
         B     DYN490                  UNIT without VOLSER specif'dv200
*
DYN470   EQU   *                       Use specified VOL or GETVOL v200
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT09                -> VOLSER text unit
         ST    R0,0(,R6)               Plug into ptr list
*
DYN490   EQU   *                                                   v200
         OI    0(R6),X'80'             End the parameter list
         B     DYN900                  Go allocate
*
*-- SYSUT3 for IEBCOPY
*
*   Equivalent JCL:
*   //SYS00000 DD DISP=(NEW,DELETE),UNIT=SYSDA,
*   //            SPACE=(CYL,5)
*
DYN500   EQU   *
         MVC   TXT01,TXT01D            Init from the models
         MVC   TXT03,TXT03D            DISP 1
         MVC   TXT04,TXT04D            DISP 2
         MVC   TXT06,TXT06D            PRIME
         MVC   TXT10,TXT10D            UNIT
         MVC   TXT19,TXT19D            CYL
*
         MVI   TXT04+6,X'04'           Adjust to DISP=,DELETE
         MVC   TXT06+6(3),=XL3'05'     5 cylinders
*
         LA    R0,TXT01                -> return DDNAME
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT03                -> DISP=NEW
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT04                -> DISP=,DELETE
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT06                -> Primary space
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT10                -> UNIT
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT19                -> SPACE CYL
         ST    R0,0(,R6)               Plug into ptr list
         OI    0(R6),X'80'             End the parameter list
         B     DYN900                  Go allocate
*
*-- Dataset INDATASET
*
*   Equivalent JCL:
*   //SYS00000 DD DISP=SHR,DSNAME=indataset
*
DYN600   EQU   *
         MVC   TXT01,TXT01D            Init from the models
         MVC   TXT02,TXT02D
         MVC   TXT03,TXT03D
         MVC   TXT13,TXT13D
*
         MVI   TXT03+6,X'08'           set DISP=SHR
         MVC   TXT13(2),=Y(DALRTORG)   set RETURN DSORG
*
         LA    R0,TXT01                -> return DDNAME
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT03                -> DISP=SHR
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT13                -> DSORG
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT02                -> DSNAME
         ST    R0,0(,R6)               Plug into ptr list
*
DYN610   EQU   *
         OI    0(R6),X'80'             End the parameter list
         B     DYN900                  Go allocate
*
*-- Dataset NETSPOOL
*
*   Equivalent JCL:
*   //NETSPOOL DD DISP=SHR,DSNAME=NJE38.NETSPOOL
*
*
DYN700   EQU   *
         MVC   TXT01,TXT01D            Init from the models
         MVC   TXT02,TXT02D
         MVC   TXT03,TXT03D
*
         MVC   TXT01(2),=Y(DALDDNAM)   Use fixed DD
         MVI   TXT03+6,X'08'           set DISP=SHR
*
         LA    R0,TXT01                -> DDNAME
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT03                -> DISP=SHR
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT02                -> DSNAME
         ST    R0,0(,R6)               Plug into ptr list
*
         OI    0(R6),X'80'             End the parameter list
         B     DYN900                  Go allocate
*
*-- Allocate the dataset
*
DYN900   EQU   *
         LA    R1,LS99RB               -> S99RB
         USING S99RB,R1
         OI    S99FLAG1,S99NOCNV        FORCE NEW ALLOCATION
         DROP  R1
         LA    R1,LS99PTR               POINTER TO S99 PTR
         SVC   99                       ISSUE DYNALLOC
         LTR   R15,R15                  Any errors?
         BZ    XITDYN00                 No
*
         LA    R1,LS99RB
         USING S99RB,R1
         UNPK  TWRK(9),S99ERROR(5)      Add zones to error code
         L     R4,S99ERROR              Error code in R4 for later v200
         DROP  R1
         TR    TWRK(8),HEXTRAN-240
         CLI   TWRK+1,C'7'              Class 7 error code?
         BNE   ERR012                   No
         LA    R1,DYNINMCP              Code for the INMCOPY dataset?
         CR    R1,R5                    Was alloc for DYNINMCP?
         BE    ERR027                   Yes, dataset exists
         LA    R1,DYNFINAL              Code for the final dataset?
         CR    R1,R5                    Was alloc for DYNFINAL?
         BE    ERR027                   Yes, dataset exists
         LA    R1,DYNINDS               Code for the INDATASET?
         CR    R1,R5                    Was alloc for DYNINDS?
         BE    ERR031                   Yes, dataset does not exist
*
ERR012   EQU   *
         MVC   LIST(4+L'MSG012T),MSG012 Dyn alloc failure msg
         MVC   LIST+21(8),TWRK          Error codes to line
         MVC   LIST+35(44),TDSNAME      Move DSNAME
         LA    R2,LIST                  -> msg
         BAL   R14,PUTLINE              Display it
         CLM   R4,12,=X'0218'           volume conflict/invalid?   v200
         BE    ERR033                   Yes                        v200
         CLM   R4,12,=X'021C'           Unit undefined?            v200
         BE    ERR034                   Yes                        v200
         B     XITDYN08                 General allocation failure
*
ERR027   EQU   *
         MVC   LIST,BLANKS
         MVC   LIST+4(9),=C'Dataset '''
         MVC   LIST+13(44),TDSNAME Move name
         TRT   LIST+13(45),BLANK   Look for end of name
         MVI   0(R1),C''''         Close apost
         LA    R1,1(,R1)           Skip apost
         MVC   0(L'MSG027T,R1),MSG027T  Move rest of msg
         LA    R1,L'MSG027T(,R1)   point to end
         XC    LIST(4),LIST        Clear RDW area
         LA    R2,LIST             -> start of RDW+msg
         SR    R1,R2               Compute total length
         STH   R1,LIST             Plug RDW
         BAL   R14,PUTLINE         Inform user
         B     XITDYN04            And exit with dataset exists
*
ERR031   EQU   *
         MVC   LIST,BLANKS
         MVC   LIST+4(9),=C'Dataset '''
         MVC   LIST+13(44),TDSNAME Move name
         TRT   LIST+13(45),BLANK   Look for end of name
         MVI   0(R1),C''''         Close apost
         LA    R1,1(,R1)           Skip apost
         MVC   0(L'MSG031T,R1),MSG031T  Move rest of msg
         LA    R1,L'MSG031T(,R1)   point to end
         XC    LIST(4),LIST        Clear RDW area
         LA    R2,LIST             -> start of RDW+msg
         SR    R1,R2               Compute total length
         STH   R1,LIST             Plug RDW
         BAL   R14,PUTLINE         Inform user
         B     XITDYN04            And exit with dataset doesnt exist
*
ERR033   EQU   *                                                   v200
         LA    R2,MSG033           -> msg (inv unit/volser combo)  v200
         BAL   R14,PUTLINE              Display it                 v200
         B     XITDYN08                                            v200
*
ERR034   EQU   *                                                   v200
         LA    R2,MSG034           -> msg (undefined unit)         v200
         BAL   R14,PUTLINE              Display it                 v200
         B     XITDYN08                                            v200
*
*
*-- Exit
*
XITDYN00 EQU   *
         SR    R15,R15             Set RC=0;  alloc/dealloc ok
         B     XITDYN
*
XITDYN04 EQU   *
         LA    R15,4               Set RC=4;  Exit for special action
         B     XITDYN
*
XITDYN08 EQU   *
         LA    R15,8               Set RC=8;  allocation error
*
XITDYN   EQU   *
         L     R13,4(,R13)         -> prev s.a.
         ST    R15,16(,R13)        Set RC
         LM    R14,R12,12(R13)     Reload callers regs
         BR    R14                 Return with RC
*
         LTORG
         DROP  R7                  INMFIELD
*
*
*
*-- Text unit skeletons
*
*-- Note:  EXPDT is included for completeness but is not used.
*
*
*
TXT01D   DC    Y(DALRTDDN),AL2(1),AL2(8)          RETURN DDNAME
TXT02D   DC    Y(DALDSNAM),AL2(1),AL2(44)         DSNAME
TXT03D   DC    Y(DALSTATS),AL2(1),AL2(1),X'04'    DISP=(NEW,)
TXT04D   DC    Y(DALNDISP),AL2(1),AL2(1),X'02'    DISP=(,CATLG)
TXT05D   DC    Y(DALBLKLN),AL2(1),AL2(3)          BLK TEXT KEY, BLKLEN
TXT06D   DC    Y(DALPRIME),AL2(1),AL2(3)          PRIMARY SPACE UNITS
TXT07D   DC    Y(DALSECND),AL2(1),AL2(3)          SECONDARY SPACE UNITS
TXT08D   DC    Y(DALDIR),AL2(1),AL2(3)            DIRECTORY BLOCKS
TXT09D   DC    Y(DALVLSER),AL2(1),AL2(6)          VOLSER
TXT10D   DC    Y(DALUNIT),AL2(1),AL2(8),CL8'SYSDA'  UNIT default   v200
TXT11D   DC    Y(DALEXPDT),AL2(1),AL2(5)          EXPDT C'YYDDD'
TXT12D   DC    Y(DALBLKSZ),AL2(1),AL2(2)          BLKSIZE
TXT13D   DC    Y(DALDSORG),AL2(1),AL2(2)          DSORG
TXT14D   DC    Y(DALLRECL),AL2(1),AL2(2)          LRECL
TXT15D   DC    Y(DALRECFM),AL2(1),AL2(1)          RECFM
TXT16D   DC    Y(DALDUMMY),AL2(0)                 DUMMY
TXT17D   DC    Y(DALSYSOU),AL2(0)                 SYSOUT
TXT18D   DC    Y(DALTERM),AL2(0)                  TERM
TXT19D   DC    Y(DALCYL),AL2(0)                   CYLINDER
TXT20D   DC    Y(DALCLOSE),AL2(0)                 FREE=CLOSE
*
UTXTD    DC    Y(DUNDDNAM),AL2(1),AL2(8)          DD for deallocation
*
         DS    0F
CPS99RB  DS    0XL20                   DEFINE INITIAL S99RB
         DC    AL1(20)                 LENGTH OF REQ BLOCK
         DC    AL1(1)                  VERB CODE:  ALLOCATION
         DC    X'20'                   FLAGS:  NO MOUNTS,OFFLINE VOLS
         DC    X'00'                   FLAGS
         DC    AL2(0)                  ERROR REASON CODE
         DC    AL2(0)                  INFO REASON CODE
         DC    A(0)                    ADDR OF TEXT PTRS
         DC    A(0)                    ADDR OF RBX
         DC    AL4(0)                  MORE FLAGS
*                                                                       NJE00250
*                                                                       NJE00250
*********************
*  N J E N E T      *               NJENET determines if NETDATA
*                   *               exists in a spool file and
*  Examine NETDATA  *               examines the INMR02 control
*                   *               record for attributes
*********************
*
NJENET   CSECT
         B     28(,R15)               BRANCH AROUND EYECATCHERS
         DC    AL1(23)                LENGTH OF EYECATCHERS
         DC    CL9'NJENET'
         DC    CL9'&SYSDATE'
         DC    CL5'&SYSTIME'
*
         STM   R14,R12,12(R13)         Save Regs                        NJE00050
         LR    R12,R15                 Base                             NJE00060
         USING NJENET,R12                                               NJE00070
         USING NJEWK,R10
         ST    R13,NETSA+4             SAVE prv S.A. ADDR               NJE00080
         LA    R1,NETSA                -> my save area
         ST    R1,8(,R13)              Plug it into prior SA
         LR    R13,R1
*
         LR    R15,R0                  Copy action code
         B     FUNC000(R15)            Branch into table
*
FUNC000  B     PINIT000            00  Process initial ctl records
         B     PDATA000            04  Process netdata records
         B     PFLAT000            08  Process flat records
*
*-- Find INMR01 record                                                  NET00060
*                                                                       NET00060
PINIT000 EQU   *
         LA    R0,2                    # of bytes to get                NET00070
         BAL   R14,GETBYTES            Get length and desc of segment   NET00080
         MVC   CTL,1(R1)               Save copy of descriptor byte
*                                                                       NET00090
         CLI   CTL,X'E0'               Valid 1st control rec indic?v200 NET00100
         BE    PINIT010                Could be ok                 v200 NET00110
         CLI   CTL,X'A0'               Valid 1st control rec indic?v200 NET00100
         BNE   XITNET04                No, its not NETDATA         v200 NET00110
*                                                                       NET00120
PINIT010 EQU   *                                                   v200
         L     R2,GBRPS                -> phys record position     v200
         CLC   0(6,R2),INMR01          Peek ahead. INMR01?         v200
         BNE   XITNET04                No, its not NETDATA         v200
*
         SR    R0,R0                                                    NET00130
         IC    R0,0(,R1)               Get segment length byte          NET00140
         S     R0,=F'2'                Less 2 we already retrieved      NET00150
         LR    R3,R0                   Copy length of control record    NET00300
         BAL   R14,GETBYTES            Get control record               NET00160
*                                                                       NET00170
         CLC   0(6,R1),INMR01          NETDATA?                         NET00180
         BNE   XITNET04                Not NETDATA                      NET00190
*
         LA    R15,6                   Len of "INMR01"                  NET00360
         AR    R1,R15                  Skip over that field             NET00370
         LA    R9,INMF01               -> area to hold INMR01 fields
         USING INMFIELD,R9
         BAL   R14,CTL000              Go parse control record
         OI    FLAGS1,F1INMR01         Indicate fields processed
*
*-- Find INMR02 record                                                  NET00060
*                                                                       NET00200
FINMR02  EQU   *
         LA    R0,2                    # of bytes to get                NET00210
         BAL   R14,GETBYTES            Get length and desc of segment   NET00220
         MVC   CTL,1(R1)               Save copy of descriptor byte
*                                                                       NET00090
         LA    R0,CODE1                Control record not indicated
         TM    CTL,X'20'               Is this a control record?        NET00100
         BZ    XITNET08                No, invalid NETDATA              NET00110
*                                                                       NET00260
         SR    R0,R0                                                    NET00270
         IC    R0,0(,R1)               Get segment length byte          NET00280
         S     R0,=F'2'                Less 2 we already retrieved      NET00290
         LR    R3,R0                   Copy length of control record    NET00300
         BAL   R14,GETBYTES            Get control record               NET00310
*                                                                       NET00320
         LA    R0,CODE2                INMR02 record not detected
         CLC   0(6,R1),INMR02          NETDATA?                         NET00330
         BNE   XITNET08                invalid NETDATA                  NET00190
*                                                                       NET00350
         LA    R15,10                  Len of "INMR02"+file number word NET00360
         AR    R1,R15                  Skip over those fields           NET00370
         LA    R9,INMF02A              -> area to hold INMR02 fields
         BAL   R14,CTL000              Go parse control record
         TM    FLAGS2,F2TERM           Was a TERM text unit key found?
         BO    XITNET20                Y, unsupported
         OI    FLAGS1,F1INMR2A         Indicate fields processed
*
*-- Find INMR02 or INMR03 record                                        NET00060
*                                                                       NET00200
         LA    R0,2                    # of bytes to get                NET00210
         BAL   R14,GETBYTES            Get length and desc of segment   NET00220
         MVC   CTL,1(R1)               Save copy of descriptor byte
*                                                                       NET00090
         LA    R0,CODE3                Control record not indicated
         TM    CTL,X'20'               Is this a control record?        NET00100
         BZ    XITNET08                No, invalid NETDATA              NET00110
*                                                                       NET00260
         SR    R0,R0                                                    NET00270
         IC    R0,0(,R1)               Get segment length byte          NET00280
         S     R0,=F'2'                Less 2 we already retrieved      NET00290
         LR    R3,R0                   Copy length of control record    NET00300
         BAL   R14,GETBYTES            Get control record               NET00310
*                                                                       NET00320
         CLC   0(6,R1),INMR03          Is it INMR03?                    NET00330
         BE    IR03                    Yes, go there                    NET00190
         LA    R0,CODE4                INMR02 record not detected
         CLC   0(6,R1),INMR02          Is it INMR02?                    NET00330
         BNE   XITNET08                Something wrong; inval NETDATA   NET00190
*                                                                       NET00350
         LA    R15,10                  Len of "INMR02"+file number word NET00360
         AR    R1,R15                  Skip over those fields           NET00370
         LA    R9,INMF02B              -> area to hold INMR02 fields
         BAL   R14,CTL000              Go parse control record
         TM    FLAGS2,F2TERM           Was a TERM text unit key found?
         BO    XITNET20                Y, unsupported
         OI    FLAGS1,F1INMR2B         Indicate fields processed
*
*-- Find INMR03 record                                                  NET00060
*                                                                       NET00200
FINMR03  EQU   *
         LA    R0,2                    # of bytes to get                NET00210
         BAL   R14,GETBYTES            Get length and desc of segment   NET00220
         MVC   CTL,1(R1)               Save copy of descriptor byte
*                                                                       NET00090
         LA    R0,CODE5                INMR03 ctl rec not indicated
         TM    CTL,X'20'               Is this a control record?        NET00100
         BZ    XITNET08                No, invalid NETDATA              NET00110
*                                                                       NET00260
         SR    R0,R0                                                    NET00270
         IC    R0,0(,R1)               Get segment length byte          NET00280
         S     R0,=F'2'                Less 2 we already retrieved      NET00290
         LR    R3,R0                   Copy length of control record    NET00300
         BAL   R14,GETBYTES            Get control record               NET00310
*                                                                       NET00320
         LA    R0,CODE6                INMR03 record not detected
         CLC   0(6,R1),INMR03          Is it INMR03?                    NET00330
         BNE   XITNET08                Something wrong; invalid NETDATA NET00190
*                                                                       NET00350
IR03     EQU   *
         LA    R15,6                   Len of "INMR03"                  NET00360
         AR    R1,R15                  Skip over those fields           NET00370
         LA    R9,INMF03               -> area to hold INMR02 fields
         BAL   R14,CTL000              Go parse control record
         OI    FLAGS1,F1INMR03         Indicate fields processed
         B     XITNET00                Done
*                                                                       NET00380
*-- Parse the text unit keys from a control record                      NET00380
*                                                                       NET00380
*-- Entry:  R3 = length of entire control record                        NET00380
*--         R15= length of INMRxx header fields to skip over
*-- Exit:   Keys identified are parsed an in their respective fields    NET00380
*                                                                       NET00380
CTL000   EQU   *                                                        NET00390
         ST    R14,SV14CTL             Save return addr
*
CTL010   EQU   *                                                        NET00390
         LA    R4,CTL010               Where to return with new segmnt
         SR    R3,R15                  Reduce remaining length          NET00400
         BNP   CTL070                  Done with control record segmnt  NET00410
         LA    R7,INMKEYS              -> text unit keys table
*                                                                       NET00420
*-- Look for supported keys                                             NET00430
*                                                                       NET00440
CTL020   EQU   *                                                        NET00390
         LA    R0,CODE7                Inv/unrecognized NETDATA key
         CLI   0(R7),X'FF'             End of table?
         BE    XITNET08                Invalid NETDATA key
*
         CLC   0(2,R1),0(R7)           Look for matching key            NET00450
         BE    CTL030                  Got one                          NET00460
         LA    R7,KEYLEN(,R7)          Bump to next in table
         B     CTL020                  Keep searching
*
CTL030   EQU   *                                                        NET00390
         ICM   R15,15,2(R7)            -> supporting rtn for key
         BNZR  R15                     Go there if rtn available
*                                                                       NET00610
*-- Skip over and ignore unsupported/unrecognized keys                  NET00620
*                                                                       NET00630
CTL050   EQU   *
         LA    R1,2(,R1)               Skip over unrecognized key       NET00640
         LA    R15,2                   Remaining length adjust          NET00650
         SR    R0,R0                   Clear for IC                     NET00660
         ICM   R0,3,0(R1)              Get # value                      NET00670
         LA    R1,2(,R1)               Skip over # value                NET00680
         LA    R15,2(,R15)             Remaining length adjust          NET00690
         BZ    CTL010                  # was 0; no lengths              NET00700
*
         LA    R4,CTL060               Where to return with new segmnt
         SR    R3,R15                  Reduce remaining length          NET00400
         BNP   CTL070                  Done with control record segmnt  NET00410
*                                                                       NET00720
CTL060   EQU   *                                                        NET00730
         SR    R14,R14                 Clear for ICM                    NET00710
         ICM   R14,3,0(R1)             Get length field                 NET00740
         LA    R1,2(R14,R1)            Skip over length and data        NET00750
         LA    R15,2(R14,R15)          Remaining length adjust          NET00760
         BCT   R0,CTL060               Do next len/data field pair      NET00770
         B     CTL010                  Resume                           NET00780
*                                                                       NET00720
*-- Here at end of segment or entire control record.                    NET00720
*-- We could also be here in the middle of a key (like INMMEMBR) and    NET00720
*-- we need to return to the right place after getting the next
*-- segment to continue on.
*                                                                       NET00720
CTL070   EQU   *                                                        NET00730
         TM    CTL,X'40'               Was that the final segment?
         BO    CTL090                  Yes, done with control record
*
*-- We need another control record segment
*
         ST    R0,SVR0CTL              Save # value for keys in progres
         LA    R0,2                    # of bytes to get                NET00070
         BAL   R14,GETBYTES            Get length and desc of segment   NET00080
         MVC   CTL,1(R1)               Save copy of descriptor byte
*                                                                       NET00090
         LA    R0,CODE8                Ctl rec segment not detected
         TM    CTL,X'20'               Is this a control record?        NET00100
         BZ    XITNET08                Bad...something wrong            NET00110
*                                                                       NET00120
         SR    R0,R0                                                    NET00130
         IC    R0,0(,R1)               Get segment length byte          NET00140
         S     R0,=F'2'                Less 2 we already retrieved      NET00150
         LR    R3,R0                   Copy length of ctl segment       NET00300
         BAL   R14,GETBYTES            Get control record segment       NET00160
         L     R0,SVR0CTL              Restore # value of the key
         SR    R15,R15                 Clear length adjustment
         BR    R4                      Return to CTL010 or CTL060
*                                                                       NET00720
CTL090   EQU   *                                                        NET00730
         L     R14,SV14CTL             Load return addr
         BR    R14                     Done with control record
*                                                                       NET00790
*-- Handle keys we dont support.                                        NET00800
*-- We look for INMTERM in order to bail out if present.
*-- This is generated by modern TRANSMIT with MSG.
*
TRM000   EQU   *
         OI    FLAGS2,F2TERM           Indicate INMTERM discovered
         B     CTL050                  Ignore the text unit key
*
*-- Handle keys we support, as well as those that we will capture       NET00800
*-- a value for but not do anything with it (example: creation date).
*                                                                       NET00810
*- Utility name                                                         NET00820
UTL000   EQU   *                       Get utility name                 NET00830
         MVC   UTLNAME+2,BLANKS         Init receiving field            NET00840
         LA    R6,UTLNAME              -> receiving field               NET00850
         BAL   R14,KEY000              Go handle the key                NET00860
         B     CTL010                  Scan for next key
*                                                                       NET00870
*- File size                                                            NET00880
FSZ000   EQU   *                       File size                        NET00890
         LA    R6,FILESIZE             -> receiving field               NET00900
         BAL   R14,KEY000              Go handle the key                NET00910
         BAL   R14,ADJ000              Right justify the value          NET00910
         B     CTL010                  Scan for next key
*                                                                       NET00920
*- DSORG                                                                NET00930
DSG000   EQU   *                       DSORG                            NET00940
         LA    R6,DSORG                -> receiving field               NET00950
         BAL   R14,KEY000              Go handle the key                NET00960
         B     CTL010                  Scan for next key
*- BLKSIZE                                                              NET00970
BLK000   EQU   *                       BLKSIZE                          NET00980
         LA    R6,BLKSIZE              -> receiving field               NET00990
         BAL   R14,KEY000              Go handle the key                NET01000
         BAL   R14,ADJ000              Right justify the value          NET00910
         B     CTL010                  Scan for next key
*                                                                       NET01010
*- LRECL                                                                NET01020
LRL000   EQU   *                       LRECL                            NET01030
         LA    R6,LRECL                -> receiving field               NET01040
         BAL   R14,KEY000              Go handle the key                NET01050
         BAL   R14,ADJ000              Right justify the value          NET00910
         B     CTL010                  Scan for next key
*                                                                       NET01060
*- RECFM                                                                NET01070
RFM000   EQU   *                       RECFM                            NET01080
         LA    R6,RECFM                -> receiving field               NET01090
         BAL   R14,KEY000              Go handle the key                NET01100
         B     CTL010                  Scan for next key
*                                                                       NET00870
*- # directory blocks                                                   NET00880
DIR000   EQU   *                       File size                        NET00890
         LA    R6,DIRBLKS              -> receiving field               NET00900
         BAL   R14,KEY000              Go handle the key                NET00910
         BAL   R14,ADJ000              Right justify the value          NET00910
         B     CTL010                  Scan for next key
*                                                                       NET01110
*- FFM                                                                  NET01120
FFM000   EQU   *                       File mode number                 NET01130
         LA    R6,FFM                  -> receiving field               NET01140
         BAL   R14,KEY000              Go handle the key                NET01150
         B     CTL010                  Scan for next key
*
*- Origin timestamp                                                     NET00820
FTM000   EQU   *                                                        NET00830
         MVC   FTIME+2,BLANKS          Init receiving field             NET00840
         LA    R6,FTIME                -> receiving field               NET00850
         BAL   R14,KEY000              Go handle the key                NET00860
         B     CTL010                  Scan for next key
*
*- Origin node                                                          NET00820
FND000   EQU   *                       Get origin node                  NET00830
         MVC   FNODE+2,BLANKS          Init receiving field             NET00840
         LA    R6,FNODE                -> receiving field               NET00850
         BAL   R14,KEY000              Go handle the key                NET00860
         B     CTL010                  Scan for next key
*
*- Origin userid                                                        NET00820
FUS000   EQU   *                       Get origin userid                NET00830
         MVC   FUSER+2,BLANKS          Init receiving field             NET00840
         LA    R6,FUSER                -> receiving field               NET00850
         BAL   R14,KEY000              Go handle the key                NET00860
         B     CTL010                  Scan for next key
*
*- To node                                                              NET00820
TND000   EQU   *                       Get destination node             NET00830
         MVC   TNODE+2,BLANKS          Init receiving field             NET00840
         LA    R6,TNODE                -> receiving field               NET00850
         BAL   R14,KEY000              Go handle the key                NET00860
         B     CTL010                  Scan for next key
*
*- To userid                                                            NET00820
TUS000   EQU   *                       Get destination userid           NET00830
         MVC   TUSER+2,BLANKS          Init receiving field             NET00840
         LA    R6,TUSER                -> receiving field               NET00850
         BAL   R14,KEY000              Go handle the key                NET00860
         B     CTL010                  Scan for next key
*
*- Version                                                              NET00820
VER000   EQU   *                       Get Version info                 NET00830
         MVC   FVERS+2,BLANKS          Init receiving field             NET00840
         LA    R6,FVERS                -> receiving field               NET00850
         BAL   R14,KEY000              Go handle the key                NET00860
         BAL   R14,ADJ000              Right justify the value          NET00910
         B     CTL010                  Scan for next key
*
*- Creation date                                                        NET00820
CRE000   EQU   *                                                        NET00830
         MVC   CREATE+2,BLANKS         Init receiving field             NET00840
         LA    R6,CREATE               -> receiving field               NET00850
         BAL   R14,KEY000              Go handle the key                NET00860
         B     CTL010                  Scan for next key
*
*- DDNAME                                                               NET00820
DDN000   EQU   *                                                        NET00830
         MVC   DDNAME+2,BLANKS         Init receiving field             NET00840
         LA    R6,DDNAME               -> receiving field               NET00850
         BAL   R14,KEY000              Go handle the key                NET00860
         B     CTL010                  Scan for next key
*
*- Extended attribute                                                   NET00820
ATR000   EQU   *                                                        NET00830
         LA    R6,EATTR                -> receiving field               NET00850
         BAL   R14,KEY000              Go handle the key                NET00860
         B     CTL010                  Scan for next key
*
*- RECEIVE error code                                                   NET00820
ECD000   EQU   *                                                        NET00830
         LA    R6,ERRCD                -> receiving field               NET00850
         BAL   R14,KEY000              Go handle the key                NET00860
         B     CTL010                  Scan for next key
*
*- Expiration date                                                      NET00820
EXP000   EQU   *                                                        NET00830
         MVC   EXPDT+2,BLANKS          Init receiving field             NET00840
         LA    R6,EXPDT                -> receiving field               NET00850
         BAL   R14,KEY000              Go handle the key                NET00860
         B     CTL010                  Scan for next key
*
*- Last changed date                                                    NET00820
LCH000   EQU   *                                                        NET00830
         MVC   LCHG+2,BLANKS           Init receiving field             NET00840
         LA    R6,LCHG                 -> receiving field               NET00850
         BAL   R14,KEY000              Go handle the key                NET00860
         B     CTL010                  Scan for next key
*
*- Last referenced date                                                 NET00820
LRF000   EQU   *                                                        NET00830
         MVC   LREF+2,BLANKS           Init receiving field             NET00840
         LA    R6,LREF                 -> receiving field               NET00850
         BAL   R14,KEY000              Go handle the key                NET00860
         B     CTL010                  Scan for next key
*                                                                       NET00870
*- Size in megabytes                                                    NET00880
LSZ000   EQU   *                       File size in MB                  NET00890
         LA    R6,LSIZE                -> receiving field               NET00900
         BAL   R14,KEY000              Go handle the key                NET00910
         B     CTL010                  Scan for next key
*                                                                       NET00870
*- Number of files                                                      NET00880
NMF000   EQU   *                       File size in MB                  NET00890
         LA    R6,NUMF                 -> receiving field               NET00900
         BAL   R14,KEY000              Go handle the key                NET00910
         BAL   R14,ADJ000              Right justify the value          NET00910
         B     CTL010                  Scan for next key
*                                                                       NET00870
*- Record count                                                         NET00880
RCT000   EQU   *                                                        NET00890
         LA    R6,RECCT                -> receiving field               NET00900
         BAL   R14,KEY000              Go handle the key                NET00910
         BAL   R14,ADJ000              Right justify the value          NET00910
         B     CTL010                  Scan for next key
*                                                                       NET00870
*- Secondary space                                                      NET00880
SEC000   EQU   *                                                        NET00890
         LA    R6,SECND                -> receiving field               NET00900
         BAL   R14,KEY000              Go handle the key                NET00910
         B     CTL010                  Scan for next key
*
*- Destination timestamp                                                NET00820
TTM000   EQU   *                                                        NET00830
         MVC   TTIME+2,BLANKS          Init receiving field             NET00840
         LA    R6,TTIME                -> receiving field               NET00850
         BAL   R14,KEY000              Go handle the key                NET00860
         B     CTL010                  Scan for next key
*                                                                       NET00870
*- Dataset Type                                                         NET00880
TYP000   EQU   *                       Data set type                    NET00890
         LA    R6,DSTYPE               -> receiving field               NET00900
         BAL   R14,KEY000              Go handle the key                NET00910
         B     CTL010                  Scan for next key
*                                                                       NET01160
*                                                                       NET01160
*- DSNAME                                                               NET01170
DSN000   EQU   *                       DSNAME                           NET01180
         MVC   DSNAME+2,BLANKS         Init receiving field             NET01190
         LA    R6,DSNAME+2             -> receiving field               NET01200
         LA    R1,2(,R1)               Skip over key                    NET01210
         LA    R15,2                   Remaining length adjust          NET01220
         SR    R0,R0                   Clear for IC                     NET01230
         ICM   R0,3,0(R1)              Get # value                      NET01240
         LA    R1,2(,R1)               Skip over # value                NET01250
         LA    R15,2(,R15)             Remaining length adjust          NET01260
         BZ    CTL010                  # was 0; no lengths              NET01270
         SR    R14,R14                 Clear for ICM                    NET01280
*                                                                       NET01290
DSN020   EQU   *                                                        NET01300
         ICM   R14,3,0(R1)             Get length field                 NET01310
         BCT   R14,DSN030              Adjust for execute               NET01320
         MVC   0(0,R6),2(R1)           executed instr                   NET01330
DSN030   EX    R14,*-6                 Move name to receiving field     NET01340
         LA    R1,3(R14,R1)            Skip over length and data        NET01350
         LA    R15,3(R14,R15)          Remaining length adjust          NET01360
         LA    R6,1(R14,R6)            Bump to next qualifier area      NET01370
         MVI   0(R6),C'.'              Add qualifier dot
         LA    R6,1(,R6)               -> next qualifier area
         BCT   R0,DSN020               Do next len/data field pair      NET01380
         BCTR  R6,0                    -> last byte of DSNAME           NET01390
         MVI   0(R6),C' '              Remove trailing dot
         BCTR  R6,0                    -> prior to trailing '.'         NET01390
         LA    R0,DSNAME+2             -> start of DSNAME               NET01400
         SR    R6,R0                   Compute final DSN length         NET01410
         STCM  R6,3,DSNAME             Save it                          NET01420
         B     CTL010                  get next key                     NET01430
*                                                                       NET01440
*-- Common routine to break part key/#/len/data elements that have #=1  NET01450
*                                                                       NET01460
KEY000   EQU   *                                                        NET01470
         LA    R1,4(,R1)               Skip over key, #                 NET01480
         LA    R15,4                   Remaining length accum           NET01490
         SR    R5,R5                   Clear for IC                     NET01500
         ICM   R5,3,0(R1)              Get length of name               NET01510
         STCM  R5,3,0(R6)              Store actual len in result fld
         BZR   R14                     If no length, done with key
         BCT   R5,KEY010               Adjust for execute               NET01520
         MVC   2(0,R6),2(R1)           executed instr                   NET01530
KEY010   EX    R5,*-6                  Move name to receiving field     NET01540
         LA    R1,3(R5,R1)             -> next text unit key            NET01550
         LA    R15,3(R5,R15)           Accum length adjustment          NET01560
         BR    R14                     Return                           NET01570
*
*-- Common routine right justify numeric fields of numeric text units   NET01450
*                                                                       NET01460
ADJ000   EQU   *
         LA    R8,8                    Max length of value
         LH    R0,0(,R6)               Get length from NETDATA key
         SR    R8,R0                   Compute # bytes of shift
         BZR   R14                     No justification required
         SLA   R8,3                    Turn # bytes into # bits
         LM    R4,R5,2(R6)             Get numeric field
         SRDL  R4,0(R8)                Right justify the number
         STM   R4,R5,2(R6)             Put back justified numeric value
         BR    R14
*
         DROP  R9                      INMFIELD
*
*
*-- Process data records
*
*-- NOTE!  We are using PUT LOCATE mode here, which offers the
*--        flexibility to accomodate RECFM=VS and VBS records when
*--        combined with DCB=BFTEK=A.  This can be confusing looking
*--        as it seems the PUT is issued and then the record is built.
*--        However, the PUT is actually writing the previous record
*--        and the last record is written by CLOSE, all per the IBM
*--        data management specification.
*
*-- NOTE!  RECFM=U processing requires the length of the record
*--        be stored in DCBLRECL prior to the PUT LOCATE being issued.
*--        But we don't know the length of the record yet, because it
*--        is coming in from the NETDATA in segments.  So, we have to
*--        unfortunately use a separate buffer to accumulate the
*--        segments and when complete obtain the total length to
*--        store into DCBLRECL.  Then we can issue the PUT.  Then
*--        we have to move the data from our segment accumulation
*--        buffer into the PUT LOCATE buffer. Note though, that
*--        if we used PUT MOVE for RECFM=U, the system would
*--        move our data out of the segment buffer; so either way
*--        the data is moved an extra time.
*
PDATA000 EQU   *
         LA    R0,2                    # of bytes to get                NET00210
         BAL   R14,GETBYTES            Get length and desc of segment   NET00220
*                                                                       NET00230
         TM    1(R1),X'20'             Is this a control record?        NET00240
         BO    PDATA100                Yes                              NET00110
*
         MVC   CTL,1(R1)               Save copy of descriptor byte
         SR    R0,R0                                                    NET00130
         IC    R0,0(,R1)               Get segment length byte          NET00140
         S     R0,=F'2'                Less 2 we already retrieved      NET00150
         LR    R3,R0                   Copy length of segment           NET00300
         BAL   R14,GETBYTES            Get a segment                    NET00160
         LR    R4,R1                   Copy segment ptr
*
*-- Determine type of record segment
*
         TM    CTL,X'C0'           C0  Complete record?
         BO    CMP000                  Yes
         TM    CTL,X'80'           80  1st record of segment?
         BO    FST000                  Yes
         TM    CTL,X'40'           40  last record of segment?
         BO    LST000                  Yes
*
*-- Middle segment
*
MID000   EQU   *                   00  Handle middle segment
         L     R1,RBPOS                -> next available buffer byte
         LR    R0,R1                   Copy next available ptr     v222
         S     R0,RBUFF                Compute len used so far     v222
         AR    R0,R3                   Add len of next segment     v222
         CH    R0,NEWDS+(DCBLRECL-IHADCB) will segment fit in buff?v222
         BH    XITNET24                No. record too large        v222
         BCTR  R3,0                    Adjust for execute
         EX    R3,MVCSEG               Move segement data
         LA    R1,1(R3,R1)             -> next available byte
         ST    R1,RBPOS                Save record position
         B     PDATA000                Go get some more
*
*-- Complete segment (an entire record)
*
CMP000   EQU   *
         TM    TRECFM,X'C0'            Using undefined format?
         BO    CMPU100                 Yes
*
         PUT   NEWDS                   Write R1 buffer and get new one
*
         TM    TRECFM,X'40'            Using variable format?
         BO    CMP010                  Yes
         BCTR  R3,0                    Adjust for execute
         EX    R3,MVCSEG               Move segment data
         B     PDATA000                Go get some more
*
CMP010   EQU   *
         LA    R0,4(,R3)               Copy record length + 4
         SLL   R0,16                   Make RDW = LLZZ
         STCM  R0,15,0(R1)             Plug in RDW
         LA    R1,4(,R1)               Skip over RDW
         BCTR  R3,0                    Adjust for execute
         EX    R3,MVCSEG               Move segment data
         B     PDATA000                Go get some more
*
CMPU100  EQU   *                    ** Here if RECFM=U only
         STH   R3,NEWDS+(DCBLRECL-IHADCB) Set len of output recrd
         PUT   NEWDS                   Write R1 buffer and get new one
         BCTR  R3,0                    Adjust for execute
         EX    R3,MVCSEG               Move segment data
         B     PDATA000                Go get some more
*
MVCSEG   MVC   0(0,R1),0(R4)           executed instr
*
*-- First segment of a record
*
FST000   EQU   *                       Handle first segment
         TM    TRECFM,X'C0'            Using undefined format?
         BO    FSTU100                 Yes
*
         PUT   NEWDS                   Write R1 buffer and get new one
         ST    R1,RBUFF                Save start addr of buffer
*
         TM    TRECFM,X'40'            Variable records?
         BZ    FST010                  No
         LA    R1,4(,R1)               Leave space for RDW
*
FST010   EQU   *
         BCTR  R3,0                    Adjust for execute
         EX    R3,MVCSEG               Move segment data
         LA    R1,1(R3,R1)             -> next available byte
         ST    R1,RBPOS                Save record position
         B     PDATA000                Go get some more
*
FSTU100  EQU   *                    ** Here if RECFM=U only
         L     R1,NEWBLK               -> RECFM=U build buffer
         BCTR  R3,0                    Adjust for execute
         EX    R3,MVCSEG               Move segment data
         LA    R1,1(R3,R1)             -> next available byte
         ST    R1,RBPOS                Save record position
         B     PDATA000                Go get some more
*
*-- Last segment of a record
*
LST000   EQU   *                       Handle last segment
         L     R1,RBPOS                -> next available buffer byte
         LR    R0,R1                   Copy next available ptr     v222
         S     R0,RBUFF                Compute len used so far     v222
         AR    R0,R3                   Add len of next segment     v222
         CH    R0,NEWDS+(DCBLRECL-IHADCB) will segment fit in buff?v222
         BH    XITNET24                No. record too large        v222
         BCTR  R3,0                    Adjust for execute
         EX    R3,MVCSEG               Move segment data
         LA    R1,1(R3,R1)             -> next available byte
*
         TM    TRECFM,X'C0'            Using undefined format?
         BO    LSTU100                 Yes
*
         L     R3,RBUFF                -> record start
         TM    TRECFM,X'40'            Variable records?
         BZ    LST010                  No
*
         SR    R1,R3                   Compute record length
         LA    R0,CODE9                Assume bad segment length   v200
         CH    R1,NEWDS+(DCBLRECL-IHADCB) Chk RDW against LRECL    v200
         BH    XITNET08                It was                      v200
*
         SLL   R1,16                   Make RDW = LLZZ
         STCM  R1,15,0(R3)             Plug in RDW
         SRL   R1,16                   Make length
*
LST010   EQU   *
         B     PDATA000                Go get some more
*
LSTU100  EQU   *                    ** Here if RECFM=U only
         L     R2,NEWBLK               -> RECFM=U record build area
         SR    R1,R2                   Compute record length
         STH   R1,NEWDS+(DCBLRECL-IHADCB) Set len of output recrd
         LR    R3,R1                   Copy length to write
*
         PUT   NEWDS                   Write prv buffer and get new one
         LR    R0,R1                   -> PUT buffer to R0
         LR    R1,R3                   Length of record
         MVCL  R0,R2                   Move to PUT LOCATE buffer
         B     PDATA000                Go get some more
*
*-- Control record encountered in data stream
*
PDATA100 EQU   *
         SR    R0,R0                                                    NET00130
         IC    R0,0(,R1)               Get segment length byte          NET00140
         S     R0,=F'2'                Less 2 we already retrieved      NET00150
         LR    R3,R0                   Copy length of segment           NET00300
         BAL   R14,GETBYTES            Get a segment                    NET00160
*
         CLC   0(6,R1),INMR06          Is it INMR06?                    NET00330
         BNE   PDATA000                Ignore other control records
         B     XITNET00                Done
*
*-- Process FLAT FILE not in NETDATA format
*
*-- We've already read the first spool record, in REC.
*-- PUN files:  just write 80 byte records.
*-- PRT files:  write 133 bytes, always convert to ASA carriage ctl;
*--             the raw data over NJE is always M carriage ctl for PRT.
*
*-- Writing out to DCB NEWDS using MACRF=PL
*
*
*
PFLAT000 EQU   *
         LA    R6,TAGDATA
         USING TAG,R6
         LA    R4,X'40'                Assume CC of space 1
         B     PFLAT030                1st record is already in REC
*
*
*-- Retrieve the spool file records
*
PFLAT010 EQU   *
         BAL   R14,GET000              Get a record
         C     R15,=F'4'               EOF?
         BE    XITNET00                Yes, were done
         LTR   R15,R15                 Any errors?
         BNZ   XITNET16                Yes, deal with them
*
PFLAT030 EQU   *
         TM    TAGINDEV,TYPPUN         Is this punch data?
         BO    PFLAT180                Yes
*
*-- Output PRT records with RECFM=A carriage control
*
         TM    REC,X'03'               Immediate cmd CC in record?
         BNO   PFLAT070                No, this one is the data
*
         LA    R4,C'0'                 Space 2 lines
         CLI   REC,X'13'               Is CC character space 2 immed?
         BE    PFLAT010                Yes
         LA    R4,C'1'                 Skip to channel 1
         CLI   REC,X'8B'               Is CC character ch 1 immed?
         BE    PFLAT010                Yes
         LA    R4,C'-'                 Space 3 lines
         CLI   REC,X'1B'               Is CC character space 3 immed?
         BE    PFLAT010                Yes
         LA    R4,C'+'                 Suppress space
         CLI   REC,X'01'               Is CC character write sup imd?
         BE    PFLAT010                Yes
         LA    R4,X'40'                Otherwise use space 1
         B     PFLAT010
*
PFLAT070 EQU   *
         PUT   NEWDS                   Write a line
         LR    R5,R1                   Get new buffer addr
*
         STC   R4,0(,R5)               Set the CC byte
         LH    R1,NCB1+(NCBRECLN-NCB)  Get length of spool record
         BCTR  R1,0                    Less one to skip CC byte
         ICM   R1,8,BLANKS             Set pad char
         LA    R0,REC+1                -> spool input record skipping
*                                       the M carriage control
         LA    R14,1(,R5)              Where to build output record
         LH    R15,NEWDS+(DCBLRECL-IHADCB) get len of output recrd area
         BCTR  R15,0                   Less one to skip CC byte
         MVCL  R14,R0                  Move record and pad excess
         B     PFLAT010                Process another line
*
*-- PUN records
*
PFLAT180 EQU   *
         PUT   NEWDS                   Write a line
         LR    R5,R1                   Get new buffer addr
*
         LH    R1,NCB1+(NCBRECLN-NCB)  Get length of spool record
         ICM   R1,8,BLANKS             Set pad char
         LA    R0,REC                  -> spool input record
         LR    R14,R5                  Where to build output record
         LH    R15,NEWDS+(DCBLRECL-IHADCB) get len of output recrd area
         MVCL  R14,R0                  Move record and pad excess
         B     PFLAT010                Process another line
*
*
*                                                                       NET01580
*                                                                       NET01580
*                                                                       NET01580
*-- Request some more bytes of NETDATA formatted data                   NET01590
*                                                                       NET01590
*-- Entry:  R0 = # of bytes requested  (1-255)                          NET01590
*-- Exit:   R1 -> string of bytes obtained                              NET01590
*                                                                       NET01660
*-- Uses R0-R1,R5-R8,R14-R15; the caller's values in these              NET01660
*--      registers are not preserved across this call.
*                                                                       NET01660
GETBYTES EQU   *                                                        NET01670
         ST    R14,SV14GB              Save return addr                 NET01680
         L     R5,GBREM                Get # bytes remaining in rec buf NET01690
         LA    R1,BUFF                 Point to getbytes buffer         NET01700
         ST    R1,GBPOS                Set starting position            NET01710
*
         L     R8,GBRBA                Get RBA of current position
         ST    R8,GBPBA                Save prior RBA
         AR    R8,R0                   Compute next RBA
         ST    R8,GBRBA                Update RBA if successful
*
         LR    R8,R0                   Requested amount to R8           NET01720
*                                                                       NET01730
*                                                                       NET01740
GB010    EQU   *                                                        NET01750
         LTR   R5,R5                   Any bytes left in phy record?    NET01760
         BP    GB040                   Yes, use them first              NET01770
*                                                                       NET01780
         BAL   R14,GET000              Get a NETDATA record
         LTR   R15,R15                 Any errors?
         BNZ   GB090                   Yes, deal with them
*                                      R0-> length of record read       NET01850
         LR    R5,R0                   Num bytes read                   NET01840
         ST    R1,GBRPS                Reset start of record position   NET01880
*                                                                       NET01890
GB040    EQU   *                                                        NET01900
         LR    R7,R8                   Assume requested amt avail       NET01910
         LR    R15,R8                  Same                             NET01920
*                                                                       NET01930
         CR    R5,R8                   Have more than we need?          NET01940
         BH    GB050                   Yes, just move requested         NET01950
         LR    R7,R5                   Else move what we have           NET01960
         LR    R15,R5                  Same                             NET01970
*                                                                       NET01980
GB050    EQU   *                                                        NET01990
         LR    R0,R7                   Save copy of length to move      NET02000
         L     R14,GBPOS               -> GB buffer position            NET02010
         L     R6,GBRPS                -> input record curr position    NET02020
         MVCL  R14,R6                  Move                             NET02030
*                                                                       NET02040
         ST    R14,GBPOS               New GB position                  NET02050
         ST    R6,GBRPS                New phys record curr position    NET02060
*                                                                       NET02070
         SR    R5,R0                   Reduce bytes left in phy record  NET02080
         SR    R8,R0                   Reduce requested amt             NET02090
         BP    GB010                   We need more, go get it          NET02100
*                                                                       NET02110
         ST    R5,GBREM                Remember whats left in phy rec   NET02120
*                                                                       NET02130
         LA    R1,BUFF                 Point to the requested bytes     NET02140
         L     R14,SV14GB              Load  return addr                NET02150
         BR    R14                     Return from getbytes             NET02160
*                                                                       NET01980
GB090    EQU   *                                                        NET01990
         C     R15,=F'4'               End of file?
         BE    XITNET12                Yes
         B     XITNET16                I/O error
*
*-- Exit NETDATA processing
*
XITNET00 EQU   *
         SR    R15,R15             RC=0; NETDATA info filled
         B     XITNET
*
XITNET04 EQU   *
         LA    R15,4               RC=4; File doesnt lead off w/NETDATA
         B     XITNET
*
*-- Here if unexpected or unrecognized NETDATA sequences are found
*
*-- There are 8 places that could branch here; they are numbered 1-8
*-- in R0 to indicate how we arrived here "detection code".  Used
*-- with the input NETDATA record and byte number this code can
*-- help to locate the offending error.
*
*-- The detection CODEx equates below describe the 8 tests
*
CODE1    EQU   1                       Control record not indicated
CODE2    EQU   2                       INMR02 record not detected
CODE3    EQU   3                       Control record not indicated
CODE4    EQU   4                       INMR02 record not detected
CODE5    EQU   5                       INMR03 ctl rec not indicated
CODE6    EQU   6                       INMR03 record not detected
CODE7    EQU   7                       Inv/unrecognized NETDATA key
CODE8    EQU   8                       Ctl rec segment not detected
CODE9    EQU   9                       Incorrect segment lengths   v200
*
*-- Format error msg (MSG003):
*
*Invalid or unsupported NETDATA detected; error code x, record y byte z
*
*-- Note for debugging:  the record and byte number displayed point
*-- to the position in the original input at the point of the GETBYTES
*-- call.  The error may be at that exact byte or following it for
*-- some reasonable amount (up to 255 bytes).  For error codes 1-6 and
*-- code 8, the rec/byte shown is very close and usually exact. For
*-- code 7 errors there is an invalid or unknown text unit key and
*-- the invalid key is somewhere after the rec/byte shown in the
*-- next 255 bytes.
*
*-- For code 9, the record segment lengths exceeded the LRECL      v200
*--  (variable length records only).                               v200
*
XITNET08 EQU   *
         LR    R6,R0               Detection code to R6
*
         L     R1,GBPBA            Get RBA of prior GETBYTES call
         SR    R0,R0               Clear for divide
         D     R0,=F'80'           Compute input record number
         LA    R2,1                Load 1
         AR    R1,R2               Make record number relative to 1
         AR    R0,R2               Make byte number relative to 1
         CVD   R1,DBLE             Convert
         MVC   LIST(4+L'MSG003T),MSG003  Build msg
         MVC   TWRK(12),=X'402020206B2020206B202120' Edit mask
         LA    R1,TWRK+11          Start of significance
         EDMK  TWRK(12),DBLE+3     Edit record count
         LA    R2,TWRK+11          -> last digit of edited number
         SR    R2,R1               Compute display length
         EX    R2,MVREC            Move edited number to line
         LA    R1,LIST+67(R2)      -> next available byte in line
         MVC   0(8,R1),=C' byte xx'
*
         CVD   R0,DBLE             Convert byte position
         UNPK  6(2,R1),DBLE        Fill in byte #
         OI    7(R1),X'F0'         Fix sign
*
         STC   R6,LIST+56          Store detection code
         OI    LIST+56,X'F0'       Add a sign to make display
*
         LA    R1,8(,R1)           Compute end of msg text
         LA    R2,LIST             -> start of msg
         SR    R1,R2               Compute msg length RDW
         STH   R1,LIST             Set RDW
*
         BAL   R14,PUTLINE         Notify user
         LA    R15,8               RC=8; Invalid NETDATA detected
         B     XITNET
*
*-- EOF on NETDATA
XITNET12 EQU   *
         LA    R15,12              RC=12 unexpected EOF
         B     XITNET
*
*-- Read error on NETDATA
XITNET16 EQU   *
         LA    R15,16              RC=16 Read i/o error
         B     XITNET
*
*-- INMTERM text unit key detected and it is unsupported
XITNET20 EQU   *
         LA    R15,20              RC=20 INMTERM detected
         B     XITNET
*
*-- Segmented record pieces are too large for LRECL and exceed     v222
*--  the PUT record buffer                                         v222
XITNET24 EQU   *                                                   v222
         LA    R15,24              RC=24 record too large          v222
         B     XITNET                                              v222
*
XITNET   EQU   *
         L     R13,4(,R13)         -> prev s.a.
         ST    R15,16(,R13)        Set RC
         LM    R14,R12,12(R13)     Reload callers regs
         BR    R14                 Return with RC
*
MVREC    MVC   LIST+66(0),0(R1)    executed instr
*
         LTORG
*                                                                       NET02190
*                                                                       NET02190
*- Control records that we look for and process (others ignored).       NET02190
INMR01   DC    C'INMR01'               Header Control record            NET02200
INMR02   DC    C'INMR02'               File Utility Control record      NET02210
INMR03   DC    C'INMR03'               Data Control record              NET02210
INMR06   DC    C'INMR06'               Trailer Control record           NET02210
*                                                                       NET02220
*- Keys                                                                 NET02230
INMKEYS  DS    0H
INMBLKSZ DC    X'0030',AL4(BLK000)     Block size
INMCREAT DC    X'1022',AL4(CRE000)     Creation date
INMDDNAM DC    X'0001',AL4(DDN000)     DDNAME for the file
INMDIR   DC    X'000C',AL4(DIR000)     Number of directory blocks
INMDSNAM DC    X'0002',AL4(DSN000)     Name of the file
INMDSORG DC    X'003C',AL4(DSG000)     File organization
INMEATTR DC    X'8028',AL4(ATR000)     Extended attribute status
INMERRCD DC    X'1027',AL4(ECD000)     RECEIVE command error code
INMEXPDT DC    X'0022',AL4(EXP000)     Expiration date
INMFACK  DC    X'1026',AL4(0)  NO SPT--Originator requested notificat'n
INMFFM   DC    X'102D',AL4(FFM000)     Filemode number
INMFNODE DC    X'1011',AL4(FND000)     Origin node name or node number
INMFTIME DC    X'1024',AL4(FTM000)     Origin timestamp
INMFUID  DC    X'1012',AL4(FUS000)     Origin user ID
INMFVERS DC    X'1023',AL4(VER000)     Origin version num of the data
INMLCHG  DC    X'1021',AL4(LCH000)     Date last changed
INMLRECL DC    X'0042',AL4(LRL000)     Logical record length
INMLREF  DC    X'1020',AL4(LRF000)     Date last referenced
INMLSIZE DC    X'8018',AL4(LSZ000)     Data set size in megabytes.
INMMEMBR DC    X'0003',AL4(0)  NO SPT--Member name list
INMNUMF  DC    X'102F',AL4(NMF000)     Number of files transmitted
INMRECCT DC    X'102A',AL4(RCT000)     Transmitted record count
INMRECFM DC    X'0049',AL4(RFM000)     Record format
INMSECND DC    X'000B',AL4(SEC000)     Secondary space quantity
INMSIZE  DC    X'102C',AL4(FSZ000)     File size in bytes
INMTERM  DC    X'0028',AL4(TRM000)     Data transmitted as a message
INMTNODE DC    X'1001',AL4(TND000)     Target node name or node number
INMTTIME DC    X'1025',AL4(TTM000)     Destination timestamp
INMTUID  DC    X'1002',AL4(TUS000)     Target user ID
INMTYPE  DC    X'8012',AL4(TYP000)     Data set type
INMUSERP DC    X'1029',AL4(0)  NO SPT--User parameter string
INMUTILN DC    X'1028',AL4(UTL000)     Name of utility program
         DC    X'FFFF'                 End of table
KEYLEN   EQU   6                       Length of key/adcon pair
*
*-- Target fields from INMRxx control records that we recognize:
*
*-- Missing from the list and unsupported:
*--  INMFACK  1-64 bytes, notification string from transmit
*--  INMTERM  0 bytes, data was transmitted as a message
*--  INMUSERP 1-251 bytes, user PARM field string from TRANSMIT/RECEIVE
*
INMFIELD DSECT
UTLNAME  DS    0XL8,XL2,CL8           Utility name                      NET02490
FILESIZE DS    0XL8,XL2,XL8           File size in bytes                NET02500
DIRBLKS  DS    0XL8,XL2,XL8           #directory blocks                 NET02500
BLKSIZE  DS    0XL8,XL2,XL8           BLKSIZE                           NET02510
LRECL    DS    0XL8,XL2,XL8           LRECL                             NET02520
RECFM    DS    0XL2,XL2,XL2           RECFM                             NET02530
DSORG    DS    0XL2,XL2,XL2           DSORG                             NET02540
FFM      DS    0XL1,XL2,CL1           File mode number                  NET02550
DSNAME   DS    0XL44,XL2,CL44         DSNAME                            NET02580
FTIME    DS    0XL20,XL2,CL20         Origin time stamp                 NET02580
FNODE    DS    0XL8,XL2,CL8           Origin node                       NET02580
FUSER    DS    0XL8,XL2,CL8           Origin userid                     NET02580
TNODE    DS    0XL8,XL2,CL8           Dest node                         NET02580
TUSER    DS    0XL8,XL2,CL8           Dest userid                       NET02580
TTIME    DS    0XL16,XL2,CL16         Destination time stamp            NET02580
FVERS    DS    0XL8,XL2,XL8           Version                           NET02580
DDNAME   DS    0XL8,XL2,CL8           DDNAME                            NET02580
CREATE   DS    0XL16,XL2,CL16         Creation date                     NET02580
EATTR    DS    0XL1,XL2,CL1           Extended attributes               NET02550
ERRCD    DS    0XL1,XL2,CL1           Receive error code                NET02550
EXPDT    DS    0XL16,XL2,CL16         Expiration date                   NET02580
LCHG     DS    0XL16,XL2,CL16         Last Changed date                 NET02580
LREF     DS    0XL16,XL2,CL16         Last Referenced date              NET02580
LSIZE    DS    0XL4,XL2,XL4           Size of file in MB                NET02580
MEMBR    DS    0XL8,XL2,CL8           Member name list (1 supported)    NET02580
NUMF     DS    0XL8,XL2,XL8           Number of files in transmission   NET02520
RECCT    DS    0XL8,XL2,XL8           Number of records transmitted     NET02520
SECND    DS    0XL3,XL2,XL3           secondary space qty               NET02520
DSTYPE   DS    0XL1,XL2,XL1           Data set type                     NET02520
         DS    0H                     Force to halfword size
INMFSZ   EQU   *-INMFIELD             Size of DSECT
*
*                                                                       NJE00250
*********************
*  N J E P A R      *               NJEPAR calls IKJPARS to parse
*                   *               the TSO command line parameters.
*  TSO Command Line *
*  Parse            *
*                   *
*********************
*
*  Entry:  R0=0  Parse the command line parameters
*
*          R0=4  Parse the prompt parameters (change dsname, etc)
*          R1 -> Prompt input buffer from PUTGET if R0 = 4.
*
*  Exit:   R15 = IKJPARS RC
*
NJEPAR   CSECT
         B     28(,R15)               BRANCH AROUND EYECATCHERS
         DC    AL1(23)                LENGTH OF EYECATCHERS
         DC    CL9'NJEPAR'
         DC    CL9'&SYSDATE'
         DC    CL5'&SYSTIME'
*
         STM   R14,R12,12(R13)         Save Regs                        NJE00050
         LR    R12,R15                 Base                             NJE00060
         USING NJEPAR,R12                                               NJE00070
         USING NJEWK,R10
         ST    R13,PARSA+4             SAVE prv S.A. ADDR               NJE00080
         LA    R2,PARSA                -> my save area
         ST    R2,8(,R13)              Plug it into prior SA
         LR    R13,R2
*
*
         LR    R7,R0                   Copy entry action code
         LR    R6,R1                   Copy any passed ptr
*
         L     R1,CPARMS               -> CPPL entry parms
         LM    R2,R5,0(R1)             Get TSO command entry parameters
*                                       R2 -> Command buffer
*                                       R3 -> UPT
*                                       R4 -> PSCB
*                                       R5 -> ECT
*
*-- Build the IKJPARS PPL
*
PARS000  EQU   *
         LA    R8,PPLSTG               -> PPL
         USING PPL,R8
         ST    R3,PPLUPT               Set UPT addr
         ST    R5,PPLECT               Set ECT addr
         LA    R3,PARSECB              -> parse ECB
         ST    R3,PPLECB               Set it
         LA    R3,ANSWER               -> IKJPARS "answer area"
         ST    R3,PPLANS               Set it
         ST    R10,PPLUWA              Set user work area addr
         C     R7,=F'4'                Process prompt parameters?
         BE    PARS010                 Yes
*
*                                   ** Process command line
         ST    R2,PPLCBUF              Set TSO command buffer addr
         L     R3,=A(PCLDEFS)          -> command parms definitions
         ST    R3,PPLPCL               Set it
         B     PARS020
*
PARS010  EQU   *                    ** Process prompt parameters
         ST    R6,PPLCBUF              Set PUTGET input buffer addr
         L     R3,=A(PRMTOPS)          -> prompt parms definitions
         ST    R3,PPLPCL               Set it
*
PARS020  EQU   *
         CALLTSSR EP=IKJPARS,MF=(E,PPLSTG)   Parse command line
         LTR   R0,R15                  Any parse errors?
         BNZ   XITPAR12                Yes
         DROP  R8                      PPL
*
         C     R7,=F'4'                Did we parse prompt parms?
         BE    PARS200                 Yes, examine those
*
*- Examine command line results
         L     R4,ANSWER               -> IKJPARS built PCEs
         USING PRDSECT,R4
*
         LA    R2,FILEPCE              -> File #### PCE data
         TM    6(R2),X'80'             Was file #### specified?
         BZ    PARS025                 No
*
         L     R3,0(,R2)               -> word containing file #
         MVC   FILEID,0(R3)            Save specified spool id #
         OI    FLAGS3,F3FILEID         Indicate file id valid
*
PARS025  EQU   *
         LA    R2,QTPCE                -> QUIET PCE
         CLC   0(2,R2),=AL2(1)         Was QUIET specified?
         BNE   PARS030                 No
         OI    FLAGS3,F3QUIET+F3NPRMPT Indicate QUIET+NOPROMPT
*
PARS030  EQU   *
         LA    R2,PURPCE               -> PURGE/NOPURGE PCE
         CLC   0(2,R2),=AL2(2)         Was NOPURGE specified?
         BNE   PARS035                 No
         NI    FLAGS3,255-F3PURGE      Indicate no purge
*
PARS035  EQU   *
         LA    R2,PRMTPCE              -> PROMPT/NOPROMPT PCE
         CLC   0(2,R2),=AL2(2)         Was NOPROMPT specified?
         BNE   PARS040                 No
         OI    FLAGS3,F3NPRMPT         Indicate no prompts
*
PARS040  EQU   *
         LA    R2,VOLPCE               -> VOLSER PCE
         TM    6(R2),X'80'             Was VOLSER specified?
         BZ    PARS050                 No
         L     R3,0(,R2)               -> VOLSER string
         LH    R1,4(,R2)               Length of volser
         MVC   USRVOL,BLANKS           Init receiving field
         BCTR  R1,0                    Adjust for execute
         EX    R1,MVVOL                Move the volser
         OI    FLAGS3,F3VOLSER         Indicate volser valid
*
PARS050  EQU   *
         LA    R2,INDAPCE              -> INDATASET PCE
         TM    6(R2),X'80'             Was INDATASET specified?
         BZ    PARS080                 No
         MVC   USRINDS,BLANKS          Init receiving field
         LA    R5,USRINDS              -> where to place DSN
*
         TM    6(R2),X'40'             Was dataset name in quotes?
         BO    PARS060                 Y, don't insert prefix
         CLC   PREFIX,BLANKS           Is a prefix available?
         BE    PARS060                 All blank, dont use prefix
*
         MVC   USRINDS(8),PREFIX       Add the prefix
         TRT   USRINDS,BLANK           Look for end of prefix
         MVI   0(R1),C'.'              Set delim after prefix
         LA    R5,1(,R1)               -> place to put rest of dsn
         LA    R2,INDAPCE              -> INDATASET PCE
*
PARS060  EQU   *
         L     R3,0(,R2)               -> INDATASET string
         LH    R1,4(,R2)               Length of DSN
         BCTR  R1,0                    Adjust for execute
         EX    R1,MVINDS               Move the DSN
         OI    FLAGS3,F3INDS           Indicate INDATASET valid
*
PARS070  EQU   *
         TM    14(R2),X'80'            Was INDATASET member specified?
         BZ    PARS080                 No
         L     R3,8(,R2)               -> INDATASET member name
         LH    R1,12(,R2)              Length of member name
         MVC   USRMEM,BLANKS           Init receiving field
         BCTR  R1,0                    Adjust for execute
         EX    R1,MVINMEM              Move the member name
         OI    FLAGS3,F3INMEM          Indicate INDATASET member valid
*
PARS080  EQU   *
         LA    R2,FDAPCE                -> DATASET PCE
         TM    6(R2),X'80'             Was DATASET specified?
         BZ    PARS110                 No
         MVC   FINALDS,BLANKS          Init receiving field
         LA    R5,FINALDS              -> where to place DSN
*
         TM    6(R2),X'40'             Was dataset name in quotes?
         BO    PARS090                 Y, don't insert prefix
         CLC   PREFIX,BLANKS           Is a prefix available?
         BE    PARS090                 All blank, dont use prefix
*
         MVC   FINALDS(8),PREFIX       Add the prefix
         TRT   FINALDS,BLANK           Look for end of prefix
         MVI   0(R1),C'.'              Set delim after prefix
         LA    R5,1(,R1)               -> place to put rest of dsn
         LA    R2,FDAPCE               -> DATASET PCE
*
PARS090  EQU   *
         L     R3,0(,R2)               -> DATASET string
         LH    R1,4(,R2)               Length of DSN
         BCTR  R1,0                    Adjust for execute
         EX    R1,MVINDS               Move the DSN
         OI    FLAGS3,F3DS             Indicate DATASET valid
*
PARS100  EQU   *
         TM    14(R2),X'80'            Was DATASET member specified?
         BZ    PARS110                 No
         OI    FLAGS4,F4MEMINV         Indicate MEMBER specified
*
PARS110  EQU   *                                                   v200
         LA    R2,UNIPCE               -> UNIT PCE                 v200
         TM    6(R2),X'80'             Was UNIT specified?         v200
         BZ    PARS120                 No                          v200
         L     R3,0(,R2)               -> UNIT string              v200
         LH    R1,4(,R2)               Length of unit name         v200
         MVC   USRUNIT,BLANKS          Init receiving field        v200
         BCTR  R1,0                    Adjust for execute          v200
         EX    R1,MVUNIT               Move the unit               v200
         OI    FLAGS2,F2UNIT           Indicate unit valid         v200
*
PARS120  EQU   *                                                   v200
         LA    R2,DIRPCE               -> # dir blocks PCE         v200
         TM    6(R2),X'80'             Was DIR specified?          v200
         BZ    PARS130                 No                          v200
*
         L     R3,0(,R2)               -> word containing # blks   v200
         MVC   USRDIR,0(R3)            Save specified #            v200
         OI    FLAGS2,F2DIR            Indicate DIR valid          v200
*
PARS130  EQU   *                                                   v200
         B     XITPAR00                All done
         DROP  R4                      PRDSECT
*
MVVOL    MVC   USRVOL(0),0(R3)         executed instr
MVUNIT   MVC   USRUNIT(0),0(R3)        executed instr              v200
MVINDS   MVC   0(0,R5),0(R3)           executed instr
MVINMEM  MVC   USRMEM(0),0(R3)         executed instr
*
*
*- Examine prompt parameter results
PARS200  EQU   *
         L     R4,ANSWER               -> IKJPARS built PCEs
         USING PRMSECT,R4
*
PARS220  EQU   *
         LA    R2,ACTPCE               -> PURGE/END PCE
         CLC   0(2,R2),=AL2(1)         Was PURGE specified?
         BNE   PARS230                 No
         OI    FLAGS4,F4PURGE          Indicate purge
*
PARS230  EQU   *
         CLC   0(2,R2),=AL2(2)         Was END specified?
         BNE   PARS240                 No
         OI    FLAGS4,F4END            Indicate END
*
PARS240  EQU   *
         LA    R2,VLPCE                -> VOLSER PCE
         TM    6(R2),X'80'             Was VOLSER specified?
         BZ    PARS250                 No
         L     R3,0(,R2)               -> VOLSER string
         LH    R1,4(,R2)               Length of volser
         MVC   USRVOL,BLANKS           Init receiving field
         BCTR  R1,0                    Adjust for execute
         EX    R1,MVVOL                Move the volser
         OI    FLAGS4,F4VOLSER         Indicate volser valid
*
PARS250  EQU   *
         LA    R2,DAPCE                -> DATASET PCE
         TM    6(R2),X'80'             Was DATASET specified?
         BZ    PARS280                 No
         MVC   FINALDS,BLANKS          Init receiving field
         LA    R5,FINALDS              -> where to place DSN
*
         TM    6(R2),X'40'             Was dataset name in quotes?
         BO    PARS260                 Y, don't insert prefix
         CLC   PREFIX,BLANKS           Is a prefix available?
         BE    PARS260                 All blank, dont use prefix
*
         MVC   FINALDS(8),PREFIX       Add the prefix
         TRT   FINALDS,BLANK           Look for end of prefix
         MVI   0(R1),C'.'              Set delim after prefix
         LA    R5,1(,R1)               -> place to put rest of dsn
         LA    R2,DAPCE                -> DATASET PCE
*
PARS260  EQU   *
         L     R3,0(,R2)               -> DATASET string
         LH    R1,4(,R2)               Length of DSN
         BCTR  R1,0                    Adjust for execute
         EX    R1,MVINDS               Move the DSN
         OI    FLAGS4,F4DS             Indicate DATASET valid
         NI    FLAGS3,255-F3DS         DATASET from cmd line not valid
*
PARS270  EQU   *
         TM    14(R2),X'80'            Was DATASET member specified?
         BZ    PARS280                 No
         OI    FLAGS4,F4MEMINV         Indicate MEMBER specified
*
PARS280  EQU   *
         LA    R2,UNPCE                -> UNIT PCE                 v200
         TM    6(R2),X'80'             Was UNIT specified?         v200
         BZ    PARS290                 No                          v200
         L     R3,0(,R2)               -> UNIT string              v200
         LH    R1,4(,R2)               Length of unit name         v200
         MVC   USRUNIT,BLANKS          Init receiving field        v200
         BCTR  R1,0                    Adjust for execute          v200
         EX    R1,MVUNIT               Move the unit               v200
         OI    FLAGS2,F2UNIT           Indicate unit valid         v200
*
PARS290  EQU   *                                                   v200
         LA    R2,DRPCE                -> # dir blocks PCE         v200
         TM    6(R2),X'80'             Was DIR specified?          v200
         BZ    PARS300                 No                          v200
*
         L     R3,0(,R2)               -> word containing # blks   v200
         MVC   USRDIR,0(R3)            Save specified #            v200
         OI    FLAGS2,F2DIR            Indicate DIR valid          v200
*
PARS300  EQU   *                                                   v200
         B     XITPAR00                All done
         DROP  R4                      PRMSECT
*
*-- Exit
*
XITPAR00 EQU   *
         LA    R1,ANSWER               -> IKJPARS "answer place"
         IKJRLSA (1)                   Release parsing storage
*
         SR    R0,R0               Set secondary RC=0;
         SR    R15,R15             Set RC=0;
         B     XITPAR
*
XITPAR12 EQU   *
         LA    R15,12              Set RC=12; R0 already set by IKJPARS
         B     XITPAR
*
XITPAR   EQU   *
         L     R13,4(,R13)         -> prev s.a.
         L     R14,12(,R13)        Load r14
         LM    R1,R12,24(R13)      Reload callers regs
         BR    R14                 Return with RCs in R0/R15
*
         LTORG
*
*-- IKJPARS Description Macros
*
*-- RECEIVE command parms:
*
*     RECEIVE  #### INDATASET(ddd) VOLSER(vvv) UNIT(uuu) DATASET(iii)
*                   DIR(nnn)
*                   PURGE | NOPURGE
*                   PROMPT | NOPROMPT
*                   QUIET
*
*   Where:
*
*     #### if specified must be the first parm, all numeric spool id
*     ddd is an optional dataset name to RECEIVE from
*     vvv is an optional VOLSER of where to allocate the RECEIVEd data
*     uuu is an optional UNIT of where to allocate the RECEIVEd data
*     iii is an optional DSNAME to RECEIVE into.
*     nnn is an optional number of directory blocks to assign
*     PURGE indicates the spool file is purged after RECEIVE  (DEFAULT)
*     NOPURGE indicates the spool file is retained after RECEIVE
*     PROMPT indicates to prompt user for parameters          (DEFAULT)
*     NOPROMPT no user prompts are issued
*     QUIET  suppress all informational msgs
*
*
PCLDEFS  IKJPARM DSECT=PRDSECT
*
FILEPCE  IKJIDENT 'FILE NUMBER',                                       x
               MAXLNTH=4,FIRST=NUMERIC,OTHER=NUMERIC,                  x
               INTEG
*
PURPCE   IKJKEYWD DEFAULT='PURGE'
         IKJNAME  PURGE            PCE value = 1
         IKJNAME  NOPURGE          PCE value = 2
*
PRMTPCE  IKJKEYWD DEFAULT='PROMPT'
         IKJNAME  PROMPT           PCE value = 1
         IKJNAME  NOPROMPT         PCE value = 2
*
QTPCE    IKJKEYWD
         IKJNAME  QUIET            PCE value = 1
*
INDSPCE  IKJKEYWD
         IKJNAME  'INDATASET',SUBFLD=INDSFLD,ALIAS='INDSNAME'
*
FDSPCE   IKJKEYWD
         IKJNAME  'DATASET',SUBFLD=FDSFLD,ALIAS='DSNAME'
*
VSRPCE   IKJKEYWD
         IKJNAME  'VOLSER',SUBFLD=VOLSFLD,ALIAS='VOLUME'
*
USRPCE   IKJKEYWD ,                                                v200
         IKJNAME  'UNIT',SUBFLD=UNISFLD,ALIAS=('U')                v200
*
DRBPCE   IKJKEYWD ,                                                v200
         IKJNAME  'DIR',SUBFLD=DBSFLD                              v200
*
INDSFLD  IKJSUBF
INDAPCE  IKJPOSIT DSNAME,                                              x
               PROMPT='THE NAME OF THE DATA SET YOU WANT TO RECEIVE FROx
               M'
*
FDSFLD   IKJSUBF
FDAPCE   IKJPOSIT DSNAME,                                              x
               PROMPT='THE NAME OF THE DATA SET YOU WANT TO RECEIVE INTx
               O'
*
VOLSFLD  IKJSUBF
VOLPCE   IKJPOSIT DSTHING,VOLSER,                                      x
               PROMPT='THE VOLUME SERIAL OF THE VOLUME WHERE YOU WANT Tx
               HE DATASET ALLOCATED'
*
UNISFLD  IKJSUBF ,                                                 v200
UNIPCE   IKJIDENT 'UNIT NAME',MAXLNTH=8,FIRST=ALPHANUM,            v200x
               OTHER=ALPHANUM                                      v200
*
DBSFLD   IKJSUBF ,                                                 v200
DIRPCE   IKJIDENT 'DIRECTORY BLOCKS',                              v200x
               MAXLNTH=5,FIRST=NUMERIC,OTHER=NUMERIC,              v200x
               INTEG                                               v200
*
         IKJENDP
*
*-- RECEIVE parameters from prompt:
*
*     DATASET(ddd) VOLSER(vvv) UNIT(uuu) DIR(nnn) PURGE/END
*
*   Where:
*
*     ddd is an alternate dataset name to RECEIVE intp
*     vvv is an optional VOLSER of where to allocate the RECEIVEd data
*     uuu is an optional UNIT of where to allocate the RECEIVEd data
*     nnn is an optional number of directory blocks to assign
*     PURGE indicates the spool file is purged immediately and the
*      RECEIVE operation is aborted.
*     END indicates the RECEIVE operation is aborted with no action.
*
PRMTOPS  IKJPARM DSECT=PRMSECT
*
ACTPCE   IKJKEYWD DEFAULT=
         IKJNAME  PURGE            PCE value = 1
         IKJNAME  END              PCE value = 2
*
DSPCE    IKJKEYWD
         IKJNAME  'DATASET',SUBFLD=DAFLD,ALIAS='DSNAME'
*
VSPCE    IKJKEYWD
         IKJNAME  'VOLSER',SUBFLD=VLFLD,ALIAS='VOLUME'
*
USPCE    IKJKEYWD ,                                                v200
         IKJNAME  'UNIT',SUBFLD=UNFLD,ALIAS=('U')                  v200
*
DBPCE    IKJKEYWD ,                                                v200
         IKJNAME  'DIR',SUBFLD=DRFLD                               v200
*
DAFLD    IKJSUBF
DAPCE    IKJPOSIT DSNAME,                                              x
               PROMPT='THE NAME OF THE DATA SET YOU WANT TO RECEIVE INTx
               O'
*
VLFLD    IKJSUBF
VLPCE    IKJPOSIT DSTHING,VOLSER,                                      x
               PROMPT='THE VOLUME SERIAL OF THE VOLUME WHERE YOU WANT Tx
               HE DATASET ALLOCATED'
*
UNFLD    IKJSUBF ,                                                 v200
UNPCE    IKJIDENT 'UNIT NAME',MAXLNTH=8,FIRST=ALPHANUM,            v200x
               OTHER=ALPHANUM                                      v200
*
DRFLD    IKJSUBF ,                                                 v200
DRPCE    IKJIDENT 'DIRECTORY BLOCKS',                              v200x
               MAXLNTH=5,FIRST=NUMERIC,OTHER=NUMERIC,              v200x
               INTEG                                               v200
*
         IKJENDP
*
*
         IKJPPL
IKJPPLSZ EQU   (*-PPL)/4           # words in PPL
*
         LTORG
*
*                                                                     *
***********************************************************************
**                                                                   **
**                        TASK ESTAE EXIT                            **
**                                                                   **
** This csect handles all abends trapped by ESTAE during the normal  **
** execution of the subtask.          This exit does not attempt     **
** any recovery other than to terminate processing.                  **
** An SVC dump is taken on abends.                                   **
**                                                                   **
** On entry:  R0=ESTAE provide entry code                            **
**            R1=SDWA address                                        **
**            R2=parameter passed on ESTAE macro                     **
**                                                                   **
**                                                                   **
** On exit: If SDWACLUP is 1, then no retry is allowed and this      **
**             exit will allow percolation back to system routines   **
**             to terminate the task.                                **
**                                                                   **
**          If SDWACLUP is 0, then retry is allowed.                 **
**                                                                   **
** Security:  N/A.                                                   **
**                                                                   **
** Register usage:                                                   **
**                                                                   **
**   R1  = SDWA address                                              **
**   R3  = SDWA address                                              **
**   R10 = Dynamic storage area base                                 **
**   R12 = This program base                                         **
**                                                                   **
**                                                                   **
**                                                                   **
***********************************************************************
*
NJEDMP   CSECT
         B     28(,R15)               BRANCH AROUND EYECATCHERS
         DC    AL1(23)                LENGTH OF EYECATCHERS
         DC    CL9'NJEDMP'
         DC    CL9'&SYSDATE'
         DC    CL5'&SYSTIME'
*
         LR    R12,R15                SET UP BASE REG
         USING NJEDMP,R12             ESTABLISH ADDRESSABILITY
         LR    R8,R14                 SAVE RETURN ADDRESS TO SYSTEM
*
         L     R10,0(,R1)             GET VALUE PASSED TO US (WORKA)
         USING NJEWK,R10
         L     R11,=A(NJECOM)          -> common csect
         USING NJECOM,R11
*
         LR    R3,R1                  SAVE R1 ENTRY CONTENTS
         USING SDWA,R3
         LR    R5,R0                  Save R0 entry code
*
         LTR   R3,R3                  Do we have an SDWA?
         BZ    NOSDWA                 Exit if no SDWA
         LA    R13,MVSSAVE            Save area
         ESTAE 0
*
         MODESET MODE=SUP,            Run this ESTAI exit privileged   x
               KEY=ZERO                to access PSW -> storage
*
         MVC   MACLIST(WTOMSGL),WTOMSG
         L     R6,PSATOLD-PSA(0)      -> my TCB
         L     R5,TCBTIO-TCB(,R6)     -> TIOT
         MVC   MACLIST+9(8),0(R5)         Plug in job name
         MVC   MACLIST+4(4),=C'USER'
         MVC   MACLIST+19(7),=C'RECEIVE'  Plug in command name
*
*
LNK020   EQU   *
         MVC   MACLIST+29(5),=C'ABEND'
         L     R5,SDWAABCC              GET ABEND CODE INFO WORD
         N     R5,=X'00FFF000'          KEEP ONLY THE SYSTEM CODE
         BZ    USERCDE                  NONE THERE, MUST BE A USER CODE
         SRL   R5,12                    Put sys code in low order  v201
         C     R5,=X'00000222'          Operator cancel, no dump?  v201
         BE    SDUMP040                 Yes, suppress dump
         CLM   R5,1,=X'3E'              Was it an x3E (DETACH) ?   v201
         BE    SDUMP040                 Yes, suppress dump         v201
*
         MVI   MACLIST+35,C'S'          INDICATE SYSTEM CODE
         UNPK  FWORK(5),SDWACMPC(3)     GET SYSTEM CMP CODE
         TR    FWORK(3),HEXTRAN-240
         MVC   FWORK+3(5),=CL5' '       CLEAR REST OF ABEND CODE
         B     NOREAS
*
USERCDE  EQU   *
         MVI   MACLIST+35,C'U'         INDICATE USER ABEND CODE
         L     R5,SDWAABCC             GET ABEND CODE
         N     R5,=X'00000FFF'         KEEP USER ABEND CODE
         CVD   R5,FSAVE                CONVERT CODE TO DECIMAL
         UNPK  FWORK(4),FSAVE          UNPK THE CODE
         OI    FWORK+3,X'F0'           FIX SIGN
         MVC   FWORK+4(2),=CL2' '      BLANKS AT END OF ABEND CODE
*
NOREAS   EQU   *
         MVC   MACLIST+36(6),FWORK     MOVE ABEND-REASON TO LINE
         MVC   ABCODE,MACLIST+36       Save a copy of formatted abcode
*
         WTO   ,MF=(E,MACLIST)        Write to console
         LA    R2,MACLIST
         BAL   14,PUTLINE             Echo to TSO terminal
*
         MVC   MACLIST(WTOMSGL),WTOMSG
         MVC   MACLIST+4(3),=C'PSW'
         UNPK  FSAVE(9),SDWAEC1(5)    Add zones to PSW word 1
         TR    FSAVE(8),HEXTRAN-240
         MVC   MACLIST+10(8),FSAVE
         UNPK  FSAVE(9),SDWAEC1+4(5)  Add zones to PSW word 2
         TR    FSAVE(8),HEXTRAN-240
         MVC   MACLIST+19(8),FSAVE
*
         SR    R5,R5                   CLEAR FOR IC
         IC    R5,SDWAILC1             GET THE ILC
         CVD   R5,FWORK                MAKE DECIMAL
         MVC   MACLIST+29(3),=C'ILC'
         UNPK  MACLIST+33(2),FWORK     UNPK
         OI    MACLIST+34,X'F0'        FIX THE SIGN
*
         MVC   MACLIST+37(4),=C'INTC'
         UNPK  FWORK(5),SDWAINC1(3)    MAKE INTC DISPLAYABLE
         TR    FWORK(4),HEXTRAN-240
         MVC   MACLIST+42(4),FWORK     MOVE INTC TO LINE
*
         WTO   ,MF=(E,MACLIST)
         LA    R2,MACLIST
         BAL   14,PUTLINE             Echo to TSO terminal
*
         MVC   MACLIST(WTOMSGL),WTOMSG
         MVC   MACLIST+4(13),=C'DATA NEAR PSW'
         MVC   MACLIST+19(8),=CL8'UNAVAIL'  ASSUME WE CANT GET DATA
         L     R4,SDWAEC1+4            Get PSW IA
         LA    R4,0(,R4)               Clear high bit
         C     R4,=F'8'                1st 8 bytes of storage?
         BH    LOC010                  No, its higher than that
         SR    R4,R4                   Yes, just use 0
         B     LOC020
*
LOC010   EQU   *
         S     R4,=F'8'                BACK UP BEFORE INTERRUPT ADDR
*
LOC020   EQU   *
         LRA   R0,0(,R4)               Do we have access?
         BNZ   UNAVAIL                 No translation, better not
         LRA   R0,14(,R4)              Do we have access?
         BNZ   UNAVAIL                 No translation, better not
*
         ST    R4,FWORK                SAVE FOR CONVERSION
         UNPK  FSAVE(9),FWORK(5)       ADD ZONES TO ADDRESS
         TR    FSAVE(8),HEXTRAN-240    MAKE DISPLAYABLE HEX
         MVC   MACLIST+19(8),FSAVE     MOVE DISPLAYABLE
*
         MVC   FWORK(4),0(R4)          MOVE 4 WORDS AT PSW
         UNPK  FSAVE(9),FWORK(5)       ADD ZONES
         TR    FSAVE(8),HEXTRAN-240    MAKE DISPLAYABLE HEX
         MVC   MACLIST+29(8),FSAVE     MOVE TO LINE
*
         MVC   FWORK(4),4(R4)          MOVE 4 WORDS AT PSW
         UNPK  FSAVE(9),FWORK(5)       ADD ZONES
         TR    FSAVE(8),HEXTRAN-240    MAKE DISPLAYABLE HEX
         MVC   MACLIST+38(8),FSAVE     MOVE TO LINE
*
         MVC   FWORK(4),8(R4)          MOVE 4 WORDS AT PSW
         UNPK  FSAVE(9),FWORK(5)       ADD ZONES
         TR    FSAVE(8),HEXTRAN-240    MAKE DISPLAYABLE HEX
         MVC   MACLIST+47(8),FSAVE     MOVE TO LINE
*
         MVC   FWORK(4),12(R4)         MOVE 4 WORDS AT PSW
         UNPK  FSAVE(9),FWORK(5)       ADD ZONES
         TR    FSAVE(8),HEXTRAN-240    MAKE DISPLAYABLE HEX
         MVC   MACLIST+56(8),FSAVE     MOVE TO LINE
*
UNAVAIL  EQU   *
         WTO   ,MF=(E,MACLIST)
         LA    R2,MACLIST
         BAL   14,PUTLINE              Echo to TSO terminal
*----
         LA    R4,4                    4 ROWS OF REGISTERS
         LA    R5,SDWAGR00             POINT TO ABEND REGS
         LA    R6,REGLIST              POINT TO REGISTER ID LITERALS
*
REG000   EQU   *
         MVC   MACLIST(WTOMSGL),WTOMSG
         MVC   MACLIST+4(8),0(R6)      MOVE REGISTERS ID
         LA    R15,MACLIST+13          WHERE 1ST REG GOES ON LINE
         LA    R14,4                   4 REGS PER LINE
*
REG010   EQU   *
         UNPK  FSAVE(9),0(5,R5)        UNPK A REGISTER
         TR    FSAVE(8),HEXTRAN-240    MAKE DISPLAYABLE HEX
         MVC   0(8,R15),FSAVE          MOVE TO THE LINE
         LA    R15,10(,R15)            NEXT SPOT ON PRINT LINE
         LA    R5,4(,R5)               NEXT REGISTER
         BCT   R14,REG010              KEEP DOING REGS
         WTO   ,MF=(E,MACLIST)
         LA    R2,MACLIST
         BAL   14,PUTLINE              Echo to TSO terminal
         LA    R6,8(,R6)               NEXT REGISTER ID
         BCT   R4,REG000               GO DISPLAY THE NEXT ROW
*
*
SDUMP000 EQU   *
         L     R5,SDWAABCC             Get abend code info word
         N     R5,=X'00FFF000'         Keep only the system code
         SRL   R5,12                   Right justify the code
         C     R5,=X'00000222'         Operator cancel, no dump?
         BE    SDUMP040                Yes, skip dump
         CLM   R5,1,=X'37'             x37 abend code?
         BE    SDUMP040                Skip the dump
*
         MVI   DHDR,C' '
         MVC   DHDR+1(29),DHDR
         MVI   DHDR,29                IBM length of header
         L     R5,PSATOLD-PSA(0)      -> my TCB
         L     R5,TCBTIO-TCB(,R5)     -> TIOT
         MVC   DHDR+1(8),0(R5)        Use jobname in description
         MVC   DHDR+11(7),=C'RECEIVE' Use command name
         MVC   DHDR+21(7),ABCODE
*
         MVC   MACLIST(SDUMPL),SDUMP    MOVE SDUMP LIST TO WORK
         LA    R1,MACLIST
         SDUMP HDRAD=DHDR,              ISSUE SDUMP TO RECORD STATUS   x
               BUFFER=NO,                                              x
               QUIESCE=NO,                                             x
               SDATA=(RGN,CSA,LPA,SUM),                                x
               MF=(E,(1))
*
*
SDUMP040 EQU   *
*
SDUMP090 EQU   *
         LR    R1,R3                  SDWA BACK TO R1
         L     R15,=A(NJERCV)         Main csect addr
         ST    R15,SDWASRSV+4*R12     Plug it to R12
         L     R15,=A(EXIT08)         -> RECEIVE exit point
*
         SETRP RC=4,                  Retry - try to shut down RECEIVE x
               DUMP=NO,               Suppress any further dumps       x
               FRESDWA=YES,           Free the SDWA                    x
               RETREGS=YES,           Restore original regs            x
               RETADDR=(15)           Return to Receive exit point
*
NOSDWA   EQU   *                  **  NO RETRY AVAILABLE (OR DESIRED)
         SR    R15,R15                REQUEST PERCOLATION
         LR    R14,R8                 RESTORE RETURN ADDRESS
         BR    R14                    RETURN TO SYSTEM
*
         LTORG
*
SDUMP    SDUMP MF=L
SDUMPL   EQU   *-SDUMP
*
REGLIST  DC    CL8'GR 0-3'
         DC    CL8'GR 4-7'
         DC    CL8'GR 8-11'
         DC    CL8'GR 12-15'
*
WTOMSG   WTO   '                                                       x
                                             ',MF=L
WTOMSGL  EQU   *-WTOMSG
*
         LTORG
*
*
****  Main work area common                                             NJE00290
****  to all NJExxx CSECTs.                                             NJE00290
*                                                                       NJE00290
NJEWK    DSECT
NJEEYE   DS    CL4'NJER'           Eyecatcher
NJEWKLEN DS    F                   Getmain size of this area
*
DBLE     DS    D                   Work area                            NJE00310
TWRK     DS    2D                  Work area
LCLNODE  DS    CL8                 Local node id
DEFUSER  DS    CL8                 Default 'no security' userid
USERID   DS    CL8                 TSO Userid
PREFIX   DS    CL8                 TSO PREFIX
*
*
MACLIST  DS    CL96                   Macro expansion area
STAXLIST DS    CL20                   STAX parameter list
*                                                                       NET02360
CPARMS   DS    A                      -> input CPPL (entry parms)
PUTECB   DS    F                      ECB for PUTLINE/PUTGET
IOPLAREA DS    4A                     IOPL for PUTLINE/PUTGET
DEVINFO  DS    A                      -> Entry selected from disks tbl
SV14CTL  DS    A                      R14 save area                     NET02370
SV14GB   DS    A                      R14 save area                     NET02370
SV14GET  DS    A                      R14 save area                     NET02370
SV14LN   DS    A                      R14 save area                     NET02370
SV14PUR  DS    A                      R14 save area                     NET02370
SVR0CTL  DS    F                      R0 save of # value for a key      NET02370
*
GBREM    DS    F                      # bytes remaining in phys rec     NET02380
GBPOS    DS    A                      -> current position in BUFF       NET02390
GBRPS    DS    A                      -> current position in phys rec   NET02400
GBRBA    DS    F        for debug     RBA of last GETBYTES call         NET02400
GBPBA    DS    F        for debug     RBA of prior GETBYTES call        NET02400
RBUFF    DS    A                      -> Record build area
RBPOS    DS    A                      -> current position in RBUFF      NET02390
*
BLOCKLEN DS    F                      Length of block buffer
BLOCK    DS    A                      -> Block of physical records
NEWLEN   DS    F                      Length of NEWDS RECFM=U buffer
NEWBLK   DS    A                      -> NEWDS RECFM=U build buffer
*
OLD      DS    F                      For PUTGET, # segments
OLDMSGAD DS    A                      -> msg len/text
*
PARSECB  DS    F                      IKJPARS ECB
ANSWER   DS    F                      IKJPARS Answer area
PPLSTG   DS    (IKJPPLSZ)A            Space for PPL
FILEID   DS    F                      User specified spool id #
USRDIR   DS    F                      User specified # of dir blks v200
USRVOL   DS    CL6                    User specified VOLSER
USRUNIT  DS    CL8                    User specified UNIT name     v200
USRINDS  DS    CL44                   User specified INDATASET
USRMEM   DS    CL8                    User specified INDATASET member
FINALDS  DS    CL44                   Final dataset name
*
*
FLAGS1   DS    X                      Flag bits
F1INMR01 EQU   X'80'  1... ....        INMR01 fields processed
F1INMR2A EQU   X'40'  .1.. ....        1st INMR02 fields processed
F1INMR2B EQU   X'20'  ..1. ....        2nd INMR02 fields processed
F1INMR03 EQU   X'10'  ...1 ....        INMR03 fields processed
F1BATCH  EQU   X'08'  .... 1...        Running in BATCH TSO
F1ACEE   EQU   X'04'  .... .1..        Security is available on system
F1AUSR   EQU   X'02'  .... ..1.        Special user
F1APF    EQU   X'01'  .... ...1        Authorized at invocation
*
FLAGS2   DS    X                      Flag bits
F2NETOPN EQU   X'80'  1... ....        NETDATA DCB open
F2NCBOPN EQU   X'40'  .1.. ....        NETSPOOL NCB open
F2NEWOPN EQU   X'20'  ..1. ....        NEWDS DCB open
F2TERM   EQU   X'10'  ...1 ....        INMTERM text unit detected
F2DIR    EQU   X'08'  .... 1...        DIR (CMD -OR- PROMPT) spec. v200
F2FLAT   EQU   X'04'  .... .1..        Incoming file is a flat file
F2UNIT   EQU   X'02'  .... ..1.        UNIT (CMD -OR- PROMPT) spec.v200
F2FEND   EQU   X'01'  .... ...1        Force END in batch after 1st pmt
*                     .... ....        available bits
*
FLAGS3   DS    X                      Flag bits from CMD line parse
F3FILEID EQU   X'80'  1... ....        Spool file id specified
F3PURGE  EQU   X'40'  .1.. ....        1=PURGE, 0=NOPURGE
F3VOLSER EQU   X'20'  ..1. ....        VOLSER specified
F3INDS   EQU   X'10'  ...1 ....        INDATASET specified
F3INMEM  EQU   X'08'  .... 1...        INDATASET MEMBER specified
F3DS     EQU   X'04'  .... .1..        DATASET specified
F3NPRMPT EQU   X'02'  .... ..1.        NOPROMPT was specified
F3QUIET  EQU   X'01'  .... ...1        QUIET was specified
*
FLAGS4   DS    X                      Flag bits from prompt parse
F4MEMINV EQU   X'80'  1... ....        DATASET MEMBER specified (inval)
F4PURGE  EQU   X'40'  .1.. ....        PURGE (delete spool file & exit)
F4VOLSER EQU   X'20'  ..1. ....        VOLSER specified
F4DS     EQU   X'10'  ...1 ....        DATASET specified
F4END    EQU   X'08'  .... 1...        END (take no action and exit)
F4ATTN   EQU   X'01'  .... ...1        User pressed ATTN key       v201
*                     .... .xx.        available bits
*                                                                       NET02470
INMF01   DS    (INMFSZ)X              Fields from INMR01 record
INMF02A  DS    (INMFSZ)X              Fields from 1st INMR02 record
INMF02B  DS    (INMFSZ)X              Fields from 2nd INMR02 record
INMF03   DS    (INMFSZ)X              Fields from INMR03 record
*                                                                       NET02590
         DS    0F
BUFF     DS    CL256                  GB buffer containing request data NET02600
LIST     DS    CL133                  Print line                   v200
REC      DS    CL133                  Physical record from spool
*
*----
LS99PTR  DS    A                       PTR TO S99RB
LS99RB   DS    XL20                    SPACE FOR S99RB
*
TXTPTRS  DS    15A                     -> Text unit ptr list
*
         DS    0H
UTXT     DS    0XL06,Y,AL2,AL2         DDNAME Unallocation
UDDNAME  DS    CL8                      DDNAME
*
         DS    0H
TXT01    DS    0XL06,Y,AL2,AL2         Return DDNAME
TDDNAME  DS    CL8                      DDNAME
*
         DS    0H
TXT02    DS    0XL06,Y,AL2,AL2         DSN=
TDSNAME  DS    CL44                     DSNAME
*
         DS    0H
TXT03    DS    0XL07,Y,AL2,AL2,X       DISP=(NEW,
*
         DS    0H
TXT04    DS    0XL07,Y,AL2,AL2,X       DISP=(,CATLG)
*
         DS    0H
TXT05    DS    0XL06,Y,AL2,AL2         SPACE BLOCK LEN
TBLKLEN  DS    XL3                      BLKLEN
*
         DS    0H
TXT06    DS    0XL06,Y,AL2,AL2         SPACE PRIMARY
TPRIME   DS    XL3                      Primary
*
         DS    0H
TXT07    DS    0XL06,Y,AL2,AL2         SPACE SECONDARY
TSECND   DS    XL3                      Secondary
*
         DS    0H
TXT08    DS    0XL06,Y,AL2,AL2         SPACE DIRECTORY BLOCKS
TDIRBLKS DS    XL3                      DIR BLKS
*
         DS    0H
TXT09    DS    0XL06,Y,AL2,AL2         VOLUME
TVOLSER  DS    CL6                      VOLSER
*
         DS    0H
TXT10    DS    0XL14,Y,AL2,AL2         UNIT                        v200
TUNIT    DS    CL8                      UNITNAME                   v200
*
         DS    0H
TXT11    DS    0XL06,Y,AL2,AL2         EXPDT
TEXPDT   DS    CL5                      EXPDT=yyddd
*
         DS    0H
TXT12    DS    0XL06,Y,AL2,AL2         BLKSIZE
TBLKSIZE DS    XL2                      BLKSIZE
*
         DS    0H
TXT13    DS    0XL06,Y,AL2,AL2         DSORG
TDSORG   DS    XL2                      DSORG
*
         DS    0H
TXT14    DS    0XL06,Y,AL2,AL2         LRECL
TLRECL   DS    XL2                      LRECL
*
         DS    0H
TXT15    DS    0XL06,Y,AL2,AL2         RECFM
TRECFM   DS    XL1                      RECFM
*
         DS    0H
TXT16    DS    0XL04,Y,AL2             DUMMY
*
         DS    0H
TXT17    DS    0XL04,Y,AL2             SYSOUT
*
         DS    0H
TXT18    DS    0XL04,Y,AL2             TERM
*
         DS    0H
TXT19    DS    0XL04,Y,AL2             CYLINDER
*
         DS    0H
TXT20    DS    0XL04,Y,AL2             FREE=CLOSE
*---
*
CTL      DS    X                      Segment descriptor byte
*
*
         DS    0F
TAGDATA  DS    XL108                  TAG data area
TYPPRT   EQU   X'40'                   PRT dev
TYPPUN   EQU   X'80'                   PUN dev
*
NCB1     DS    XL48                   NCB for Spool Access
NETDATA  DS    (DMYNPSL)X             NETDATA DCB
NEWDS    DS    (DMYSEQL)X             New dataset DCB
DECB     DS    (READL)X               DECB for NETDATA
*
CPYPLIST DS    XL(COPYPRML)            IEBCOPY PARM FIELD
*
         DS    0H
DDLISTL  DS    AL2(DDLISTSZ)           DDNAME LIST LENGTH
DDLIST   DS    4XL8'00'                    FOUR DDNAMES UNDEFINED
DDSYSIN  DS    CL8    DDNAME representing IEBCOPY's SYSIN
DDSYSPR  DS    CL8    DDNAME representing IEBCOPY's SYSPRINT
         DS    XL8'00'                     UNDEFINED DD
DDSYSUT1 DS    CL8    DDNAME of ds created by INMRCOPY INMR02 (SYSUT1)
DDSYSUT2 DS    CL8    DDNAME representing IEBCOPY's SYSUT2
DDSYSUT3 DS    CL8    DDNAME representing IEBCOPY's SYSUT3
         DS    XL8'00'                     SYSUT4 UNUSED
DDLISTSZ EQU   *-DDLIST                LENGTH OF DDLIST for IEBCOPY
DDNETDAT DS    XL8'00'                 INDATASET DDNAME
DDNETSPL DS    XL8'00'                 NETSPOOL DDNAME
UNLISTSZ EQU   *-DDLIST                TOTAL of all DDs in list
*
*-- ESTAE exit used areas
*
FSAVE    DS    2D
FWORK    DS    D
DHDR     DS    CL30
ABCODE   DS    CL7
MVSSAVE  DS    18F                 ESTAE exit OS save
*-- End of ESTAE area
*
*
NJESA    DS    18F                    NJERCV OS save area               NJE00300
NETSA    DS    18F                    NJENET OS save area               NJE00300
DYNSA    DS    18F                    NJEDYN OS save area               NJE00300
PARSA    DS    18F                    NJEPAR OS save area               NJE00300
NOTSA    DS    18F                    NJENOT OS save area               NJE00300
*
         DS    0D                     Force doubleword size
NJEWKSZ  EQU   *-NJEWK
*                                                                       NJE00930
         CVT   DSECT=YES,PREFIX=NO
         IEFZB4D0
         IEFZB4D2
         DCBD  DSORG=PS,DEVD=DA
*
IEFUCBOB DSECT
         IEFUCBOB LIST=YES
         IHAPSA
         IKJTCB
         IHASDWA
IEFTIOT  DSECT
         IEFTIOT1
         IHAASCB
         IHAASXB
         IKJUPT
         IKJCPPL
         IKJPGPB
         IKJIOPL
*
ACEE     DSECT                         Maps a portion of ACEE in MVS3.8
ACEEEYE  DS    CL4'ACEE'
         DS    16X
ACEEUSRL DS    X                       Length of userid
ACEEUSR  DS    CL8                     Userid
*
         COPY  NETSPOOL                                                 NJE00940
         COPY  TAG
*
         END   NJERCV                                                   NJE01000
./ ADD NAME=NJERLY
*
*
*-- NJERLY - NJE38-Registered User Interface
*
*
*
* Change log:
*
*
* 10 Dec 20 - Initial creation                                     v220
*
*
*
*
         PRINT GEN
         REGEQU                        REGISTER EQUATES
         GBLC  &VERS
*
REGISTER EQU   1
DREGISTR EQU   2
WAIT     EQU   3
GETMSG   EQU   4
GETECB   EQU   5
*
HIGHCODE EQU   5                       Set to highest valid req code
*
*
NJERLY   CSECT
         NJEVER
         STM   R14,R12,12(R13)         SAVE REGS
         LR    R12,R15                 BASE
         USING NJERLY,R12              ADDRESS IT
         LR    R6,R1                   Save off input parms
         LM    R7,R9,0(R6)              Load parameters
*                                  r7 -> njetkn word
*                                  r8 =  function code
*                                  r9 -> string value
*
         SR    R10,R10                 Assume no work area
         C     R8,=A(HIGHCODE)         Request code too high?
         BH    EXIT12X                 Y, invalid request
         C     R8,=A(REGISTER)         Register request?
         BL    EXIT12X                 No too low; invalid request
         BNE   INIT010                 Not register; skip Getmain
*
INIT000  EQU   *
         GETMAIN RU,                   Get local stg area              X
               LV=4096,                                                X
               BNDRY=PAGE
         LR    R10,R1
         LR    R1,R0                   Copy length
         LR    R2,R0                   Copy length
         LR    R0,R10                  -> new stg area
         SR    R15,R15                 set pad
         MVCL  R0,R14                  Clear the page
         ST    R10,0(,R7)              Return the stg tkn to caller
*
INIT010  EQU   *
         ICM   R10,15,0(R7)            Get our work area addr (njetkn)
         BZ    EXIT12X                 Not reg: invalid request
         USING NJERWK,R10
         ST    R13,NJESA+4             SAVE prv S.A. ADDR
         LA    R1,NJESA                -> my save area
         LR    R13,R1
*
         MVC   NJEEYE,=CL4'NJER'       Work area eyecatcher
         LA    R2,NJEWKSZ              Get size of our work area
         ST    R2,NJEWKLEN             Save size of area in area
         ST    R6,APARMS               Save ptr to input parms
*
         L     R11,=A(NJECOM)          -> common csect
         USING NJECOM,R11
         ST    R11,ANJECOM             Save in main work area
*
         SR    R1,R1                   Dont return spool DSN
         L     R15,=V(NJESYS)          -> ENQ finder
         BALR  R14,R15                 Check if NJE38 already act
         LTR   R15,R15                 Look for RC=0
         BNZ   EXIT16                  No.  NJE38 is not active
         ST    R1,NJE38CSA             Save NJE38's CSA block addr
         MVC   LCLNODE,NJ38NODE-NJ38CSA(R1)  Save off lcl node name
*
*
MAIN000  EQU   *
         LR    R15,R8                  Copy function code
         SLL   R15,2                   Multiply by 4 into branch idx
         B     MAIN010(R15)            Branch into table
*
MAIN010  EQU   *
         B     EXIT12              0 - Cant happen; invalid request
         B     REG000              1 - Register request
         B     DREG000             2 - Deregister request
         B     WAIT000             3 - Wait request
         B     GTM000              4 - Get message
         B     GTE000              5 - Get ECB address
*
*
* REGISTER
*
*   Exit RCs:  0  = successful
*             12  = Invalid request (bad userid)
*             16  = NJE38 is not active
*             20  = POST failed
*             24  = Userid already registered
*
*
REG000   EQU   *
         MVC   USERID,0(R9)        Copy requestor userid
         TRT   USERID,VALDNAME     Validate the characters within
         BNZ   EXIT12              Name is not valid.  Inv request
*
*-- Issue STIMER for keep alive to avoid S 522 abends
*
         L     R0,=A(NJETEX)           -> Timer expiration exit
         L     R1,=A(INTVL)            -> interval
         STIMER REAL,                  Set timer                       X
               (0),                                                    X
               DINTVL=(1)
*
*-- Initialize console processing to allow MVS modify and stop
*-- commands to control this address space
*
REG040   EQU   *
         MVC   MACLIST(EXTRACTL),EXTRACT Move macro model
         LA    R3,COMMAREA             -> area to place comm area addr
         EXTRACT (3),                  Get ptr to comm area            X
               FIELDS=COMM,                                            X
               MF=(E,MACLIST)
*
         L     R3,COMMAREA             -> ptrs to COMM CIB and ECB
         USING IEZCOM,R3               Map the communication area
         MVC   COMMECBA,COMECBPT       Save off addr of COMM ECB
         ICM   R4,15,COMCIBPT          Get addr of CIB ptr
         BZ    REG060                  No CIB, go get one
         USING CIBNEXT,R4              Map the CIB
*
         CLI   CIBVERB,CIBSTART        Is this a START CIB?
         BNE   REG060                  No, set up CIB count
*
         QEDIT ORIGIN=COMCIBPT,        Free the CIB from the START cmd X
               BLOCK=(4)                that started this space
*
REG060   EQU   *
         QEDIT ORIGIN=COMCIBPT,        Set CIB limit to 1              X
               CIBCTR=1
         DROP  R4                      IEZCIB
         DROP  R3                      IEZCOM
*
REG090   EQU   *
         MODESET KEY=ZERO,MODE=SUP
*
         GETMAIN RU,               Obtain stg for a WRE                x
               LV=WRESIZE,                                             x
               SP=241
         LR    R4,R1               -> WRE
         USING WRE,R4
         XC    0(WRESIZE,R4),0(R4)
         ST    R4,AREGWRE          Save WRE address for life of reg
         MVI   WRESP,241           Set subpool
         MVI   WRETYPE,WREREG      Register user WRE
         MVC   WRELINK,LCLNODE     Set target node for WRE
         MVC   WREUSER,USERID      Set requestor userid
*
         MVC   WREASCB,PSAAOLD-PSA(0)  Set our ASCB addr
*
         MVC   WRETXT,BLANKS       Init receiving field
         BAL   R14,PST000          POST NJE38 with our request
         LTR   R15,R15             Was post successful?
         BNZ   EXIT20              No
*
         WAIT  1,ECB=WREECB        Wait for NJE38's response
         L     R5,WREECB           Load ECB value
         XC    WREECB,WREECB       Clear the ECB
         N     R5,=X'0000FFFF'     Keep only our POST code
         B     QUIT000             Exit with POST code as RC
         DROP  R4                  WRE
*
*
* DEREGISTER
*
*   Exit RCs:  0  = successful
*             12  = Invalid request (bad userid)
*             16  = NJE38 is not active
*             20  = POST failed
*             28  = Userid not registered
*
*
DREG000  EQU   *
         ICM   R4,15,AREGWRE       -> registration WRE
         BZ    EXIT28              No WRE, user is not registered
         USING WRE,R4
*
         MODESET KEY=ZERO,MODE=SUP
*
         MVI   WRETYPE,WREDREG     Deregister user WRE
*
         BAL   R14,PST000          POST NJE38 with our request
         LTR   R15,R15             Was post successful?
         BNZ   EXIT20              No
*
         WAIT  1,ECB=WREECB        Wait for NJE38's response
         L     R5,WREECB           Load ECB value
         XC    WREECB,WREECB       Clear the ECB
         N     R5,=X'0000FFFF'     Keep only our POST code
         BNZ   QUIT000             Exit with POST code if non-zero
         DROP  R4                  WRE
*
         FREEMAIN RU,              Free the WRE                        x
               LV=WRESIZE,                                             x
               A=(4),                                                  x
               SP=241
*
         XC    AREGWRE,AREGWRE     Clear the anchor
         TTIMER CANCEL                 Cancel the timer
         B     EXIT00              Exit with success
*
* GET MESSAGE
*
*   Exit RCs:  0  = successful
*              4  = No message queued
*             12  = Invalid request (bad userid)
*             16  = NJE38 is not active
*             20  = POST failed
*             28  = Userid not registered
*
*
GTM000   EQU   *
         ICM   R4,15,AREGWRE       -> registration WRE
         BZ    EXIT28              No WRE, user is not registered
         USING WRE,R4
*
         MODESET KEY=ZERO,MODE=SUP
*
         MVI   WRETYPE,WREDRM      Dequeue and retrieve a msg
*
         BAL   R14,PST000          POST NJE38 with our request
         LTR   R15,R15             Was post successful?
         BNZ   EXIT20              No
*
         WAIT  1,ECB=WREECB        Wait for NJE38's response
         L     R5,WREECB           Load ECB value
         XC    WREECB,WREECB       Clear the ECB
         N     R5,=X'0000FFFF'     Keep only our POST code
         BNZ   QUIT000             Exit with POST code if non-zero
*
         MVC   0(L'WRETXT,R9),WRETXT Give msg to caller
         MVI   L'WRETXT(R9),X'00'  Ensure string terminated
         B     EXIT00              Exit with success
         DROP  R4                  WRE
*
* GET ECB ADDRESS
*
*   Exit RCs:  0  = successful
*             28  = Userid not registered
*
*
GTE000   EQU   *
         ICM   R4,15,AREGWRE       -> registration WRE
         BZ    EXIT28              No WRE, user is not registered
*
         LA    R5,USERECB          -> User accessible ECB
         B     QUIT010             Exit w/ ECB addr as the ret code
*
*
* WAIT
*
*   Exit RCs:  0  = successful; a message has been queued
*              8  = MVS Console STOP command entered (non-TSO only)
*             16  = NJE38 is not active
*             28  = Not registered
*             32  = USER ECB posted
*
*
WAIT000  EQU   *
         NC    AREGWRE,AREGWRE     Is registration complete?
         BZ    EXIT28              No, no user is registered
*
         BAL   R14,BLDL000             Go build the ECB list
*
         MODESET KEY=ZERO,MODE=SUP     Use key 0 for CSA ECB
*
         WAIT  1,ECBLIST=ECBLIST
*
*-- Identify the ECB that was posted
*
WAIT010  EQU   *
         LM    R2,R4,ECBLIST           Get our ECB ptrs
         TM    0(R2),X'40'             Was COMM ECB posted?
         BO    COMM000                 Yes
         TM    0(R3),X'40'             Was WRE ECB posted?
         BO    WRK000                  Yes
         TM    0(R4),X'40'             Was USER ECB posted?
         BO    EXIT32                  Yes
*
         B     WAIT000                 Nothing; go back to sleep
*
*
*-- Build a new ECBLIST before the wait
*
BLDL000  EQU   *
         SR    R1,R1                   Init: no ECBs in list
         LA    R15,ECBLIST-4           -> 0th ECB list entry
         LA    R15,4(,R15)             -> next available ECB list slot
         L     R1,COMMECBA             -> COMM ECB
         ST    R1,0(,R15)              Set addr in ECB list
         LA    R15,4(,R15)             -> next available ECB list slot
         L     R1,AREGWRE              -> registration WRE in CSA
         LA    R1,WREECB-WRE(,R1)      -> WRE work ECB
         ST    R1,0(,R15)              Set addr in ECB list
         LA    R15,4(,R15)             -> next available ECB list slot
         LA    R1,USERECB              -> User accessible ECB
         ST    R1,0(,R15)              Set addr in ECB list
         OI    0(R15),X'80'            Mark end of list
         BR    R14                     Return with ECB list built
*
*
*-- Address space Communications ECB was posted
*-- The QEDIT macro will clear the COMM ECB
*
COMM000  EQU   *
         L     R4,COMMAREA             -> Communications area
         USING IEZCOM,R4
         L     R5,COMCIBPT             -> CIB
         USING CIBNEXT,R5
         CLI   CIBVERB,CIBMODFY        Modify cmd?
         BE    MOD000                  Yes
         CLI   CIBVERB,CIBSTOP         Stop cmd?
         BE    STOP000                 Yes, let subtasks know
U0038    ABEND 38,DUMP,STEP            Shouldnt happen
*
MOD000   EQU   *
         QEDIT ORIGIN=COMCIBPT,BLOCK=(5)     Purge the CIB
         B     WAIT010
*
*
*
STOP000  EQU   *
         QEDIT ORIGIN=COMCIBPT,BLOCK=(5)     Purge the CIB
         DROP  R4                      IEZCOM
         DROP  R5                      IEZCIB
*
STOP010  EQU   *
         OI    NJFL1,NJF1STOP          Indicate STOP ordered
         B     EXIT08                  And exit
*
WRK000   EQU   *
         XC    0(4,R3),0(R3)           Clear the WRE ECB
         B     EXIT00                  Indicate wait completed
*
*
EXIT00   EQU   *
         LA    R5,ERNOERR              No errors
         B     QUIT000
*
EXIT04   EQU   *
         LA    R5,ERNOMSG              No more messages
         B     QUIT000
*
EXIT08   EQU   *
         LA    R5,ERSTOP               STOP command issued
         B     QUIT000
*
EXIT12   EQU   *
         LA    R5,ERINVREQ             Invalid request
         B     QUIT000
*
EXIT12X  EQU   *
         LA    R5,ERINVREQ             Invalid request on entry
         B     QUIT090
*
EXIT16   EQU   *
         LA    R5,ERINACT              NJE38 not active
         B     QUIT000
*
EXIT20   EQU   *
         LA    R5,ERPOST               POST NJE38 failed
         B     QUIT000
*
EXIT24   EQU   *
         LA    R5,ERDUPUSR             User already registered
         B     QUIT000
*
EXIT28   EQU   *
         LA    R5,ERUSERNF             User not registered (not found)
         B     QUIT000
*
EXIT32   EQU   *
         LA    R5,ERECBPST             User ECB was posted
         B     QUIT000
*
QUIT000  EQU   *
         MODESET KEY=NZERO,MODE=PROB
*
QUIT010  EQU   *
         L     R13,4(,R13)             -> caller's sa
*
*
QUIT090  EQU   *
         LR    R1,R10                  -> NJEWK main work area page
         ST    R5,16(,R13)             Set RC in save area
*
         LTR   R1,R1                   Anything to free?
         BZ    QUIT095                 No
*
         C     R8,=A(DREGISTR)         De-registration request?
         BNE   QUIT095                 No.  Dont free work area
         XC    0(4,R7),0(R7)           Clear callers tkn (njetkn)
*
         FREEMAIN RU,                  Release our area                x
               LV=4096,                                                x
               A=(1)
*
QUIT095  EQU   *
         LM    R14,R12,12(R13)         Reload system's regs
         BR    R14                     Return
*
         LTORG
*
EXTRACT  EXTRACT MF=L
EXTRACTL EQU   *-EXTRACT
ESTAE    ESTAE 0,MF=L
ESTAEL   EQU   *-ESTAE
*
*
         DROP  R12
*
*********************
*  N J E C O M      *               NJECOM hosts small routines and
*                   *               frequently used constants that
*  Common routines  *               are available to all NJExxx csects
*  and constants    *               via base register 11
*                   *
*********************
*
NJECOM   CSECT
         DC    A(0)                 No branch around constants
         DC    AL1(23)                LENGTH OF EYECATCHERS
         DC    CL9'NJECOM'
         DC    CL9'&SYSDATE'
         DC    CL5'&SYSTIME'
         USING NJECOM,R11
         USING NJERWK,R10
*
*
*-- Get a new command type WRE
*
*-- Caller must be in PSW key 0 before call
*
*-- Entry:  None
*   Exit:   R1 -> WRE
*
*
GTW000   EQU   *
         ST    R14,SVR14           Save return addr
         GETMAIN RU,               Get CSA for WRE TYPE=WREREG         x
               LV=WRESIZE,                                             x
               SP=241
         XC    0(WRESIZE,R1),0(R1)    Clear stg area
         USING WRE,R1
         MVI   WRESP,241           Set subpool
         MVI   WRETYPE,WREREG      Registration WRE
         DROP  R1
         L     R14,SVR14           Load return addr
         BR    R14
*
*-- Queue the WRE to NJE38's main task
*-- Caller must be PSW key 0
*
*-- Entry:  R4 -> WRE
*-- Exit:   None
*
PST000   EQU   *
         ST    R14,SVR14           Save return addr
         L     R6,NJE38CSA         -> NJE38 CSA block
         USING NJ38CSA,R6
         USING WRE,R4
         LM    R0,R1,NJ38SWAP      Get first WRE ptr, sync count
*
PST020   EQU   *
         ST    R0,WRENEXT          First WRE becomes next
         LA    R5,1(,R1)           Incr synchronization count
         CDS   R0,R4,NJ38SWAP      Update LINK WRE anchor, sync
         BC    7,PST020            Gotta try again
*
         LA    R5,NJ38ECB          -> NJE38 external WRE ECB
         L     R6,NJ38ASCB         -> NJE38 ASCB
         DROP  R6                  NJ38CSA
         DROP  R4                  WRE
*
         MVC   MACLIST(POSTL),POST Move macro model
         POST  (5),                Wake up NJE38                       x
               ASCB=(6),                                               x
               ERRET=PST030,       Exit if can't do the post           x
               ECBKEY=0,                                               x
               MF=(E,MACLIST)
*
         SR    R15,R15             Set POST success RC
         L     R14,SVR14           Load return addr
         BR    R14
*
PST030   EQU   *
         LA    R15,20              POST failed
         L     R14,SVR14           Load return addr
         BR    R14
*
*
*
*
*
POST     POST  0,ASCB=0,ERRET=0,MF=L
POSTL    EQU   *-POST
*
BLANKS   DC    CL120' '
NONBLANK DC    64X'FF',X'00',191X'FF'   TR Table to locate nonblank
BLANK    DC    64X'00',X'FF',191X'00'   TR Table to locate blanks
HEXTRAN  DC    CL16'0123456789ABCDEF'  Translate table
*                 0 1 2 3 4 5 6 7 8 9 A B C D E F
VALDNAME DC    X'FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' 0 Invalid userid
         DC    X'FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' 1 characters
         DC    X'FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' 2
         DC    X'FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' 3
         DC    X'00FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' 4  Blank=ok/delim
         DC    X'FFFFFFFFFFFFFFFFFFFFFF00FFFFFFFF' 5  valid= $
         DC    X'FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' 6
         DC    X'FFFFFFFFFFFFFFFFFFFFFF0000FFFFFF' 7  valid= # @
         DC    X'FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' 8
         DC    X'FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' 9
         DC    X'FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' A
         DC    X'FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' B  valid =
         DC    X'FF000000000000000000FFFFFFFFFFFF' C  C1-C9
         DC    X'FF000000000000000000FFFFFFFFFFFF' D  D1-D9
         DC    X'FFFF0000000000000000FFFFFFFFFFFF' E  E2-E9
         DC    X'00000000000000000000FFFFFFFFFFFF' F  F0-F9
*
         LTORG
*
*
*
*
***************
* TIMER       *                        THIS EXIT WILL KEEP THE JOB
* EXPIRATION  *                        ACTIVE EVERY 20 MINUTES, AND
* EXIT        *                        WILL KEEP THE JOB FROM ABENDING
***************                        WITH AN S 522 ABEND (WAIT LIMIT)
*
NJETEX   CSECT
         B     28(,R15)                BRANCH AROUND EYECATCHERS
         DC    AL1(23)                 LENGTH OF EYECATCHERS
         DC    CL9'NJETEX'
         DC    CL9'&SYSDATE'
         DC    CL5'&SYSTIME'
         STM   R14,R12,12(R13)
         LR    R12,R15
         USING NJETEX,R12
*
         STIMER REAL,                  RESET THE TIMER AGAIN           X
               (12),                   POINT TO THE EXIT ROUTINE       X
               DINTVL=INTVL            INTERVAL
*
         LM    R14,R12,12(R13)         RELOAD REGS
         SR    R15,R15
         BR    R14                     RETURN TO SYSTEM
*
         DS    0D
*                  HHMMSSTH
INTVL    DC    CL8'00200000'           20 MINUTE TIMER
*
         DROP  R12
         LTORG
*
*
****  Main work area common
****  to all NJExxx CSECTs.
*
NJERWK   DSECT
NJEEYE   DS    CL4'NJER'           Eyecatcher; work area
NJEWKLEN DS    F                   Getmain size of this area
*
DBLE     DS    D                   Work area
TWRK     DS    2D                  Work area
LCLNODE  DS    CL8                 Local node name
USERID   DS    CL8                 Requestor userid
*
*
MACLIST  DS    XL160               Macro expansion area
ANJECOM  DS    A                   -> NJECOM csect
COMMAREA DS    A                   -> Console communications area
COMMECBA DS    A                   -> Console communications ECB
NJE38CSA DS    A                   -> NJE38's CSA block
APARMS   DS    A                   -> Caller's parm list
AREGWRE  DS    A                   CSA addr of registration WRE
USERECB  DS    F                   User accessible ECB
*
ECBLIST  DS    3A                  ECB list
*
NJFL1    DS    X                   Flag byte
NJF1STOP EQU   X'80'   1... ...     STOP command issued
*                      ..xx xx..    Available
*
NJFL2    DS    X                   Flag byte
*                      xxxx xxxx    Available
*
*
SVR14    DS    A                   R14 save
NJESA    DS    18F                 NJEINIT OS save area
BALRSAVE DS    16F                 Local register save area
*
         DS    0D                      Force doubleword size
NJEWKSZ  EQU   *-NJERWK
*
*
*-- System DSECTs
*
*
IEZCOM   DSECT
         IEZCOM
IEZCIB   IEZCIB
         IHAPSA
         IHASDWA
         IKJTCB
         IHAASCB
*
CSCB     DSECT
         IEECHAIN                      MAP FOR A CSCB
         CVT   DSECT=YES,LIST=NO
         DCBD  DEVD=DA,DSORG=PS
*
         COPY  NETSPOOL
*
*-- NJE38 DSECTs
*
         NJEWRE
*
         END   NJERLY
./ ADD NAME=NJESCN
*
*
*-- NJE38 - Configuration scan and create
*
*
*   Called by NJEINIT (on start up)
*   Called by NJECMX (for commands entered by users and operators)
*
*
* Change log:
*
* 04 Dec 20 - Expanded internal trace table support                v212
* 29 Nov 20 - Initial creation                                     v211
*
*
*
* notes for doc:
*
* -keywords must start in col 1
* -keywords and values 1-8 bytes only
* -last keyword or value on line must have a trailing blank (e.g,
*    column 80 must be blank)
* -CUU must be 3-digit
* -ROUTE names are not validated for existence, or character makeup
*
*
*
         GBLC  &VERS
         REGEQU
NJESCN   CSECT                                                          NJE00020
         NJEVER
         STM   R14,R12,12(R13)         Save Regs                        NJE00050
         LR    R12,R15                 Base                             NJE00060
         LA    R11,2048
         LA    R11,2048(R11,R12)       2nd Base
         USING NJESCN,R12,R11                                           NJE00070
         LR    R7,R0                   Save input code
         LR    R8,R1                   Save input parm list addr
         LR    R9,R2                   Save input parm list addr
*
         LA    R0,NJEWKSZ              Size of work area
         GETMAIN RU,                   Get local stg area              X
               LV=(0),                                                 X
               BNDRY=PAGE
         LR    R10,R1
         LR    R1,R0                   Copy length
         LR    R2,R0                   Copy length
         LR    R0,R10                  -> new stg area
         SR    R15,R15                 set pad
         MVCL  R0,R14                  Clear the stg
*
         USING NJEWK,R10
         ST    R13,NJESA+4             SAVE prv S.A. ADDR               NJE00080
         LA    R1,NJESA                -> my save area
         ST    R1,8(,R13)              Plug it into prior SA
         LR    R13,R1
*
         MVC   NJEEYE,=CL4'NJES'       Work area eyecatcher
         ST    R2,NJEWKLEN             Save size of area in area
         STM   R8,R9,INITPLST          Save entry parm list addrs
         MVC   INITPARM,0(R8)          Copy passed parameters
*
INIT000  EQU   *
         B     INIT010(R7)             Branch into request table
*
INIT010  EQU   *
         B     SCN000               00 Scan and create configuration
         B     CMD000               04 Scan a configuration command
*
SCN000   EQU   *
         MVC   CONFIG,DMYDCB           Set up DCB
         LA    R1,JFCBL                -> JFCB area
         ST    R1,EXLST                Plug into exit list
         MVI   EXLST,X'87'             Set up for JFCB retrieve
         LA    R4,CONFIG               -> DCB
         USING IHADCB,R4
         LA    R1,EXLST                -> exit list
         STCM  R1,7,DCBEXLST+1         Plug it into DCB
*
         MVC   MACLIST(RDJFCBL),RDJFCB Move macro model
         RDJFCB CONFIG,MF=(E,MACLIST)
*
         MVC   MACLIST(OPENL),OPEN     Move macro model
         OPEN  (CONFIG,INPUT),         Open dataset                    x
               MF=(E,MACLIST)
         TM    DCBOFLGS,DCBOFOPN       Did DCB open ok?
         BZ    EXIT08                  No
         DROP  R4                      IHADCB
         OI    NJFL1,F1OPEN            Indicate DCB is open
*
         LA    R3,JFCBL
         USING JFCB,R3
         MVC   WTOMSG,WTO              Move WTO model
         MVC   WTOTXT(L'NJE049I),NJE049I  Using configuration DSN
         MVC   WTOTXT+28(44),JFCBDSNM  Move DSN
         TM    JFCBIND1,JFCPDS         Using PDS member?
         BZ    SCN030                  No
         TRT   WTOTXT+28(45),BLANK     Look for end of DSN
         MVI   0(R1),C'('
         MVC   1(8,R1),JFCBELNM        Move member name
         TRT   0(10,R1),BLANK          Look for end of member name
         MVI   0(R1),C')'
         DROP  R3                      JFCB
*
SCN030   EQU   *
         WTO   ,MF=(E,WTOMSG)          Write the using config msg
         SR    R9,R9                   Init record counter
*
SCN040   EQU   *
         GET   CONFIG,REC              Get a record from CONFIG DD
         LA    R1,REC                  -> RECORD
         LA    R9,1(,R9)               Bump record count
         CLI   0(R1),C'*'              Comment line?
         BE    SCN040                  Yes, skip it
         CLI   0(R1),C' '              Blank leading off the line?
         BE    ERR073                  Yes, this is invalid
*
         OC    REC,BLANKS              Upper case the record
         LA    R15,80                  Scan length of input line
         B     CTK000                  Join common code
*
SCN100   EQU   *                       End of scan of one record
         B     SCN040                  Scan next
*
*
*
CMD000   EQU   *
         L     R2,ACMDBLOK             -> CMDBLOK
         USING CMDBLOK,R2
         MVC   REC,BLANKS              Init receiving field
         IC    R1,CMDBLEN              Len of command text
         EX    R1,OCCMD                Move and uppercase cmd image
         DROP  R2                      CMDBLOK
         LA    R15,120                 Max len of command image
         LA    R1,REC                  -> Command image
*
CTK000   EQU   *
         BAL   R14,TKN000              Parse and tokenize the cmd
         LA    R15,TOKENS-L'TOKENS     -> 0th length/token in list
         BAL   R14,GETTKN              Get 1st token
*
         CLC   =CL8'LOCAL',1(R15)      Local?
         BE    LCL000                  Yes
         CLC   =CL8'LINK',1(R15)       Link?
         BE    LNK000                  Yes
         CLC   =CL8'ROUTE',1(R15)      Route?
         BE    RTE000                  Yes
         CLC   =CL8'AUTH',1(R15)       Auth?
         BE    AUTH000                 Yes
         B     ERR076                  Unknown configuration statement
*
OCCMD    OC    REC(0),CMDTEXT-CMDBLOK(R2)  Executed instr
*
RETURN   EQU   *                       R7 branch table index
         B     SCN040               00 Read another config record
         B     EXIT00               04 End of command processing
*
*-- LOCAL
*
LCL000   EQU   *
         L     R1,ALINKS               -> LINKS anchor word
         NC    0(4,R1),0(R1)           Was LOCAL processed?
         BNZ   ERR052                  Y, only one LOCAL allowed
         LA    R0,LINKLEN              Length of LINKTABL entry
         BAL   R14,GETSTG              Get stg for entry
         LR    R8,R1
         XC    0(LINKLEN,R8),0(R8)     Initialize entry
         USING LINKTABL,R8
*
         BAL   R14,GETTKN              Get next token
         BZ    ERR075                  No local name
         MVC   LINKID,1(R15)           Local node name to entry
         TRT   LINKID,VALDNAME         Valid node name?
         BNZ   ERR043                  No
*
         MVC   LDEFUSER,DEFUSER        Set default userid
         BAL   R14,GETTKN              Get next tkn (should be DEFUSER)
         BZ    LCL090                  No other tokens
         CLC   =CL8'DEFUSER',1(R15)    Was this the DEFUSER keyword?
         BNE   ERR055                  No, error
         BAL   R14,GETTKN              Get next tkn (should be userid)
         BZ    ERR075                  Missing userid
         MVC   LDEFUSER,1(R15)         Set default userid of choice
         DROP  R8                      LINKTABL
*
LCL090   EQU   *
         L     R15,ALINKS              -> LINKS anchor word
         ST    R8,0(,R15)              Start LINKS chain
         B     RETURN(R7)              Resume scan
*
*
*-- LINK
*
LNK000   EQU   *
         L     R1,ALINKS               -> LINKS anchor word
         NC    0(4,R1),0(R1)           Was LOCAL processed?
         BZ    ERR053                  No; it is required
         LA    R8,BLDBUF               Temp area to build entry
         XC    0(LINKLEN,R8),0(R8)     Initialize entry
         USING LINKTABL,R8
         MVC   LBUFF,=H'1012'          Set default buffer size
*
         BAL   R14,GETTKN              Get next token
         BZ    ERR075                  No link name
         MVC   LINKID,1(R15)           Link node name to entry
         TRT   LINKID,VALDNAME         Valid node name?
         BNZ   ERR043                  No
*
LNK010   EQU   *
         BAL   R14,GETTKN              Get next tkn
         BZ    LNK050                  None
*
         CLC   =CL8'LINE',1(R15)       Was it a LINE keyword?
         BE    LNE000                  Yes
         CLC   =CL8'BUFF',1(R15)       Was it a BUFF keyword?
         BE    BUF000                  Yes
         CLC   =CL8'AUTO',1(R15)       Was it a AUTO keyword?
         BE    ATO000                  Yes
         CLC   =CL8'OFF',1(R15)        Was it the OFF keyword?
         BE    LOFF000                 Yes
         B     ERR055                  Unrecognized keyword
*
LNK050   EQU   *
         TM    NJFL2,F2LINE            Was line CUU found?
         BZ    ERR077                  No, its required
*
*-- LINK successfully scanned.  Now add the LINKTABL entry to chain.
*
         L     R2,ALINKS               -> LINKS anchor word (0th entry)
         L     R2,0(,R2)               -> First LINKTABL e.g. LOCAL
*
LNK060   EQU   *
         ICM   R3,15,LNEXT-LINKTABL(R2) -> next LINKTABL entry
         BZ    LNK080                  Found the end
         CLC   LINKID,LINKID-LINKTABL(R3)   Match on link name?
         BE    LNK120                  Yes, trying to add duplicate
*
LNK070   EQU   *
         LR    R2,R3                   Copy next entry ptr
         B     LNK060                  Keep scanning for end
*
LNK080   EQU   *
         LA    R0,LINKLEN              Size of LINKTABL entry
         BAL   R14,GETSTG              Get an actual entry
         MVC   0(LINKLEN,R1),0(R8)     Make build entry a permanent one
         ST    R1,LNEXT-LINKTABL(,R2)  Add R1 LINKTABL to chain end
*
LNK090   EQU   *
         LTR   R7,R7                   Doing CONFIG scan?
         BZ    SCN100                  Yes, Resume scan
*
*--Issue LINK cmd success msg
         MVC   WTOMSG,WTO              Move WTO model
         MVC   WTOTXT(L'NJE066I),NJE066I
         MVC   WTOTXT+13(8),LINKID     Move link name to msg
         TRT   WTOTXT+13(9),BLANK      Look for end
         MVC   1(7,R1),=CL7'defined'
         LA    R0,22(,R1)              -> end of msg
         LA    R1,WTOTXT               -> start of msg
         SR    R0,R1                   Compute length to display
         B     SUCCMSG                 Issue success msg and exit
*
LNK120   EQU   *                    ** Here for duplicate entry
*--Issue LINK cmd duplicate msg
         MVC   WTOMSG,WTO              Move WTO model
         MVC   WTOTXT(L'NJE048E),NJE048E
         MVC   WTOTXT+13(8),LINKID     Move link name to msg
         TRT   WTOTXT+13(9),BLANK      Look for end
         MVC   1(20,R1),=CL20'duplicate definition'
         LTR   R7,R7                   Doing CONFIG scan?
         BZ    LNK130                  Yes, issue duplicate msg
         MVC   1(20,R1),=CL20'is already defined'
*
LNK130   EQU   *
         LA    R0,34(,R1)              -> end of msg
         LA    R1,WTOTXT               -> start of msg
         SR    R0,R1                   Compute length to display
         B     ERRTYPE(R7)             Issue dup msg
*
LNE000   EQU   *
         BAL   R14,GETTKN              Get next tkn
         BZ    ERR075                  Missing CUU
         CLI   0(R15),X'02'            Check keyword length
         BNE   ERR078                  Not valid CUU
         LR    R3,R1                   Save R1 across TRT
         TRT   1(3,R15),INVALHEX       Valid hex chars?
         BNZ   ERR078                  Not valid cuu
*
         LR    R1,R3                   Restore R1
         MVC   TWRK(3),1(R15)          Move the character CUU
         TR    TWRK(3),TRANHEX-192     Make all A-F chars = xFA-XFF
*
         PACK  DBLE(3),TWRK(4)         Strip the zones
         MVC   LDEFLINE,DBLE           Move to LINKTABL entry
         OI    NJFL2,F2LINE            Indicate valid LINE CUU found
         B     LNK010                  Continue LINK token eval
*
BUF000   EQU   *
         BAL   R14,GETTKN              Get next tkn
         BZ    ERR075                  Missing buffersize
         SR    R3,R3                   Clear for IC
         IC    R3,0(,R15)              Length of value characters
         EX    R3,BFMVC                Make a copy of value
         EX    R3,BFOC                 Force copy to be numeric
         EX    R3,BFCLC                Was original numeric?
         BNE   ERR054                  Invalid BUFF value
         EX    R3,BFPACK               Pack the value
         CVB   R0,DBLE                 Get binary value
         CH    R0,=H'300'              Too small?
         BL    ERR054                  Yes
         CH    R0,=H'4020'             Too large?
         BH    ERR054                  Yes
         STH   R0,LBUFF                Else set specified BUFF size
         B     LNK010                  Continue LINK token eval
*
BFMVC    MVC   DBLE(0),1(R15)          executed instr
BFOC     OC    DBLE(0),=8C'0'          executed instr
BFCLC    CLC   DBLE(0),1(R15)          executed instr
BFPACK   PACK  DBLE(8),1(0,R15)        executed instr
*
ATO000   EQU   *
         BAL   R14,GETTKN              Get next tkn
         BZ    ERR075                  Missing YES/NO
         CLC   =CL8'YES',1(R15)        Was it yes?
         BE    ATO020
         CLC   =CL8'NO',1(R15)         Was it no?
         BE    LNK010                  Line will not be autostartable
         B     ERR078                  Unrecognized value
*
ATO020   EQU   *
         OI    LFLAG,LAUTO             Set line auto-startable
         B     LNK010                  Continue LINK token eval
*
LOFF000  EQU   *
         LTR   R7,R7                   Doing config scan?
         BZ    ERR055                  OFF not recognized in CONFIG
         L     R2,ALINKS               -> LINKS anchor word
         L     R2,0(,R2)               -> 1st entry (LOCAL entry)
*
LOFF010  EQU   *
         ICM   R3,15,LNEXT-LINKTABL(R2) -> next link entry
         BZ    LOFF050                 Found the end, linkid not fnd
         CLC   LINKID,LINKID-LINKTABL(R3) Match on name?
         BNE   LOFF020                 No, next
*
         TM    LFLAG-LINKTABL(R3),LCONNECT+LACTIVE+LDRAIN  Link busy?
         BNZ   ERR046                  Yes, can't remove it
         CLC   LTCBA-LINKTABL(,R3),=A(0)  Task active on link?
         BNE   ERR046                  Nonzero, can't remove it
*
* Remove the matching entry from the LINKTABL chain:
         MVC   LNEXT-LINKTABL(,R2),LNEXT-LINKTABL(R3)
*
         MVC   WTOMSG,WTO              Move WTO model
         MVC   WTOTXT(L'NJE046I),NJE046I
         MVC   WTOTXT+13(8),LINKID-LINKTABL(R3) Move link name to msg
         TRT   WTOTXT+13(9),BLANK      Look for end
         MVC   1(7,R1),=CL7'deleted'
         LA    R2,13+8(,R1)            -> end of msg
         LA    R1,WTOTXT               -> start of msg
         SR    R2,R1                   Compute length to display
         FREEMAIN RU,                  Free entry that was removed v211x
               LV=LINKLEN,                                         v211x
               A=(3),                                              v211x
               SP=1                                                v211
*
***      LA    R3,LTRMECB-LINKTABL(,R3) -> task termination ECB
***      POST  (3),255                 Signal NJEINIT to delete link
*
         LR    R0,R2                   Msg length to R0
         B     SUCCMSG                 Issue success msg
*
LOFF020  EQU   *
         LR    R2,R3                   Copy next entry
         B     LOFF010                 Keep scanning for end
*
LOFF050  EQU   *
         MVC   WTOMSG,WTO              Move WTO model
         MVC   WTOTXT(L'NJE045I),NJE045I
         MVC   WTOTXT+13(8),LINKID     Move name to msg
         TRT   WTOTXT+13(9),BLANK       Look for end
         MVC   1(14,R1),=CL14'is not defined'
         LA    R0,13+15(,R1)           -> end of msg
         LA    R1,WTOTXT               -> start of msg
         SR    R0,R1                   Compute length to display
         B     SUCCMSG                 Issue success msg
         DROP  R8                      LINKTABL
*
*-- ROUTE
*
RTE000   EQU   *
         L     R1,ALINKS               -> LINKS anchor word
         NC    0(4,R1),0(R1)           Was LOCAL processed?
         BZ    ERR053                  No; it is required
         LA    R8,BLDBUF               Temp area to build entry
         XC    0(ROUTSIZE,R8),0(R8)    Initialize entry
         USING RTE,R8
         MVC   ROUTALT1,BLANKS         Init
         MVC   ROUTALT2,BLANKS         Init
         MVC   ROUTALT3,BLANKS         Init
*
         BAL   R14,GETTKN              Get next token
         BZ    ERR075                  No link name
         MVC   ROUTNAME,1(R15)         Route node name destination
         TRT   ROUTNAME,VALDNAME       Valid node name?
         BZ    RTE010                  Yes
         CLM   R2,1,=C'*'              Was wildcard in use?
         BNE   ERR043                  No. The name contains inv char
*
RTE010   EQU   *
         BAL   R14,GETTKN              Get next tkn
         BZ    RTE050                  None
*
         CLC   =CL8'TO',1(R15)         Was it the TO keyword?
         BE    TO000                   Yes
         CLC   =CL8'ALT',1(R15)        Was it a ALT keyword?
         BE    ALT000                  Yes
         CLC   =CL8'OFF',1(R15)        Was it the OFF keyword?
         BE    ROFF000                 Yes
         B     ERR055                  Unrecognized keyword
*
RTE050   EQU   *
         TM    NJFL2,F2RTO             Was ROUTE TO processed?
         BZ    ERR051                  No, its required
*
*-- ROUTE successfully scanned.
*
*  1. first check for existing name; if so, update existing.
*  2. else add new route in collating sequence, except that the
*     wildcard character (if present) is treated as a X'FF' character
*     in order to force wildcard routes after all explicity named
*     routes.
*
         L     R2,AROUTES              -> ROUTES anchor word (0th RTE)
*
RTE060   EQU   *
         ICM   R3,15,ROUTPTR-RTE(R2)   -> next RTE entry
         BZ    RTE080                  Found the end
         CLC   ROUTNAME,ROUTNAME-RTE(R3)   Match on name?
         BE    RTE070                  Yes, update duplicate
         LR    R2,R3                   Copy next entry
         B     RTE060                  Keep scanning for end
*
*-- Update existing route
RTE070   EQU   *
         L     R0,ROUTPTR-RTE(,R3)     Save RTE next ptr
         MVC   0(ROUTSIZE,R3),0(R8)    Update&replace existing route
         ST    R0,ROUTPTR-RTE(,R3)     Restore the next ptr
         B     RTE200                  Issue success msg
*
*-- Add new route to chain in collating seq based on route name
RTE080   EQU   *
         L     R2,AROUTES              -> ROUTES anchor word (0th RTE)
         MVC   DBLE,ROUTNAME           Copy name we want to add
         TR    DBLE,ASTER              Set any * char high
*
RTE090   EQU   *
         ICM   R3,15,ROUTPTR-RTE(R2)   -> next RTE entry
         BZ    RTE100                  Found the end; add to end
         MVC   TWRK,ROUTNAME-RTE(R3)   Copy name in chained RTE
         TR    TWRK,ASTER              Set any * char high
         CLC   DBLE,TWRK               Locate place to insert RTE
         BL    RTE100
         LR    R2,R3                   Copy next entry
         B     RTE090                  Keep scanning for end
*
RTE100   EQU   *
         LA    R0,ROUTSIZE             Length of RTE entry
         BAL   R14,GETSTG              Get stg for entry
         MVC   0(ROUTSIZE,R1),0(R8)    Make build entry a permanent one
         ST    R1,ROUTPTR-RTE(,R2)     Insert R1 RTE into chain
         ST    R3,ROUTPTR-RTE(,R1)     R1 RTE now points to next RTE
*
RTE200   EQU   *
         LTR   R7,R7                   Doing CONFIG scan?
         BZ    SCN100                  Yes, Resume scan
*
*--Issue ROUTE cmd success msg
         MVC   WTOMSG,WTO              Move WTO model
         MVC   WTOTXT(L'NJE065I),NJE065I
         MVC   WTOTXT+13(8),ROUTNAME   Move route name to msg
         TRT   WTOTXT+13(9),BLANK      Look for end
         MVC   1(19,R1),=CL19'routed through link'
         MVC   21(8,R1),ROUTNEXT       Move link name to msg
         LA    R0,21+8(,R1)            -> end of msg
         LA    R1,WTOTXT               -> start of msg
         SR    R0,R1                   Compute length to display
         B     SUCCMSG                 Issue success msg and exit
*
TO000    EQU   *
         BAL   R14,GETTKN              Get next tkn
         BZ    ERR075                  Missing node id
         MVC   ROUTNEXT,1(R15)         Move the route-to link id
         TRT   ROUTNEXT,VALDNAME       Valid node name?
         BNZ   ERR043                  Invalid node name if not
         OI    NJFL2,F2RTO             Indicate ROUTE TO processed
         B     RTE010                  Continue route scan
*
ALT000   EQU   *
         LA    R3,ROUTALT1             -> first alternate node id slot
         LA    R4,3                    Max number of alternates
*
ALT010   EQU   *
         BAL   R14,GETTKN              Get next tkn
         BZ    RTE050                  Done with route scan
         MVC   0(8,R3),1(R15)          Move the route alternate id
         LA    R3,8(,R3)               -> next alternate slot
         BCT   R4,ALT010               Continue route scan
         B     RTE050                  Done with route scan
*
ROFF000  EQU   *
         LTR   R7,R7                   Doing config scan?
         BZ    ERR055                  OFF not recognized in CONFIG
         L     R2,AROUTES              -> ROUTES anchor  (0th entry)
*
ROFF010  EQU   *
         ICM   R3,15,ROUTPTR-RTE(R2)   -> next RTE entry
         BZ    ROFF050                 Found the end, user/node not fnd
         CLC   ROUTNAME,ROUTNAME-RTE(R3)   Match on name?
         BNE   ROFF020                 No, next
*
* Remove the matching entry from the RTE chain:
         MVC   ROUTPTR-RTE(,R2),ROUTPTR-RTE(R3)
*
         MVC   WTOMSG,WTO              Move WTO model
         MVC   WTOTXT(L'NJE064I),NJE064I
         MVC   WTOTXT+23(8),ROUTNAME-RTE(R3) Move route name to msg
         TRT   WTOTXT+23(9),BLANK      Look for end
         MVC   1(7,R1),=CL7'deleted'
         LA    R2,23+8(,R1)            -> end of msg
         LA    R1,WTOTXT               -> start of msg
         SR    R2,R1                   Compute length to display
         FREEMAIN RU,                  Free entry that was removed     x
               LV=ROUTSIZE,                                            x
               A=(3),                                                  x
               SP=1
         LR    R0,R2                   Msg length to R0
         B     SUCCMSG                 Issue success msg
*
ROFF020  EQU   *
         LR    R2,R3                   Copy next entry
         B     ROFF010                 Keep scanning for end
*
ROFF050  EQU   *
         MVC   WTOMSG,WTO              Move WTO model
         MVC   WTOTXT(L'NJE063I),NJE063I
         MVC   WTOTXT+13(8),ROUTNAME   Move name to msg
         TRT   WTOTXT+13(9),BLANK       Look for end
         MVC   1(13,R1),=CL13'is not routed'
         LA    R0,13+14(,R1)           -> end of msg
         LA    R1,WTOTXT               -> start of msg
         SR    R0,R1                   Compute length to display
         B     SUCCMSG                 Issue success msg
         DROP  R8                      RTE
*
*-- AUTH
*
AUTH000  EQU   *
         L     R1,ALINKS               -> LINKS anchor word
         NC    0(4,R1),0(R1)           Was LOCAL processed?
         BZ    ERR053                  No; it is required
         LA    R8,BLDBUF               Temp area to build entry
         XC    0(AUTHSIZE,R8),0(R8)    Initialize entry
         USING AUTHLIST,R8
*
         BAL   R14,GETTKN              Get next token
         BZ    ERR075                  No userid
         MVC   AUTHUSER,1(R15)         Authorized userid
*
AUTH010  EQU   *
         BAL   R14,GETTKN              Get next tkn
         BZ    AUTH050                 None
*
         CLC   =CL8'AT',1(R15)         Was it the AT keyword?
         BE    AT000                   Yes
         CLC   =CL8'OFF',1(R15)        Was it the OFF keyword?
         BE    AOFF000                 Yes
         B     ERR055                  Unrecognized keyword
*
AUTH050  EQU   *
         TM    NJFL2,F2AAT             Was AUTH AT processed?
         BZ    ERR050                  No, its required
*
*-- AUTH successfully scanned.  Now add the AUTH entry to chain.
*
         L     R2,AAUTHS               -> AUTHS anchor word (0th entry)
*
AUTH060  EQU   *
         ICM   R3,15,AUTHPTR-AUTHLIST(R2) -> next AUTHLIST entry
         BZ    AUTH080                 Found the end
         CLC   AUTHUSER,AUTHUSER-AUTHLIST(R3)   Match on userid?
         BNE   AUTH070                 No, next
         CLC   AUTHNODE,AUTHNODE-AUTHLIST(R3)   Match on node?
         BE    AUTH120                 Yes, trying to add duplicate
*
AUTH070  EQU   *
         LR    R2,R3                   Copy next entry ptr
         B     AUTH060                 Keep scanning for end
*
AUTH080  EQU   *
         LA    R0,AUTHSIZE             Size of AUTHLIST entry
         BAL   R14,GETSTG              Get an actual entry
         MVC   0(AUTHSIZE,R1),0(R8)    Make build entry a permanent one
         ST    R1,AUTHPTR-AUTHLIST(,R2) Add R1 AUTHLIST to chain end
*
AUTH090  EQU   *
         LTR   R7,R7                   Doing CONFIG scan?
         BZ    SCN100                  Yes, Resume scan
*
*--Issue AUTH cmd success msg
         MVC   WTOMSG,WTO              Move WTO model
         MVC   WTOTXT(L'NJE068I),NJE068I
         MVC   WTOTXT+13(8),AUTHUSER   Move auth name to msg
         TRT   WTOTXT+13(9),BLANK      Look for end
         MVC   1(2,R1),=CL2'at'
         MVC   4(8,R1),AUTHNODE        Move link name to msg
         TRT   4(9,R1),BLANK           Look for end
         MVC   1(17,R1),=CL17'is now authorized'
         LA    R0,18(,R1)              -> end of msg
         LA    R1,WTOTXT               -> start of msg
         SR    R0,R1                   Compute length to display
         B     SUCCMSG                 Issue success msg and exit
*
AUTH120  EQU   *                    ** Here for duplicate entry
         LTR   R7,R7                   Doing CONFIG scan?
         BZ    SCN100                  Yes, skip duplicate msg
*--Issue AUTH cmd duplicate msg
         MVC   WTOMSG,WTO              Move WTO model
         MVC   WTOTXT(L'NJE067I),NJE067I
         MVC   WTOTXT+13(8),AUTHUSER   Move auth name to msg
         TRT   WTOTXT+13(9),BLANK      Look for end
         MVC   1(2,R1),=CL2'at'
         MVC   4(8,R1),AUTHNODE        Move link name to msg
         TRT   4(9,R1),BLANK           Look for end
         MVC   1(21,R1),=CL21'is already authorized'
         LA    R0,22(,R1)              -> end of msg
         LA    R1,WTOTXT               -> start of msg
         SR    R0,R1                   Compute length to display
         B     ERRMSG                  Issue dup msg to cmd issuer
*
AT000    EQU   *
         BAL   R14,GETTKN              Get next tkn
         BZ    ERR075                  Missing node id
         MVC   AUTHNODE,1(R15)         Move the auth node id to list
         TRT   AUTHNODE,VALDNAME       Valid node name?
         BNZ   ERR043                  No
         OI    NJFL2,F2AAT             Indicate AUTH AT processed
         B     AUTH010                 Continue AUTH scan
*
AOFF000  EQU   *
         LTR   R7,R7                   Doing config scan?
         BZ    ERR055                  OFF not recognized in CONFIG
         L     R2,AAUTHS               -> AUTHS anchor word (0th entry)
*
AOFF010  EQU   *
         ICM   R3,15,AUTHPTR-AUTHLIST(R2) -> next AUTHLIST entry
         BZ    AOFF050                 Found the end, user/node not fnd
         CLC   AUTHUSER,AUTHUSER-AUTHLIST(R3)   Match on userid?
         BNE   AOFF020                 No, next
         CLC   AUTHNODE,AUTHNODE-AUTHLIST(R3)   Match on node?
         BNE   AOFF020                 No, next
*
* Remove the matching entry from the AUTHLIST chain:
         MVC   AUTHPTR-AUTHLIST(,R2),AUTHPTR-AUTHLIST(R3)
*
         MVC   WTOMSG,WTO              Move WTO model
         MVC   WTOTXT(L'NJE070I),NJE070I
         MVC   WTOTXT+13(8),AUTHUSER-AUTHLIST(R3) Move auth name to msg
         TRT   WTOTXT+13(9),BLANK      Look for end
         MVC   1(2,R1),=CL2'at'
         MVC   4(8,R1),AUTHNODE-AUTHLIST(R3) Move node name to msg
         TRT   4(9,R1),BLANK           Look for end
         MVC   1(23,R1),=CL23'is no longer authorized'
         LA    R2,24(,R1)              -> end of msg
         LA    R1,WTOTXT               -> start of msg
         SR    R2,R1                   Compute length to display
         FREEMAIN RU,                  Free entry that was removed     x
               LV=AUTHSIZE,                                            x
               A=(3),                                                  x
               SP=1
         LR    R0,R2                   Msg length to R0
         B     SUCCMSG                 Issue success msg
*
AOFF020  EQU   *
         LR    R2,R3                   Copy next entry
         B     AOFF010                 Keep scanning for end
*
AOFF050  EQU   *
         MVC   WTOMSG,WTO              Move WTO model
         MVC   WTOTXT(L'NJE069I),NJE069I
         MVC   WTOTXT+13(8),AUTHUSER   Move auth name to msg
         TRT   WTOTXT+13(9),BLANK       Look for end
         MVC   1(2,R1),=CL2'at'
         MVC   4(8,R1),AUTHNODE        Move link name to msg
         TRT   4(9,R1),BLANK           Look for end
         MVC   1(36,R1),=CL36'was not found in authorization table'
         LA    R0,37(,R1)              -> end of msg
         LA    R1,WTOTXT               -> start of msg
         SR    R0,R1                   Compute length to display
         DROP  R8                      AUTHLIST
         B     SUCCMSG                 Issue success msg
*
*
*-- Get next tokenized length/value pair
*   Entry:  R15 -> Current pair
*   Exit:  CC  =0, R15 unchanged, no more tokens
*          CC ¬=0, R15 -> next pair
*
GETTKN   EQU   *
         LA    R15,L'TOKENS(,R15)      -> next length/token pair
         CLI   0(R15),X'FF'            No length available?
         BNER  R14                     Exit with pair -> R15
         S     R15,=A(L'TOKENS)        Back to previous token
         CLI   *+1,0                   Set CC=0
         BR    R14                     Exit with tkn ptr not changed
*
*-- Get a storage area
*   Entry:  R0 =  length to obtain
*   Exit:   R1 -> new stg area
*
GETSTG   EQU   *
         STM   R14,R15,SV14GT          Save regs
         GETMAIN RU,                   Get requested stg for block     x
               LV=(0),                                                 x
               SP=1                    All configuration elements SP=1
         LM    R14,R15,SV14GT          Reload regs
         BR    R14                     Return with stg addr in R1
*
TKN000   EQU   *
         MVI   NJFL2,0                 Clear tokenization ctl flags
         LR    R5,R1                   Save start of parse position
         LR    R3,R1                   Start position to R3
         BCTR  R15,0                   Make scan length IBM length
         MVC   TOKENS(12*8),TKNINIT    Init receiving fields
         LA    R6,TOKENS               -> token area
*
TKN040   EQU   *
         EX    R15,SCANBL              Look for blank at end of token
*SCANBL  TRT   0(0,R3),BLANK
         BZ    ERR074                  Syntax error
         SR    R1,R3                   Compute token length
         C     R1,=F'8'                Max length of token is 8
         BH    ERR074                  Syntax error
         BCTR  R1,0
         EX    R1,MVTKN                Save the token
*MVTKN   MVC   1(0,R6),0(R3)
         STC   R1,0(,R6)               Save its length
         LA    R6,9(,R6)               -> next token area
         LA    R1,1(,R1)               Restore length relative to 1
         AR    R3,R1                   -> next byte in line
         SR    R15,R1                  Reduce remaining length
         BNPR  R14                     Done with line
*
         EX    R15,SCANNBL             Look for next token
*SCANNBL TRT   0(0,R3),NONBLANK
         BZR   R14                     Nothing else on line
         SR    R1,R3                   Compute length to that token
         AR    R3,R1                   -> next byte in line
         SR    R15,R1                  Reduce remaining length
         BNPR  R14                     Done with line
*
TKN090   EQU   *
         B     TKN040                  Continue scanning
*
SCANBL   TRT   0(0,R3),BLANK           executed instr
SCANNBL  TRT   0(0,R3),NONBLANK        executed instr
MVTKN    MVC   1(0,R6),0(R3)           executed instr
*
EOD000   EQU   *
         B     EXIT00
*
*
ERR043   EQU   *
         LA    R3,1(,R15)              -> failing keyword token
         BAL   R14,CFGERR              Show failing stmt
         MVC   WTOMSG,WTO              Move WTO model
         MVC   WTOTXT(L'NJE042E),NJE042E  Node name invalid chars
         LA    R0,L'NJE042E            Length of msg
         B     ERRTYPE(R7)
*
ERR046   EQU   *
         LA    R3,1(,R15)              -> failing keyword token
         BAL   R14,CFGERR              Show failing stmt
         MVC   WTOMSG,WTO              Move WTO model
         MVC   WTOTXT(L'NJE044E),NJE044E  LINK is not inactive
         MVC   WTOTXT+13(8),LINKID-LINKTABL(R8)  LINK name
         TRT   WTOTXT+13(9),BLANK       Look for end
         MVC   1(15,R1),=CL15'is still active'
         LA    R0,13+16(,R1)           -> end of msg
         LA    R1,WTOTXT               -> start of msg
         SR    R0,R1                   Compute length to display
         B     ERRTYPE(R7)
*
ERR050   EQU   *
         LA    R3,1(,R15)              -> failing keyword token
         BAL   R14,CFGERR              Show failing stmt
         MVC   WTOMSG,WTO              Move WTO model
         MVC   WTOTXT(L'NJE050E),NJE050E  AUTH AT required
         LA    R0,L'NJE050E            Length of msg
         B     ERRTYPE(R7)
*
ERR051   EQU   *
         LA    R3,1(,R15)              -> failing keyword token
         BAL   R14,CFGERR              Show failing stmt
         MVC   WTOMSG,WTO              Move WTO model
         MVC   WTOTXT(L'NJE051E),NJE051E  ROUTE TO required
         LA    R0,L'NJE051E            Length of msg
         B     ERRTYPE(R7)
*
ERR052   EQU   *
         LA    R3,1(,R15)              -> failing keyword token
         BAL   R14,CFGERR              Show failing stmt
         MVC   WTOMSG,WTO              Move WTO model
         MVC   WTOTXT(L'NJE052E),NJE052E  More than one LOCAL stmt
         LA    R0,L'NJE052E            Length of msg
         B     ERRTYPE(R7)
*
ERR053   EQU   *
         LA    R3,1(,R15)              -> failing keyword token
         BAL   R14,CFGERR              Show failing stmt
         MVC   WTOMSG,WTO              Move WTO model
         MVC   WTOTXT(L'NJE053E),NJE053E  No LOCAL stmt
         LA    R0,L'NJE053E            Length of msg
         B     ERRTYPE(R7)
*
ERR054   EQU   *
         S     R15,=A(L'TOKENS)        Back to previous token
         LA    R3,1(,R15)              -> failing keyword token
         BAL   R14,CFGERR              Show failing stmt
         MVC   WTOMSG,WTO              Move WTO model
         MVC   WTOTXT(L'NJE054E),NJE054E  invalid BUFF value
         LA    R0,L'NJE054E            Length of msg
         B     ERRTYPE(R7)
*
ERR055   EQU   *
         LA    R3,1(,R15)              -> failing keyword token
         BAL   R14,CFGERR              Show failing stmt
         MVC   WTOMSG,WTO              Move WTO model
         MVC   WTOTXT(L'NJE055E),NJE055E  invalid value after keywd
         MVC   WTOTXT+29(8),0(R3)      Show failed keyword
         LA    R0,L'NJE055E            Length of msg
         B     ERRTYPE(R7)
*
ERR073   EQU   *
         BAL   R14,CFGERR              Show failing stmt
         MVC   WTOMSG,WTO              Move WTO model
         MVC   WTOTXT(L'NJE073E),NJE073E  keywd not in col 1
         LA    R0,L'NJE073E            Length of msg
         B     ERRTYPE(R7)
*
ERR074   EQU   *
         BAL   R14,CFGERR              Show failing stmt
         MVC   WTOMSG,WTO              Move WTO model
         MVC   WTOTXT(L'NJE074E),NJE074E  syntax error
         SR    R3,R5                   Compute column number
         LA    R3,1(,R3)               Make rel to 1
         CVD   R3,DBLE
         UNPK  WTOTXT+53(2),DBLE
         OI    WTOTXT+54,X'F0'         Fix sign
         LA    R0,L'NJE074E            Length of msg
         B     ERRTYPE(R7)
*
ERR075   EQU   *
         LA    R3,1(,R15)              -> failing keyword token
         BAL   R14,CFGERR              Show failing stmt
         MVC   WTOMSG,WTO              Move WTO model
         MVC   WTOTXT(L'NJE075E),NJE075E  syntax error
         MVC   WTOTXT+36(8),0(R3)      Show failed keyword
         LA    R0,L'NJE075E            Length of msg
         B     ERRTYPE(R7)
*
ERR076   EQU   *
         BAL   R14,CFGERR              Show failing stmt
         MVC   WTOMSG,WTO              Move WTO model
         MVC   WTOTXT(L'NJE076E),NJE076E  unknown config stmt type
         LA    R0,L'NJE076E            Length of msg
         B     ERRTYPE(R7)
*
ERR077   EQU   *
         BAL   R14,CFGERR              Show failing stmt
         MVC   WTOMSG,WTO              Move WTO model
         MVC   WTOTXT(L'NJE077E),NJE077E  line addr required
         LA    R0,L'NJE077E            Length of msg
         B     ERRTYPE(R7)
*
ERR078   EQU   *
         S     R15,=A(L'TOKENS)        Back to previous token
         LA    R3,1(,R15)              -> failing keyword token
         BAL   R14,CFGERR              Show failing stmt
         MVC   WTOMSG,WTO              Move WTO model
         MVC   WTOTXT(L'NJE078E),NJE078E  invalid value after keywd
         MVC   WTOTXT+46(8),0(R3)      Show failed keyword
         LA    R0,L'NJE078E+8          Length of msg
         B     ERRTYPE(R7)
*
ERRTYPE  EQU   *                       R7 branch table index
         B     ERRWTO               00 Issue WTO to console
         B     ERRMSG               04 Return msg len/text to caller
*
ERRWTO   EQU   *
         WTO   ,MF=(E,WTOMSG)
         B     EXIT08
*
ERRMSG   EQU   *
         L     R1,AMTEXT               -> callers MTEXT area
         MVC   0(120,R1),WTOTXT        Pass back the msg text
         B     EXIT08                  and exit to caller with error
*
SUCCMSG  EQU   *
         L     R1,AMTEXT               -> callers MTEXT area
         MVC   0(120,R1),WTOTXT        Pass back the msg text
         B     EXIT00                  and exit to caller with success
*
CFGERR   EQU   *
         LTR   R7,R7                   Processing CONFIG member?
         BNZR  R14                     No; skip config msgs
         ST    R14,SV14CF              Save return
         MVC   WTOMSG,WTO              Move WTO model
         MVC   WTOTXT(L'NJE072E),NJE072E
         CVD   R9,DBLE                 convert record #
         MVC   WTOTXT+45(3),=X'202120' Move edit mask
         ED    WTOTXT+44(4),DBLE+6     Edit record number
         WTO   ,MF=(E,WTOMSG)
         MVC   WTOMSG,WTO              Move WTO model
         MVC   WTOTXT(7),NJE072E       Move just msg number
         MVI   WTOTXT+8,C''''          Move apost
         MVC   WTOTXT+09(52),REC       Move first part of record image
         MVI   WTOTXT+61,C''''         Move apost
         WTO   ,MF=(E,WTOMSG)
         L     R14,SV14CF              Load return
         BR    R14
*
EXIT08   EQU   *
         LR    R6,R0                   Msg length to R6 for now
         LA    R5,8                    RC=8
         B     XIT000
*
EXIT00   EQU   *
         LR    R6,R0                   Possible msg len to R6 for now
         SR    R5,R5                   RC=0
*                                                                       NJE00200
XIT000   EQU   *                                                        NJE00210
         TM    NJFL1,F1OPEN            Is DCB open?
         BZ    XIT010                  No
         MVC   MACLIST(CLOSEL),CLOSE   Move macro model
         CLOSE (CONFIG),                                               x
               MF=(E,MACLIST)
         FREEPOOL CONFIG
*
XIT010   EQU   *
*
XIT090   EQU   *
         LR    R1,R10                  -> NJEWK main work area page
         L     R13,4(,R13)             -> caller's sa                   NJE00210
         STM   R5,R6,16(R13)           Set RC, msg len in SA R15, R0
*
         FREEMAIN RU,                                                  x
               LV=NJEWKSZ,                                             x
               A=(1)
         LM    R14,R12,12(R13)         Reload system's regs             NJE00220
         BR    R14                     Return                           NJE00240
         DROP  R12
         LTORG ,
*
DMYDCB   DCB   DDNAME=CONFIG,                                          x
               MACRF=GM,                                               x
               DSORG=PS,                                               x
               LRECL=80,                                               x
               RECFM=FB,                                               x
               EODAD=EOD000
DMYDCBL  EQU   *-DMYDCB
*
*               1234567890123456789012345678901234567890123456789012345
WTO      WTO   '                                                       x
                                                                       x
                        ',MF=L
*              67890123456789012345678901234567890123456789012345678901
WTOL     EQU   *-WTO
*
*
         DS    0D
BLANKS   DC    CL120' '
NONBLANK DC    64X'FF',X'00'           TR Table to locate nonblank
INVALHEX DC    193X'FF'                TR table to locate invalid hex
         DC    6X'00'     A-F
         DC    41X'FF'
         DC    10X'00'    0-9
         DC    6X'FF'
BLANK    DC    64X'00',X'FF',191X'00'  TR Table to locate blanks
*
ASTER    DC    256AL1(*-ASTER)         TR table to set asterisk high
         ORG   ASTER+C'*'               Set * high, only
         DC    X'FF'
         ORG   ,
*
HEXTRAN  DC    CL16'0123456789ABCDEF'  Translate table
*                 0 1 2 3 4 5 6 7 8 9 A B C D E F
TRANHEX  DC    X'00FAFBFCFDFEFF000000000000000000' C
         DC    X'00000000000000000000000000000000' D
         DC    X'00000000000000000000000000000000' E
         DC    X'F0F1F2F3F4F5F6F7F8F9000000000000' F
*
*                 0 1 2 3 4 5 6 7 8 9 A B C D E F
VALDNAME DC    X'FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' 0 Invalid node name
         DC    X'FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' 1 characters
         DC    X'FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' 2
         DC    X'FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' 3
         DC    X'00FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' 4  Blank=ok/delim
         DC    X'FFFFFFFFFFFFFFFFFFFFFFFF5CFFFFFF' 5  * indicator
         DC    X'FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' 6
         DC    X'FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' 7
         DC    X'FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' 8
         DC    X'FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' 9
         DC    X'FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' A
         DC    X'FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' B  valid =
         DC    X'FF000000000000000000FFFFFFFFFFFF' C  C1-C9
         DC    X'FF000000000000000000FFFFFFFFFFFF' D  D1-D9
         DC    X'FFFF0000000000000000FFFFFFFFFFFF' E  E2-E9
         DC    X'00000000000000000000FFFFFFFFFFFF' F  F0-F9
*
OPEN     OPEN  0,MF=L
OPENL    EQU   *-OPEN
CLOSE    CLOSE 0,MF=L
CLOSEL   EQU   *-CLOSE
RDJFCB   RDJFCB 0,MF=L
RDJFCBL  EQU   *-RDJFCB
*
DEFUSER  DC    CL8'HERC01'         Default userid for LOCAL
*
TKNINIT  DC    12X'FF4040404040404040'  byte 0=IBM len, bytes 1-8 blank
*                          1         2         3         4         5    NJE00250
*                01234567890123456789012345678901234567890123456789012
NJE042E  DC    C'NJE042E Node names must contain A-Z, 0-9 only'
NJE044E  DC    C'NJE044E Link ' is not inactive'
NJE045I  DC    C'NJE045I Link ' is not defined
NJE046I  DC    C'NJE046I Link ' xxx deleted
NJE048E  DC    C'NJE048I Link ' xxx duplicate definition
NJE049I  DC    C'NJE049I Using configuration '
NJE050E  DC    C'NJE050E ''AT'' keyword is required with AUTH'
NJE051E  DC    C'NJE051E ''TO'' keyword is required with ROUTE'
NJE052E  DC    C'NJE052E Only one LOCAL statement allowed'
NJE053E  DC    C'NJE053E LOCAL statement must preceed LINK, ROUTE, or A*
               UTH'
NJE054E  DC    C'NJE054E Invalid BUFF value; range is 300 to 4020'
NJE055E  DC    C'NJE055E Unrecognized keyword x'
NJE063I  DC    C'NJE063I Node xxxxxxxx ' is not routed
NJE064I  DC    C'NJE064I Route for node ' xxxxxxxx deleted
NJE065I  DC    C'NJE065I Node xxxxxxxx ' routed through link xxxx
NJE066I  DC    C'NJE066I Link '     xxx defined'
NJE067I  DC    C'NJE067I User '     xxx at yyy is already authorized'
NJE068I  DC    C'NJE068I User '     xxx at yyy is now authorized
NJE069I  DC    C'NJE069I User '     xxx at yyy not in authorization lst
NJE070I  DC    C'NJE070I User '     xxx at yyy removed from auth list
NJE072E  DC    C'NJE072E Configuration syntax error in record xxx'
NJE073E  DC    C'NJE073E Keyword is not in column 1'
NJE074E  DC    C'NJE074E Syntax, keyword, or value error after column x*
               x'
NJE075E  DC    C'NJE075E Missing value after keyword x'
NJE076E  DC    C'NJE076E Unrecognized configuration statement type'
NJE077E  DC    C'NJE077E LINE address required on LINK statement'
NJE078E  DC    C'NJE078E Invalid/incorrect value after keyword x'
*                                                                       NJE00930
* NJE043E                                                               NJE00930
* NJE047E                                                               NJE00930
* NJE056I                                                               NJE00930
* NJE057I                                                               NJE00930
* NJE058I                                                               NJE00930
* NJE059I all NJECMX msgs                                               NJE00930
* NJE060I                                                               NJE00930
* NJE061I                                                               NJE00930
* NJE062I                                                               NJE00930
* NJE071I                                                               NJE00930
*                                                                       NJE00930
         COPY  LINKTABL                                                 NJE00940
         COPY  RTE                                                      NJE00940
         COPY  AUTHLIST                                                 NJE00940
         COPY  NETSPOOL                                                 NJE00940
*
****  Main work area                                                    NJE00290
*                                                                       NJE00290
NJEWK    DSECT
NJEEYE   DS    CL4'NJES'           Eyecatcher
NJEWKLEN DS    F                   Getmain size of this area
*
DBLE     DS    D                   Work area                            NJE00310
TWRK     DS    2D                  Work area
MACLIST  DS    XL64                Macro expansion area
REC      DS    CL120               Input record or command area
TOKENS   DS    12CL9               Parsed keyword tokens (1 len,8 tkn)
*
         NJEPARMS                  Passed parameter list           v220
*
*
INITPLST DS    A                   -> entry parm list in R1
AMTEXT   DS    A                   -> MTEXT field in NJECMX
SV14CF   DS    A                   R14 save
SV14GT   DS    A,A                 R14-15 save
*
NJFL1    DS    X                   Flag bits
F1OPEN   EQU   X'80'   1... ....    CONFIG DCB is open
*
NJFL2    DS    X                   token scan and ctl flags
F2LINE   EQU   X'80'   1... ....    LINE keyword found
F2RTO    EQU   X'40'   .1.. ....    ROUTE TO keyword found
F2AAT    EQU   X'20'   ..1. ....    AUTH AT keyword found
*
         DS    0F
EXLST    DS    A                   X'87'+AL3(JFCBL)
JFCBL    DS    XL176
CONFIG   DS    XL(DMYDCBL)         CONFIG DCB
WTOMSG   DS    0XL(WTOL)           WTO header
         DS    F                   Header area
WTOTXT   DS    XL(WTOL-4)          WTO text area
*
BLDBUF   DS    XL(LINKLEN)         Build area for LINK,RTE,AUTH entries
*
NJESA    DS    18F                 NJESCN OS save area                  NJE00300
BALRSAVE DS    16F                 Local rtns register save             NJE00300
*
         DS    0D                  Force doubleword size
NJEWKSZ  EQU   *-NJEWK
*
         DCBD  DSORG=PS,DEVD=DA
JFCB     DSECT
         IEFJFCBN LIST=YES
*
         END   NJESCN                                                   NJE01000
./ ADD NAME=NJESPOOL
*
*
*-- NJE38 - "Spool" Services
*
*
*   Called by NJEINIT and NJEDRV for spool-like services
*
*
*
* Change log:
*
* 23 Jul 20 - Make CONTENTS return spool full percentage           v200
* 21 Jul 20 - Only part of record buffer area was FREEMAINed       v200
* 01 Jun 20 - Exclusive control error because ENDREQ not issued    v130
*              on CONTENTS function against an empty spool.        v130
* 21 May 20 - Add update directory entry functionality             v120
* 08 May 20 - RC 12 errors need error addr in NCBMACAD             v110
*
*
* NJESPOOL - Provide a spooling mechanism "access method" for use by
*            NJE38 to hold data files queued for transmission, or to
*            hold data files that have been received via transmission
*            but not yet retrieved by the destination user.
*
* The main goal of NJESPOOL is to provide a simple way to read and
* write files by the NJE line driver without the line driver having
* to know the vagaries of i/o, record formats, directories, and so on.
* NJESPOOL does the heavier lifting and spool management under the
* covers and unknown to the line driver.
*
* The spool dataset, "NETSPOOL", is a VSAM RRDS-type dataset.  All
* blocks in the dataset are one control interval in size.  The CI size
* must be 4096, which gives a usable record size of 4089 bytes.  The
* NETSPOOL internal format is based on these sizes.
*
* NETSPOOL contains a directory which describes the data files
* present within.  There are two directories; one is the current
* directory which describes the true state of NETSPOOL, the other is
* the current-minus-1 diectory, which is the state of NETSPOOL just
* prior to the very last directory update.  When new data files are
* added or removed from NETSPOOL, the current directory is copied onto
* current-minus-1 and then the addition or deletion is applied.  This
* then becomes the current directory and the directory that was most
* recently current becomes current-minus-1.  Thus the directories
* alternate back and forth.  The first block of each directory are
* blocks 2 and 3, respectively.  If the directory size expands to
* additional blocks, they can be anywhere in the dataset, but the
* very first block of either directory is ALWAYS 2 or 3.
*
* Block #1 contains a fullword pointer that contains the block number
* of whichever directory is current.  Thus, it will contain a 2 or 3.
* Alternating directories ensures that in the event of a failure while
* adding or deleting a data file, the changes do not clobber the
* current directory.  Only when those updates complete successfully
* is the block 1 pointer to the new current directory updated.
*
*
* The format of the NETSPOOL dataset is very simple.
*  Block 1    - contains the block # of the current directory block and
*               a few other items.
*  Blocks 2-3 - contain the 1st directory block for the current
*               and current-minus-1 directories.
*  Blocks 4-7 - contains the free space bit map.
*  Blocks 8-n - data blocks available for data files or directory blks.
*
* The free space bitmap is simply a 4-block long (4089 * 4 = 16356
* bytes) string of bits that represent whether a given CI in the
* dataset is used or available.  Upon initial formatting, the blocks
* 1-7 are marked as used.  The rest of the data blocks are free until
* the last block number that is physically present in the VSAM RRDS
* dataset.  The maximum number of blocks supported by this scheme is
* 130,848.  This is 873 cylinders of 3380 DASD space, for example.
* For VSAM RRDS NETSPOOL sizes of fewer cylinders, blocks higher than
* the highest available physical block number are marked as used out
* to the end of the bitmap so they will never be allocated.
*
*
* ACCESSING NETSPOOL VIA PROGRAMMING
*
* You may access the NETSPOOL dataset via programming the same way
* that the NJE line driver and NJE38 utilities do:  via a NETSPOOL
* CONTROL BLOCK (NCB) and the NSIO macro.
*
* The NCB is a small control block that is something akin to a VSAM
* RPL.  It simply contains information about the file being read or
* written and contains pointers to the user buffer, and file
* attributes.
*
* The NSIO macro is used to open or close the NETSPOOL dataset.  It is
* also used to read or write data records, and obtain directory
* information.
*
* The NCB and the NSIO macro are used together and provide the
* functions for spool access:
*
*  NSIO  TYPE=OPEN      - Opens the NETSPOOL dataset for i/o
*             CLOSE     - Closes NETSPOOL and updates directory
*             PUT       - Writes a single record to the spool
*             GET       - Reads a single record from the spool
*             PURGE     - Deletes a data file from the spool
*             FIND      - Locates a data file by file number
*             CONTENTS  - Returns the current directory contents
*             UDIR      - Update a directory entry                 v120
*
*  All NSIO macros must specify the NCB that it is associated with.
*  The spool is not opened for "input" or for "output" in the
*  traditional sense.  Rather, the first TYPE=GET or TYPE=PUT
*  issued establishes the mode.  Once the mode is established you
*  may not change from PUT to GET, or GET to PUT, without first
*  closing the spool and re-opening.  The PURGE, FIND, and CONTENTS
*  functions do not establish any mode, and can be used any time
*  the spool is open.
*
*  If you need to open the spool file by two or more tasks or modes
*  simultaneously, use multiple NCBs.
*
*  VSAM errors are returned via the NCBRTNCD and NCBERRCD fields which
*  are analagous to the VSAM RPLRTNCD and RPLERRCD fields. If an
*  actual VSAM error occurs, NCBRTNCD will be set to 8 and the NCBERRCD
*  field contains the actual VSAM RPLERRCD value.  If NCBRTNCD is 12,
*  the error code value is an internal value used by NJESPOOL.  These
*  are:
*
*  NCBRTNCD=X'0C'  Internal NJESPOOL error
*  NCBERRCD=X'01'  Invalid function code (not open, close, get, etc).
*           X'02'  VSAM RRDS ACB is not open
*           X'03'  NETSPOOL dataset is full
*           X'04'  File # not found in directory (TYPE=FIND/PURGE)
*           X'05'  GET attempted in PUT mode, or,
*                    PUT attempted in GET mode
*           X'06'  No files in directory  (TYPE=CONTENTS)
*
* Refer to the utilities NJ38XMIT and NJ38RECV for examples using
* NCB and NSIO to access the spool.
*
         PRINT GEN                                                      NJE00030
         REGEQU                        REGISTER EQUATES                 NJE00040
*
* NETSPOOL Internal values
*
ALLOCBLK EQU   4                       Starting BLK# of allocation map
ALLOCNUM EQU   4                       Number of allocation map blocks
*
*
NJESPOOL CSECT                                                          NJE00020
         NJEVER
         STM   R14,R12,12(R13)         SAVE CMS REGS                    NJE00050
         LR    R12,R15                 BASE                             NJE00060
         USING NJESPOOL,R12            ADDRESS IT                       NJE00070
         LTR   R9,R1                   NCB ptr to R9
         BZ    EXIT16                  Exit if no ptr
         USING NCB,R9
         CLC   NCBEYE,=CL4'NCB'        Is it an NCB?
         BNE   EXIT16                  Exit if not
         XC    NCBRTNCD(2),NCBRTNCD    Clear prior error codes
         CLI   NCBREQ,NCBOPEN          Is this an OPEN function?
         BE    INIT000                 Yes, ignore token
         L     R10,NCBTKN              Get caller token
         CLC   0(4,R10),=CL4'NSPL'     Token point to NSPL work area?
         BE    INIT010                 Yes, looks good
         B     EXIT16                  Exit if token invalid
*
*
INIT000  EQU   *
         GETMAIN RU,                   Get local stg area              X
               LV=4096,                                                X
               BNDRY=PAGE
         LR    R10,R1
         ST    R10,NCBTKN              Set area addr as token
         LR    R1,R0                   Copy length
         LR    R2,R0                   Copy length
         LR    R0,R10                  -> new stg area
         SR    R15,R15                 set pad
         MVCL  R0,R14                  Clear the page
*
         USING NJEWK,R10
         MVC   NJEEYE,=CL4'NSPL'       Work area eyecatcher
         ST    R2,NJEWKLEN             Save size of area in area
*
INIT010  EQU   *
         USING NJEWK,R10
         ST    R13,NJESA+4             SAVE prv S.A. ADDR               NJE00080
         LA    R1,NJESA                -> my save area
         ST    R1,8(,R13)              Plug it into prior SA
         LR    R13,R1
*
         L     R11,=A(NJECMN)          -> common csect
         ST    R11,ANJECMN             Save addr
         USING NJECMN,R11
*
*
INIT100  EQU   *
         LA    R14,*                   -> location of error source v110
         SR    R1,R1                   Clear for IC
         IC    R1,NCBREQ               Get request type
         SLL   R1,2                    Multiply by 4 to make index
         C     R1,=A(INIT120-INIT110)  Size of branch table
         BH    ERR1201                 Exit if req type invalid
         B     INIT110(R1)             Branch to requested function
*
INIT110  B     ERR1201              00 Invalid function
         B     OPN000               01 Open NETSPOOL dataset
         B     CLS000               02 Close NETSPOOL dataset
         B     PUT000               03 Write a logical record
         B     GET000               04 Read a logical record
         B     PUR000               05 Purge a file from NETSPOOL
         B     FID000               06 Locate a file by file id
         B     CON000               07 Get a list of files in NETSPOOL
         B     UDR000               08 Update directory entry      v120
*
INIT120  EQU   *                       Must mark end of branch table
*
*                                                                       NJE00920
********************                                                    NJE00920
*                  *                                                    NJE00920
*  OPEN DATASET    *                                                    NJE00920
*  NCBREQ = X'01'  *                                                    NJE00920
*                  *                                                    NJE00920
********************                                                    NJE00920
*                                                                       NJE00920
*
*- Get storage for NETSPOOL block
*
OPN000   EQU   *
         GETMAIN RU,                   Get stg for NETSPOOL blocks     X
               LV=3*4096,                                              X
               BNDRY=PAGE
         ST    R1,BLOCK                This is the VSAM AREA
         LR    R3,R1                   R3 for now
         LA    R2,4089(,R1)            -> end of BLOCK record size
         ST    R2,BLOCKEND             Save it
         A     R1,=F'4096'             -> 2nd page
         ST    R1,PTRBUF               This is an internal rec'd buffer
         ST    R1,PTRPOS               Save also as internal write pos
         LA    R2,4084(,R1)            -> end of ptr part of PTRBUF
         ST    R2,PTRBUFEN             Save it (bytes 4084-4089 special
         A     R1,=F'4096'             -> 2nd page
         ST    R1,BUFF                 This is an internal rec'd buffer
         ST    R1,PUTPOS               Save also as internal write pos
         LA    R1,4089(,R1)            -> end of BUFF record size
         ST    R1,BUFFEND              Save it
         XC    PTRBLK,PTRBLK           Initialize
         XC    NEWBLK,NEWBLK           Initialize
         XC    PUTCNT,PUTCNT           Initialize (to be placed in TAG)
         XC    GETCNT,GETCNT           Initialize (only used for debug)
*
         GENCB BLK=ACB,                                                x
               DDNAME=NETSPOOL,                                        x
               MACRF=(OUT,KEY,DIR),                                    x
               MF=(G,MACLIST)
         STM   R0,R1,ACBL              Save len, addr
*
         LA    R4,KEY                  -> block number argument
         GENCB BLK=RPL,                                                x
               ACB=(*,ACB),                                            x
               AREA=(R3),              -> block area                   x
               AREALEN=4089,                                           x
               RECLEN=4089,                                            x
               ARG=(R4),                                               x
               OPTCD=(KEY,DIR,MVE,UPD),                                x
               MF=(G,MACLIST)
         STM   R0,R1,RPLL              Save len, addr
*
         BAL   R14,ENQ000              Get exclusive control
*
         L     R7,ACB                  -> ACB
         MVC   MACLIST(OPENL),OPEN     Move macro model
         OPEN  ((R7)),                 Open NETSPOOL                   x
               MF=(E,MACLIST)
*
         BAL   R14,CHKOC               Check open/close result
         BNZ   EXIT08                  Exit with VSAM error
         OI    NJFL1,NJF1OACB          Indic ACB open
*
*-- Get NETSPOOL directory block ptr from block 1; determine if
*-- NETSPOOL has been formatted.
*
OPN040   EQU   *
         MVC   KEY,=F'1'
         L     R7,RPL
         GET   RPL=(R7)
         BAL   R14,CHKRPL              Check RPL result
         BNZ   EXIT08                  Exit with VSAM error
*
         ENDREQ RPL=(R7)               Cancel the update request
         BAL   R14,CHKRPL              Check RPL result
         BNZ   EXIT08                  Exit with VSAM error
*
         BAL   R14,DEQ000              Release control
         B     EXIT00                  Otherwise OPEN is complete
*                                                                       NJE00920
*                                                                       NJE00920
********************                                                    NJE00920
*                  *                                                    NJE00920
*  CLOSE DATASET   *                                                    NJE00920
*  NCBREQ = X'02'  *                                                    NJE00920
*                  *                                                    NJE00920
********************                                                    NJE00920
*                                                                       NJE00920
CLS000   EQU   *
         SR    R5,R5                   Clear possible RC
         TM    NJFL1,NJF1OACB          Is ACB open?
         BZ    CLS090                  No
         BAL   R14,ENQ000              Get exclusive control
*
         TM    NJFL1,NJF1PUT           Processing PUTs against file?
         BZ    CLS050                  N, skip close related PUT funcs.
*
         CLC   NCBTAG,=A(0)            Is tag data present?
         BE    CLS050                  0, Cant write a directory
*
         TM    NJFL1,NJF1WPND          Is physical write pending?
         BZ    CLS030                  No
         NI    NJFL1,255-NJF1WPND      No physical write pending
*
         MVC   KEY,NEWBLK              Prep for update of blk to write
         L     R7,RPL                  -> RPL
         GET   RPL=(R7)                Get the block for update
         BAL   R14,CHKRPL              Deal with errors
         BNZ   EXIT08                  Exit with VSAM error
*
         L     R3,PUTPOS               -> logical record position
         LA    R3,2(,R3)               Account for FFFF EOF marker
         L     R0,BLOCK                -> VSAM i/o area
         LA    R1,4089                 Size of physical block
         L     R2,BUFF                 -> buffer to write out
         SR    R3,R2                   Compute length to write out
         MVCL  R0,R2                   Move data and pad remaining
*
         PUT   RPL=(R7)                Update the physical block
         BAL   R14,CHKRPL              Deal with errors
         BNZ   EXIT08                  Exit with VSAM error
*
*
CLS030   EQU   *
         NC    PTRBLK,PTRBLK           Is ptr block write pending?
         BZ    CLS040
         MVC   KEY,PTRBLK              Prep for update of blk to write
         XC    PTRBLK,PTRBLK           Clear block number for recursion
         OI    NJFL1,NJF1DPND          Indic directory add pending
*
         L     R7,RPL                  -> RPL
         GET   RPL=(R7)                Get the block for update
         BAL   R14,CHKRPL              Deal with errors
         BNZ   EXIT08                  Exit with VSAM error
*
         L     R3,PTRPOS               -> ptr record position
         L     R0,BLOCK                -> VSAM i/o area
         LA    R1,4089                 Size of physical block
         L     R2,PTRBUF               -> buffer to write out
         SR    R3,R2                   Compute length to write out
         MVCL  R0,R2                   Move data and pad remaining
*
         PUT   RPL=(R7)                Update the physical block
         BAL   R14,CHKRPL              Deal with errors
         BNZ   EXIT08                  Exit with VSAM error
*
*
CLS040   EQU   *
         TM    NJFL1,NJF1DPND          Directory add pending?
         BZ    CLS050                  No
         NI    NJFL1,255-NJF1DPND      Remove directory add pending
*
         L     R1,NCBTAG               -> tag data
         USING TAG,R1
         MVC   TAGRECNM,PUTCNT         Save # records actually written
         DROP  R1
*
         LA    R0,DIRADD               Add directory entry function
         L     R15,=A(NJEDIR)          Call directory mgmt
         BALR  R14,R15                 File to add is in NCB
         LR    R5,R15                  Any RC to R5
*
CLS050   EQU   *
         L     R7,ACB                  -> ACB
         MVC   MACLIST(CLOSEL),CLOSE   Move close list
         CLOSE ((R7)),                 Close the ACB                   x
               MF=(E,MACLIST)
*
         NI    NJFL1,255-NJF1OACB      ACB now closed
         BAL   R14,DEQ000              Release control
*
CLS090   EQU   *
         L     R1,BLOCK                -> NETSPOOL record areas
         FREEMAIN RU,LV=3*4096,A=(1)   Release it                  v200
*
         LM    R0,R1,RPLL
         FREEMAIN RU,LV=(0),A=(1)
*
         LM    R0,R1,ACBL
         FREEMAIN RU,LV=(0),A=(1)
*
         XC    NCBTKN,NCBTKN           Clear token
         B     QUIT000                 Exit with RC in R5
*                                                                       NJE00920
*                                                                       NJE00920
********************                                                    NJE00920
*                  *   Write a logical record (not a physical block)    NJE00920
*  PUT             *                                                    NJE00920
*  NCBREQ = X'03'  *   No ENQ is required when writing the physical     NJE00920
*                  *   blocks as these blocks are allocated exclusively NJE00920
********************   to the calling task.                             NJE00920
*                                                                       NJE00920
PUT000   EQU   *
         LA    R14,*                   -> location of error source v110
         TM    NJFL1,NJF1OACB          Is ACB open?
         BZ    ERR1202                 No
         TM    NJFL1,NJF1GET           Processing GETs against file?
         BO    ERR1205                 Yes, cant do PUT now
         OI    NJFL1,NJF1PUT           Indicate PUT in progress
*
         NC    PTRBLK,PTRBLK           Do we have a ptr block?
         BNZ   PUT020                  Yes
         BAL   R14,GETBLK              Allocate a new physical block
         BNZ   EXIT08                  Exit with VSAM error
         LTR   R0,R0                   Is there a block number?
         BZ    ERR1203                 NETSPOOL dataset full
         ST    R0,PTRBLK               Save block number of ptr blk
         ST    R0,INITBLK              Save first block # used in PUT
         L     R0,PTRBUF               -> ptr block area
         LA    R1,4089                 Size of physical block
         LR    R3,R1                   Compute length to write out
         MVCL  R0,R2                   Clear the ptr block
         MVC   PTRPOS,PTRBUF           Set write position in block
*
         BAL   R14,GETBLK              Allocate a new physical block
         BNZ   EXIT08                  Exit with VSAM error
         LTR   R0,R0                   Is there a block number?
         BZ    ERR1203                 NETSPOOL dataset full
         ST    R0,NEWBLK               Save allocated blk #
         MVC   PUTPOS,BUFF             Set write position in block
         L     R1,PTRPOS               Get current ptr block position
         ST    R0,0(,R1)               Save new blk# in ptr block
         LA    R1,4(,R1)               Next ptr block slot
         ST    R1,PTRPOS               Update position
*
PUT020   EQU   *
         L     R3,PUTPOS               Get current position
         L     R1,BUFFEND              -> end of buffer
         SR    R1,R3                   Determine remaining space in blk
         LH    R4,NCBRECLN             Get size of record to write
         LA    R2,2+2(,R4)             Add in overhead
*                                       +2 for length halfword
*                                       +2 for next block marker
         CR    R1,R2                   Is there room to add record?
         BL    PUT100                  No, better get another block
*
         L     R15,NCBAREA              -> to logical record
         BCT   R4,*+10                 Adjust len for execute
PUTREC   MVC   2(0,R3),0(R15)
         EX    R4,PUTREC               Move record to block
         LA    R4,1+2(,R4)             Get record len + overhead
*                                       +1 to get back true length
*                                       +2 for length halfword itself
         STCM  R4,3,0(R3)              Store the length
*
         TM    NCBFL1,NCBPUN           Is this PUN type data?
         BO    PUT050                  Y, no special action
         TM    2(R3),X'03'             Is carriage ctl an immediate?
         BO    PUT060                  Y, Don't count these records
*
PUT050   EQU   *
         L     R1,PUTCNT               Get count of records written
         LA    R1,1(,R1)               Bump it
         ST    R1,PUTCNT               Update count
*
PUT060   EQU   *
         AR    R3,R4                   Compute next avail byte in blk
         MVC   0(2,R3),=X'FFFF'        Set current EOF marker in case
*                                       we write no more records
         ST    R3,PUTPOS               Save write position for next
*                                       record; would overwrite the
*                                       FFFF marker on next PUT.
         OI    NJFL1,NJF1WPND          Indicate physical write req'd
         B     EXIT00
*
PUT100   EQU   *
         L     R5,NEWBLK               Get current blk # we need to wrt
         BAL   R14,GETBLK              Allocate a new physical block
         BNZ   EXIT08                  Exit with VSAM error
         LTR   R0,R0                   Is there a block number?
         BZ    ERR1203                 NETSPOOL dataset full
         ST    R0,NEWBLK               Save newly allocated blk #
         MVC   0(2,R3),=X'FFFE'        Insert ptr indic for next blk
         LA    R3,2(,R3)               -> next write position
*
         ST    R5,KEY                  Prep for update of blk to write
         L     R7,RPL                  -> RPL
         GET   RPL=(R7)                Get the block for update
         BAL   R14,CHKRPL              Deal with errors
         BNZ   EXIT08                  Exit with VSAM error
*
         L     R0,BLOCK                -> VSAM i/o area
         LA    R1,4089                 Size of physical block
         L     R2,BUFF                 -> buffer to write out
         SR    R3,R2                   Compute length to write out
         MVCL  R0,R2                   Move data and pad remaining
*
         PUT   RPL=(R7)                Update the physical block
         BAL   R14,CHKRPL              Deal with errors
         BNZ   EXIT08                  Exit with VSAM error
*
         MVC   PUTPOS,BUFF             Reset write position in new blk
         NI    NJFL1,255-NJF1WPND      No physical write pending
*
*-- Now ensure newly allocated block is also pointed to by ptr block
*
         L     R3,PTRPOS               Get current ptr block position
         MVC   0(4,R3),NEWBLK          Save new blk# in ptr block
         LA    R3,4(,R3)               Next ptr block slot
         C     R3,PTRBUFEN             Is ptr block full?
         BNL   PUT200                  Yes
         ST    R3,PTRPOS               Update position
         B     PUT020                  Now retry to add next logical
*
*-- Here if we need another ptr block  (chain them together)
*
PUT200   EQU   *
         L     R5,PTRBLK               Get current blk # we need to wrt
         BAL   R14,GETBLK              Allocate a new phys ptr block
         BNZ   EXIT08                  Exit with VSAM error
         LTR   R0,R0                   Is there a block number?
         BZ    ERR1203                 NETSPOOL dataset full
         ST    R0,PTRBLK               Save newly allocated blk #
         ST    R0,0(,R3)               Insert ptr to next ptr blk in
*                                       full ptr block
         MVI   0(R3),X'FE'             Indic "ptr to next ptr blk" and
*                                       not ptr to a data block
         LA    R3,4(,R3)               -> next write position
*
         ST    R5,KEY                  Prep for update of blk to write
         L     R7,RPL                  -> RPL
         GET   RPL=(R7)                Get the block for update
         BAL   R14,CHKRPL              Deal with errors
         BNZ   EXIT08                  Exit with VSAM error
*
         L     R0,BLOCK                -> VSAM i/o area
         LA    R1,4089                 Size of physical block
         L     R2,PTRBUF               -> buffer to write out
         SR    R3,R2                   Compute length to write out
         MVCL  R0,R2                   Move data and pad remaining
*
         PUT   RPL=(R7)                Update the physical block
         BAL   R14,CHKRPL              Deal with errors
         BNZ   EXIT08                  Exit with VSAM error
*
         L     R0,PTRBUF               -> ptr block area
         LA    R1,4089                 Size of physical block
         LR    R3,R1                   Compute length to write out
         MVCL  R0,R2                   Clear the ptr block
         MVC   PTRPOS,PTRBUF           Reset ptr position in new blk
         B     PUT020                  Now retry to add next logical
*                                                                       NJE00200
*
*                                                                       NJE00920
********************                                                    NJE00920
*                  *   Read a logical record (not a physical block)     NJE00920
*  GET             *                                                    NJE00920
*  NCBREQ = X'04'  *   No ENQ is required when reading the physical     NJE00920
*                  *   blocks as these blocks are allocated exclusively NJE00920
********************   to the calling task.  The file id to read must   NJE00920
*                      be in NSID in the tag data pointed to by NCBTAG
*                                                                       NJE00920
GET000   EQU   *
         LA    R14,*                   -> location of error source v110
         TM    NJFL1,NJF1OACB          Is ACB open?
         BZ    ERR1202                 No
         TM    NJFL1,NJF1PUT           Processing PUTs against file?
         BO    ERR1205                 Yes, cant do GET now
         OI    NJFL1,NJF1GET           Indicate GET in progress
*
         L     R7,RPL                  -> RPL
         NC    PTRBLK,PTRBLK           Do we have a ptr block in prog?
         BNZ   GET060                  Yes, read next logical rec
*
         LA    R0,DIRLOC               Locate file function
         L     R15,=A(NJEDIR)          Call directory mgmt
         BALR  R14,R15                 File id is in tag field TAGID
*
         LTR   R15,R15                 Was file found?
         BZ    GET010                  Yes
         C     R15,=F'12'              Errors processing directory?
         BL    EXIT08                  Exit here if 4 or 8=VSAM errors
         B     EXIT12                  All others Exit12
*
GET010   EQU   *
         MODCB RPL=(R7),                                               x
               OPTCD=(KEY,DIR,MVE,NUP), No update needed on GETs       x
               MF=(G,MACLIST)
*
         L     R3,NCBTAG               -> tag data
         USING TAG,R3
         MVC   GETLIM,TAGRECNM         Save off # of records in file
         DROP  R3
*
         L     R3,INITBLK              Get 1st block # of file
*
GET020   EQU   *                    ** Get a ptr block
         ST    R3,KEY                  Set block retrieval key
         GET   RPL=(R7)                Get the ptr block
         BAL   R14,CHKRPL              Deal with errors
         BNZ   EXIT08                  Exit with VSAM error
*
         ST    R3,PTRBLK               Save ptr blk #
         L     R0,BLOCK                -> VSAM i/o area
         LA    R1,4089                 Size of physical block
         L     R14,PTRBUF              -> buffer containing repl dir
         LR    R15,R1                  Copy length
         MVCL  R14,R0                  Put ptr data in ptrbuf
*
         L     R4,PTRBUF               -> ptr block ptrs
         ST    R4,PTRPOS               Maintain ptr position
*
GET030   EQU   *
         C     R4,PTRBUFEN             Out of ptrs this block?
         BL    GET040                  No
*
*                                   ** Here if ptr block chains to
*                                       another ptr block
         CLI   0(R4),X'FE'             ptr to ptrblk indicator?
         BNE   GET200         EOF      No, done with ptrs
         SR    R3,R3                   Clear for IC
         ICM   R3,7,1(R4)              Get ptr to next ptr block
         ST    R3,KEY                  Set up for retrieval
         B     GET020                  Go get it
*
GET040   EQU   *
         ICM   R2,15,0(R4)             Get a data block #
         BZ    GET200         EOF      Done with ptrs
*
         ST    R2,KEY                  Set block retrieval key
         GET   RPL=(R7)                Get the ptr block
         BAL   R14,CHKRPL              Deal with errors
         BNZ   EXIT08                  Exit with VSAM error
*
         L     R5,BLOCK                -> VSAM i/o area
         ST    R5,GETPOS               Maintain read position
*
GET060   EQU   *
         L     R5,GETPOS               -> next logical record to read
         CLC   0(2,R5),=X'FFFF'        Is this end of file?
         BE    GET200                  Yes
         CLC   0(2,R5),=X'FFFE'        Skip to next ptr indication?
         BE    GET100                  Yes
*
         SR    R14,R14                 Clear for IC
         ICM   R14,3,0(R5)             Get the record length
         BCTR  R14,0                   Reduce length of length
         BCTR  R14,0                   Reduce length of length
         STH   R14,NCBRECLN            Return length to caller
*
         L     R15,NCBAREA              -> to caller's record buffer
         BCT   R14,*+10                Adjust len for execute
GETREC   MVC   0(0,R15),2(R5)
         EX    R14,GETREC              Move record to user area
         LA    R5,1+2(R14,R5)          Get record len + overhead
*                                       +1 to get back true length
*                                       +2 for length halfword itself
         ST    R5,GETPOS               Save read position
         L     R1,GETCNT               Get count of records read
         LA    R1,1(,R1)               Bump it
         ST    R1,GETCNT               Update count for debug purposes
         B     EXIT00                  Exit with record in NCBAREA
*
GET100   EQU   *
         L     R4,PTRPOS               Get ptr position
         LA    R4,4(,R4)               -> next ptr field
         ST    R4,PTRPOS               Maintain ptr position
         B     GET030                  Go process next ptr
*
GET200   EQU   *
         MVI   NCBERRCD,X'04'          Indicate EOF
         B     EXIT08
*                                                                       NJE00920
*                                                                       NJE00920
********************                                                    NJE00920
*                  *   Delete a file from the NETSPOOL dataset          NJE00920
*  PURGE           *                                                    NJE00920
*  NCBREQ = X'05'  *                                                    NJE00920
*                  *                                                    NJE00920
********************                                                    NJE00920
*                                                                       NJE00920
PUR000   EQU   *
         LA    R14,*                   -> location of error source v110
         TM    NJFL1,NJF1OACB          Is ACB open?
         BZ    ERR1202                 No
*
         LA    R0,DIRDEL               Del file function
         L     R15,=A(NJEDIR)          Call directory mgmt
         BALR  R14,R15                 File to del is in NCB  ???
         LR    R5,R15                  Any RC to R5
         B     QUIT000
*
*                                                                       NJE00920
********************                                                    NJE00920
*                  *   Locate a file in the directory by file id        NJE00920
*  LOCATE          *                                                    NJE00920
*  NCBREQ = X'06'  *                                                    NJE00920
*                  *                                                    NJE00920
********************                                                    NJE00920
*                                                                       NJE00920
FID000   EQU   *
         LA    R14,*                   -> location of error source v110
         TM    NJFL1,NJF1OACB          Is ACB open?
         BZ    ERR1202                 No
*
         LA    R0,DIRLOC               Locate file function
         L     R15,=A(NJEDIR)          Call directory mgmt
         BALR  R14,R15                 File id is in tag field TAGID
         LR    R5,R15                  Any RC to R5
         B     QUIT000
*
*                                                                       NJE00920
********************                                                    NJE00920
*                  *   Return a list of files in NETSPOOL dataset       NJE00920
*  CONTENTS        *                                                    NJE00920
*  NCBREQ = X'07'  *                                                    NJE00920
*                  *                                                    NJE00920
********************                                                    NJE00920
*                                                                       NJE00920
CON000   EQU   *
         LA    R14,*                   -> location of error source v110
         TM    NJFL1,NJF1OACB          Is ACB open?
         BZ    ERR1202                 No
*
         LA    R0,DIRLST               List files function
         L     R15,=A(NJEDIR)          Call directory mgmt
         BALR  R14,R15
         LR    R5,R15                  Any RC to R5
         B     QUIT000
*
*                                                                       NJE00920
********************                                                    NJE00920
*                  *   Update a directory entry by file id         v120 NJE00920
*  UDIR            *                                                    NJE00920
*  NCBREQ = X'08'  *                                                    NJE00920
*                  *                                                    NJE00920
********************                                                    NJE00920
*                                                                       NJE00920
UDR000   EQU   *                                                   v120
         LA    R14,*                   -> location of error source v120
         TM    NJFL1,NJF1OACB          Is ACB open?                v120
         BZ    ERR1202                 No                          v120
*                                                                  v120
         LA    R0,DIRUPD               Update dir  function        v120
         L     R15,=A(NJEDIR)          Call directory mgmt         v120
         BALR  R14,R15                                             v120
         LR    R5,R15                  Any RC to R5                v120
         B     QUIT000                                             v120
*
*
ERR1201  EQU   *                       Invalid NCBREQ function code
         MVI   NCBERRCD,X'01'          Set error code
         B     EXIT12
*
ERR1202  EQU   *                       ACB is not open
         MVI   NCBERRCD,X'02'          Set error code
         B     EXIT12
*
ERR1203  EQU   *                       NETSPOOL dataset is full
         MVI   NCBERRCD,X'03'          Set error code
         B     EXIT12
*
ERR1204  EQU   *                       File # not found in directory
         MVI   NCBERRCD,X'04'          Set error code
         B     EXIT12
*
ERR1205  EQU   *                       GET attempted in PUT mode, or,
*                                      PUT attempted in GET mode
         MVI   NCBERRCD,X'05'          Set error code
         B     EXIT12
*
ERR1206  EQU   *                       No files in directory  (NCBCON)
         MVI   NCBERRCD,X'06'          Set error code
         B     EXIT12
*
*                                                                       NJE00200
* Exit points                                                           NJE00200
*                                                                       NJE00200
*                                                                       NJE00200
*                                                                       NJE00200
EXIT00   EQU   *                                                        NJE00210
         SR    R5,R5                   Set RC=0
         B     QUIT000
*
* Exit04 reasons:
*   All VSAM OPEN/CLOSE and RPL errors.
*
EXIT04   EQU   *                                                        NJE00210
         LA    R5,4                    Set RC=4
         B     QUIT000
*
* Exit08 reasons:
*   All VSAM OPEN/CLOSE and RPL errors.
*
EXIT08   EQU   *                                                        NJE00210
         C     R15,=F'4'               Is is really RC 4?
         BE    EXIT04                  Reflect the truth
         LA    R5,8                    Set RC=8
         B     QUIT000
*
* Exit12 reasons:
*   NETSPOOL dataset is full (no available blocks)
*   NCBREQ contains invalid/unsupported function code
*   File is not open
*   File # is not found in directory
*   GET issued during PUT activity
*   PUT issued during GET activity
*
EXIT12   EQU   *                                                        NJE00210
         ST    R14,NCBMACAD            Save error address          v110
         LA    R5,12                   Set RC=12
         B     QUIT000
*
* Exit16 reasons:
*   R1 = zero on entry
*   R1 doesnt point to NCB  ('NCB ' in 1st four bytes)
*   NCBTKN is zero but NCBREQ is not NCBOPEN
*   NCBTKN doesnt point to area containing 'NSPL'
*
EXIT16   EQU   *                                                        NJE00210
         L     R13,4(,R13)             -> caller's sa                   NJE00210
         LA    R5,16                   Set RC=16
         B     QUIT090
*
QUIT000  EQU   *
         STC   R5,NCBRTNCD             Set R15 return code
         BAL   R14,DEQ000              Remove any ENQ
         L     R13,4(,R13)             -> caller's sa                   NJE00210
         CLC   NCBREQ(3),=AL1(NCBGET,8,4)   EOF on a NCBGET function?
         BNE   QUIT020                 No
         ICM   R15,15,NCBEODAD         Get EODAD address
         BZ    QUIT020                 If none, let 8,4 rtn cd pass
         ST    R15,12(,R13)            Set R14 return to EODAD address
         XC    NCBRTNCD(2),NCBRTNCD    Remove EOF error indicators
         SR    R5,R5                   Set RC=0
*
QUIT020  EQU   *
         CLI   NCBREQ,NCBCLOSE         Is this a close request?
         BNE   QUIT090                 No. Exit without free stgs
*
         LR    R1,R10                  -> NJEWK main work area page
         FREEMAIN RU,                                                  x
               LV=4096,                                                x
               A=(1)
*
QUIT090  EQU   *
         ST    R5,16(,R13)             Set RC in R15
         LM    R14,R12,12(R13)         Reload callers's regs            NJE00220
         BR    R14                     Return                           NJE00240
*                                                                       NJE00250
         LTORG                                                          NJE00280
*
*
OPEN     OPEN  0,MF=L
OPENL    EQU   *-OPEN
CLOSE    CLOSE 0,MF=L
CLOSEL   EQU   *-CLOSE
*
*
         DROP  R12
*
*                                                                       NJE00920
*********************                                                   NJE00920
*  N J E C M N      *               NJECMN hosts small routines and     NJE00920
*                   *               frequently used constants           NJE00920
*  Common routines  *                                                   NJE00920
*  and constants    *               via base register 11                NJE00920
*                   *                                                   NJE00920
*********************                                                   NJE00920
*                                                                       NJE00920
NJECMN   CSECT                                                          NJE00020
         DC    A(0)                 No branch around constants
         DC    AL1(23)                LENGTH OF EYECATCHERS
         DC    CL9'NJECMN'
         DC    CL9'&SYSDATE'
         DC    CL5'&SYSTIME'
         USING NJECMN,R11
         USING NJEWK,R10
*
*-- Check result of VSAM OPEN or CLOSE macro
*
CHKOC    EQU   *
         LTR   R15,R15                 Did request succeed?
         BZR   R14                     Yes return
         ST    R14,NCBMACAD            Save addr of failing macro
         STC   R15,NCBRTNCD            Set return code
         MVC   NCBERRCD,ACBERFLG-IFGACB(R7) error code
         BR    R14                     Return with VSAM error
*
*-- Check result of VSAM RPL macros
*
CHKRPL   EQU   *
         LTR   R15,R15                 Did request succeed?
         BZR   R14                     Yes return
         ST    R14,NCBMACAD            Save addr of failing macro
         STC   R15,NCBRTNCD            Set return code
         MVC   NCBERRCD,RPLERRCD-IFGRPL(R7) error code
         BR    R14                     Return with VSAM error
*
*
ENQ000   EQU   *
         TM    NJFL1,NJF1ENQ           Is ENQ active?
         BOR   R14                     Return if so
*
         ST    R14,SV14                Save return addr
         ENQ   (NJE38Q,NJEDSN,E,44,SYSTEM),                            X
               RET=NONE
*
         OI    NJFL1,NJF1ENQ           ENQ active
         L     R14,SV14                Reload return addr
         BR    R14                     Return
*
*
DEQ000   EQU   *
         TM    NJFL1,NJF1ENQ           Is ENQ active?
         BZR   R14                     Return if not
*
         ST    R14,SV14                Save return addr
         DEQ   (NJE38Q,NJEDSN,44,SYSTEM),                              X
               RET=NONE
         NI    NJFL1,255-NJF1ENQ       ENQ off
         L     R14,SV14                Reload return addr
         BR    R14                     Return
*                                                                       NJE00200
*                                                                       NJE00200
*-- ADDBLK / GETBLK routines                                            NJE00200
*                                                                       NJE00200
*-- Allocate a new physical block.  Scan the allocation map for a free  NJE00200
*-- block and mark it as taken, and return the new block number to the  NJE00200
*-- caller.
*
*-- ADDBLK and GETBLK are functionally identical except that ADDBLK
*-- does not ENQ or DEQ on NETSPOOL; it is assumed that the caller
*-- already has done that (the DIR functions).
*
*-- Uses R14-R4,R7.   R1-R4 are preserved across call
*                                                                       NJE00200
*-- Entry: None                                                         NJE00200
*                                                                       NJE00200
*-- Exit:  R15 = 0 if ok, else RC from VSAM macro.                      NJE00200
*          R0  = block # of new block.  If R0=0, no blocks available.   NJE00200
*                                                                       NJE00200
ADDBLK   EQU   *
         ST    R14,SV14GB              Save return addr
         STM   R1,R4,SVGB              Save caller's regs
         BAL   R14,GETB000             Go allocate the block
         LTR   R15,R15                 VSAM RC in R15, set CC
         LR    R0,R4                   Return block # in R0
         LM    R1,R4,SVGB              Load caller's regs
         L     R14,SV14GB              Load return addr
         BR    R14                     Return
*                                                                       NJE00200
GETBLK   EQU   *
         ST    R14,SV14GB              Save return addr
         STM   R1,R4,SVGB              Save caller's regs
         BAL   R14,ENQ000              Get exclusive control
         BAL   R14,GETB000             Go allocate the block
         LR    R3,R15                  Save R15 across DEQ
         BAL   R14,DEQ000              Release control
         LTR   R15,R3                  Return VSAM RC in R15, set CC
         LR    R0,R4                   Return block # in R0
         LM    R1,R4,SVGB              Load caller's regs
         L     R14,SV14GB              Load return addr
         BR    R14                     Return
*
GETB000  EQU   *
         ST    R14,SV14B0              Save return addr
         LA    R2,ALLOCNUM             Get # of alloc map blocks
         LA    R3,ALLOCBLK             Get 1st alloc map block #
         LA    R4,1                    Starting relative block #
*
GETB010  EQU   *
         ST    R3,KEY                  Set retrieval key
         L     R7,RPL                  -> RPL
         GET   RPL=(R7)                Get a map block
         BAL   R14,CHKRPL              Deal with errors
         BNZ   GETB090                 Exit with VSAM error
*
         L     R14,BLOCK               -> allocation map
         LA    R15,4089                # of entries in map
         L     R1,=X'FF000000'         Set pad char=X'FF'
         CLCL  R14,R0                  Look for a non-FF entry
         BE    GETB030       all FFs:  We're full up in this block
*
         LR    R1,R14                  Copy ptr to map byte
         S     R1,BLOCK                Compute offset from start
         SLL   R1,3                    Each map byte is 8 records
         AR    R4,R1                   Adjust relative block number for
*                                       byte position we located
         ICM   R1,8,0(R14)             Get map byte with the free bit
         LA    R2,X'80'                Create possible opposing bit
*
GETB020  EQU   *
         SR    R0,R0                   Clear for shift use
         SLDL  R0,1                    Shift off one bit into R0
         LTR   R0,R0                   Is this the zero bit?
         BZ    GETB040                 Yes
         SRL   R2,1                    Next opposing bit position
         LA    R4,1(,R4)               Compute next rel blk #
         B     GETB020                 Find that 0 bit
*
GETB030  EQU   *
         LA    R4,4089(,R4)            Incr starting relative block #
         LA    R3,1(,R3)               Next map block key
         BCT   R2,GETB010              Read next map block
*
         ENDREQ RPL=(R7)               No update
         SR    R4,R4                   Return no block #: ALL FULL
         SR    R15,R15                 No VSAM errors
         B     GETB090                 Done
*
SETMAP   OI    0(R14),X'00'            Executed instr
*
GETB040  EQU   *
         EX    R2,SETMAP               Set the bit in allocation map
*
         PUT   RPL=(R7)                Update the allocation map
         BAL   R14,CHKRPL              Deal with errors
*
GETB090  EQU   *
         L     R14,SV14B0              Load return addr
         BR    R14                     Return
*
*
         LTORG
*
WTOMSG   WTO   '                                                       x
                                             ',MF=L
WTOMSGL  EQU   *-WTOMSG
*
ENQ      ENQ   (0),MF=L
ENQL     EQU   *-ENQ
*
DEQ      DEQ   (0),MF=L
DEQL     EQU   *-DEQ
*
         DS    0D
NJE38Q   DC    CL8'NJE38'
NJEDSN   DC    CL44'NJE38.NETSPOOL'
*
BLANKS   DC    CL120' '
NONBLANK DC    64X'FF',X'00',191X'FF'   TR Table to locate nonblank
BLANK    DC    64X'00',X'FF',100X'00'   TR Table to locate blanks
TRTAB$   DC    91X'00',X'FF',164X'00'   TR Table to locate '$'
HEXTRAN  DC    CL16'0123456789ABCDEF'  Translate table
*                                                                       NJE00920
*                                                                       NJE00920
*********************                                                   NJE00920
*                   *                                                   NJE00920
*  N J E D I R      *                                                   NJE00920
*                   *                                                   NJE00920
*  Directory        *                                                   NJE00920
*  Management       *                                                   NJE00920
*                   *                                                   NJE00920
*********************                                                   NJE00920
*                                                                       NJE00920
*
NJEDIR   CSECT                                                          NJE00020
         B     28(,R15)               BRANCH AROUND EYECATCHERS
         DC    AL1(23)                LENGTH OF EYECATCHERS
         DC    CL9'NJEDIR'
         DC    CL9'&SYSDATE'
         DC    CL5'&SYSTIME'
         STM   R14,R12,12(R13)         SAVE CMS REGS                    NJE00050
         LR    R12,R15                 BASE                             NJE00060
         USING NJEDIR,R12              ADDRESS IT                       NJE00070
         USING NJEWK,R10
         USING NCB,R9
*
         ST    R13,NJEDIRSA+4          SAVE prv S.A. ADDR               NJE00080
         LA    R1,NJEDIRSA             -> my save area
         ST    R1,8(,R13)              Plug it into prior SA
         LR    R13,R1
*
         L     R11,=A(NJECMN)          -> common csect
         ST    R11,ANJECMN             Save addr
         USING NJECMN,R11
*
DIRADD   EQU   0                       Add new file to directory
DIRDEL   EQU   4                       Purge a file from directory
DIRLOC   EQU   8                       Locate a file by ID
DIRLST   EQU   12                      List directory contents
DIRUPD   EQU   16                      Update directory entry      v120
*
         LR    R2,R0                   Copy entry code
         B     *+4(R2)                 Branch into branch table
         B     ADD000               0  Add a new directory entry
         B     DEL000               4  Delete a directory entry
         B     LOC000               8  Locate a file by ID
         B     LST000               C  List directory contents
         B     UPD000              10  Update directory entry      v120
*
ADD000   EQU   *
         LA    R0,(10000/8)+1          Byte size of 10,000 bits
         ST    R0,SPLIDLEN             Save the length
         GETMAIN RU,                   Get stg for spool id bitmap     x
               LV=(0)
         ST    R1,SPLIDMAP             Save stg addr
         LR    R0,R1                   Copy starting addr
         L     R1,SPLIDLEN             Get the length
         SR    R15,R15                 Set pad char
         MVCL  R0,R14                  Initialize the map
*
         BAL   R14,ENQ000              Get exclusivity
*
         MVC   KEY,=F'1'               Get the first block
         L     R7,RPL                  -> RPL
         GET   RPL=(R7)                Get a map block
         BAL   R14,CHKRPL              Deal with errors
         BNZ   ADD900                  Exit with VSAM error
*
         L     R2,BLOCK                -> blk #1 in stg
         USING BLKONE,R2
         MVC   SPLID,SPLNUM            Save the last assigned id #
         L     R2,DIRBLK               Get blk# of current directory
         DROP  R2
         LA    R3,1                    Load XOR counterpart
         XR    R3,R2                   Compute alternate directry blk#
*
*-- R2 = starting block number of current directory
*-- R3 = starting block number of replacement directory
*
*
         ST    R2,KEY                  Get a current dir block
         L     R7,RPL                  -> RPL
         GET   RPL=(R7)                Get a block
         BAL   R14,CHKRPL              Deal with errors
         BNZ   ADD900                  Exit with VSAM error
*
         L     R0,BLOCK                -> VSAM i/o area
         LA    R1,4089                 Size of physical block
         L     R14,BUFF                -> buffer to place block
         LR    R15,R1                  Copy length
         MVCL  R14,R0                  Move data
*
         ST    R3,KEY                  Get a replacement dir block
         L     R7,RPL                  -> RPL
         GET   RPL=(R7)                Get a block
         BAL   R14,CHKRPL              Deal with errors
         BNZ   ADD900                  Exit with VSAM error
*
*-- Copy all of the directory entries in the current directory over
*-- to the (new) replacement directory (where we will eventually add
*-- a new directory entry).  Along the way, build a bit map of all
*-- of the spool file numbers that are in use (they're in the
*-- directory entries) so that we can assign a new unique file # to
*-- the new file in its new directory entry.
*
         L     R4,BUFF                 -> current directory
         L     R5,BLOCK                -> replacement directory
         L     R8,NSRECNM-NSDIR(,R4)   Get # directory entries current
         LA    R1,1(,R8)               +1 for new dir ent to be added
         ST    R1,NSRECNM-NSDIR(,R4)   Store (will get copied to repl)
         ST    R3,NSBLK-NSDIR(,R4)     Store starting blk of dir (will
*                                       get copied to replacement dir)
*
ADD050   EQU   *
         CLC   NSLEN-NSDIR(,R4),=X'FFFE'   Ptr to next block?
         BE    ADD100                  yes
         MVC   0(NSDIRLN,R5),0(R4)     Copy existing dir entry to repl
*
         LH    R7,NSID-NSDIR(,R4)      Get file id # for this file
         SR    R6,R6                   Clear for divide
         D     R6,=F'8'                Get byte offset remainder bits
*
         A     R7,SPLIDMAP             -> byte containing bit for
*                                       this file #
         LA    R1,X'80'                Create a bit
         SRL   R1,0(R6)                Adjust to bit for this file #
         EX    R1,SPLSET               Set the bit in the spool id map
*
         LA    R4,NSDIRLN(,R4)         -> next current dir entry
         LA    R5,NSDIRLN(,R5)         -> next replacement dir entry
         BCT   R8,ADD050               Keep copying dir entries
         B     ADD200                  Go add the new dir entry
*
SPLSET   OI    0(R7),X'00'             Executed instr
*
*
*-- Here if the directory continues onto another block.  Get these
*-- blocks, and continue processing individual entries.
*
ADD100   EQU   *
         L     R7,RPL                  -> RPL
         PUT   RPL=(R7)                Update the replacement block
         BAL   R14,CHKRPL              Deal with errors
         BNZ   ADD900                  Exit with VSAM error
*
         CLC   NSLEN-NSDIR(,R5),=X'FFFE' Repl dir ptr to next block?
         BNE   ADD190                  No; we need to add a block
*
ADD120   EQU   *
         ICM   R2,15,2(R4)             Get ptr to next current dir blk
         ICM   R3,15,2(R5)             Get ptr to next repl dir blk
*
         ST    R2,KEY                  Get next current dir block
         L     R7,RPL                  -> RPL
         GET   RPL=(R7)                Get a block
         BAL   R14,CHKRPL              Deal with errors
         BNZ   ADD900                  Exit with VSAM error
*
         L     R0,BLOCK                -> VSAM i/o area
         LA    R1,4089                 Size of physical block
         L     R14,BUFF                -> buffer to place block
         LR    R15,R1                  Copy length
         MVCL  R14,R0                  Move data
*
         ST    R3,KEY                  Get next replacement dir block
         L     R7,RPL                  -> RPL
         GET   RPL=(R7)                Get a block
         BAL   R14,CHKRPL              Deal with errors
         BNZ   ADD900                  Exit with VSAM error
*
         L     R4,BUFF                 -> current directory
         L     R5,BLOCK                -> replacement directory
         B     ADD050                  Continue processing
*
ADD190   EQU   *
         L     R3,KEY                  Get current blk # we just wrote
*
         BAL   R14,ADDBLK              Allocate a new physical block
         BNZ   ADD900                  Exit with VSAM error
         LTR   R6,R0                   Is there a block number?
         BZ    ADD910                  No, NETSPOOL dataset full   v130
*
         ST    R3,KEY                  Gotta update blk again with ptr
         GET   RPL=(R7)                Get the physical block
         BAL   R14,CHKRPL              Deal with errors
         BNZ   ADD900                  Exit with VSAM error
*
         MVC   0(2,R5),=X'FFFE'        Insert ptr indic for next blk
         STCM  R6,15,2(R5)             Insert next block #
         B     ADD100                  Now go jump to next dir blks
*
*-- Here when all current directory entries have been copied to the
*-- new (replacement) directory.  Add the new directory entry for
*-- the file just written out via PUT actions.
*
ADD200   EQU   *
         L     R1,BLOCKEND             -> end of buffer
         SR    R1,R5                   Determine remaining space in blk
         LA    R4,NSDIRLN              Get size of directory entry
         LA    R4,2+4(,R4)             Add in overhead
*                                       +2 for n block marker
*                                       +4 for next block ptr
         CR    R1,R4                   Is there room to add entry?
         BL    ADD300                  No, better get another block
*
         USING NSDIR,R5
         XC    NSDIR(NSDIRLN),NSDIR    Init new entry
         MVC   NSLEN,=Y(NSDIRLN)       Set entry length
         MVC   NSBLK,INITBLK           Set starting blk# of the file
         L     R6,NCBTAG               -> TAG block for file
         USING TAG,R6
         MVC   NSINLOC(TAGUSELN),TAGINLOC  Tag data to dir entry
*
         L     R1,SPLID                Get last assigned file id #
         L     R0,=F'10000'            10,000 possible spool ids
*
ADD250   EQU   *
         LA    R15,1(,R1)              Choose next number
         C     R15,=F'10000'           At the limit?
         BL    *+8                     No
         LA    R15,1                   Reset to 1
         LR    R1,R15                  Save next possible number
*
         SR    R14,R14                 Clear for divide
         D     R14,=F'8'               Get byte offset remainder bits
*
         A     R15,SPLIDMAP            -> byte containing bit for
*                                       this spool id #
         LA    R7,X'80'                Create a bit
         SRL   R7,0(R14)               Adjust to bit for this id #
         EX    R7,TMBIT                Check bit status in the bitmap
         BZ    ADD260                  Spool id not in use. take it
         BCT   R0,ADD250               Else try next number
         SR    R1,R1                   Otherwise use id=0000
         B     ADD260
*
TMBIT    TM    0(R15),X'00'            Executed instr
*
*
*
ADD260   EQU   *
         ST    R1,SPLID                Save newly assigned spool id
         STCM  R1,3,NSID               Assign the file id # to file
         STCM  R1,3,NCBFID             Also put it in the NCB
         STCM  R1,3,TAGID              Also, put it in the tag data
         DROP  R5,R6                   NSDIR,TAG
*
         LA    R4,NSDIRLN(,R5)         Skip past entry just added
         L     R5,BLOCKEND             -> end of block
         SR    R5,R4                   Compute length remaining in blk
         SR    R15,R15                 Set pad
         MVCL  R4,R14                  Clear to end of block
*
         L     R7,RPL                  -> RPL
         PUT   RPL=(R7)                Update final replacement block
         BAL   R14,CHKRPL              Deal with errors
         BNZ   ADD900                  Exit with VSAM error
*
*-- Now update block 1 to activate the replacement directory
*
         MVC   KEY,=F'1'               Get the first block
         L     R7,RPL                  -> RPL
         GET   RPL=(R7)                Get a map block
         BAL   R14,CHKRPL              Deal with errors
         BNZ   ADD900                  Exit with VSAM error
*
         L     R1,BLOCK                -> blk #1 in stg
         USING BLKONE,R1
         L     R2,DIRBLK               Get blk# of current directory
         LA    R3,1                    Load XOR counterpart
         XR    R3,R2                   Compute alternate directry blk#
         ST    R3,DIRBLK               Plug in alternate
         MVC   SPLNUM,SPLID            Save last assigned spool id
         DROP  R1
*
         L     R7,RPL                  -> RPL
         PUT   RPL=(R7)                Update block 1
         BAL   R14,CHKRPL              Deal with errors
         BNZ   ADD900                  Exit with VSAM error
         B     XITDIR                  Exit with RC=0
*
*-- Here if there is no room in a directory block to add the new
*-- file's directory entry.  An additional block will be allocated and
*-- chained to the directory entries.
*
ADD300   EQU   *
         L     R7,RPL                  -> RPL
         PUT   RPL=(R7)                Write back the dir block
         BAL   R14,CHKRPL              Deal with errors
         BNZ   ADD900                  Exit with VSAM error
         L     R4,KEY                  Get current blk # we just wrote
*
         BAL   R14,ADDBLK              Allocate a new physical block
         BNZ   ADD900                  Exit with VSAM error
         LTR   R6,R0                   Is there a block number?
         BZ    ADD910                  No, NETSPOOL dataset full   v130
*
         ST    R4,KEY                  Gotta update blk again with ptr
         GET   RPL=(R7)                Get the physical block
         BAL   R14,CHKRPL              Deal with errors
         BNZ   ADD900                  Exit with VSAM error
*
         MVC   0(2,R5),=X'FFFE'        Insert ptr indic for next blk
         STCM  R6,15,2(R5)             Insert next block #
*
         L     R7,RPL                  -> RPL
         PUT   RPL=(R7)                Write back the dir block
         BAL   R14,CHKRPL              Deal with errors
         BNZ   ADD900                  Exit with VSAM error
*
         ST    R6,KEY                  Now point to newly obtained blk
         GET   RPL=(R7)                Get the physical block
         BAL   R14,CHKRPL              Deal with errors
         BNZ   ADD900                  Exit with VSAM error
*
         L     R0,BLOCK                -> VSAM i/o area
         LA    R1,4089                 Size of physical block
         SR    R3,R3                   Pad
         MVCL  R0,R2                   Clear it
*
         L     R5,BLOCK                -> new block stg
         B     ADD200                  Try again to add new dir entry
*
ADD900   EQU   *                       VSAM Error return
*                                       Error codes in NCB already
         B     XITDIR                  Exit with RC in R15
*
ADD910   EQU   *                       No space in NETSPOOL
         MVC   NCBRTNCD(2),=X'0C03'    Set to 12,3 code
         LA    R14,*                   -> location of error source v110
         ST    R14,NCBMACAD            Store into NCB              v110
         LA    R15,12                  Set RC
         B     XITDIR                  Return that notice
*
*
*
*
*
DEL000   EQU   *
         GETMAIN RU,                   Get stg for alloc bitmap        x
               LV=16384
         STM   R0,R1,SPLIDLEN          Save len,addr
*
         L     R7,RPL                  -> RPL
         MODCB RPL=(R7),                                               x
               OPTCD=(KEY,DIR,MVE,UPD), Update mode                    x
               MF=(G,MACLIST)
*
         BAL   R14,ENQ000              Get exclusivity
*
         LA    R2,ALLOCNUM             Get # of alloc map blocks
         LA    R3,ALLOCBLK             Get 1st alloc map block #
         L     R4,SPLIDMAP             -> receiving stg area
*
DEL020   EQU   *
         ST    R3,KEY                  Set retrieval key
         L     R7,RPL                  -> RPL
         GET   RPL=(R7)                Get a map block
         BAL   R14,CHKRPL              Deal with errors
         BNZ   DEL900                  Exit with VSAM error
*
         L     R14,BLOCK               -> block just read
         LA    R15,4089                # of bytes in block
         LR    R5,R15                  Copy len
         MVCL  R4,R14                  Move alloc bitmap to stg area
*
         LA    R3,1(,R3)               Next block number of alloc map
         BCT   R2,DEL020               Go read them all
*
         MVC   KEY,=F'1'               Get the first block
         L     R7,RPL                  -> RPL
         GET   RPL=(R7)                Get a map block
         BAL   R14,CHKRPL              Deal with errors
         BNZ   DEL900                  Exit with VSAM error
*
         L     R2,BLOCK                -> blk #1 in stg
         USING BLKONE,R2
         L     R2,DIRBLK               Get blk# of current directory
         LA    R3,1                    Load XOR counterpart
         XR    R3,R2                   Compute alternate directry blk#
         DROP  R2
*
*-- R2 = starting block number of current directory
*-- R3 = starting block number of replacement directory
*
*
         ST    R2,KEY                  Get a current dir block
         L     R7,RPL                  -> RPL
         GET   RPL=(R7)                Get a block
         BAL   R14,CHKRPL              Deal with errors
         BNZ   DEL900                  Exit with VSAM error
*
         L     R0,BLOCK                -> VSAM i/o area
         LA    R1,4089                 Size of physical block
         L     R14,BUFF                -> buffer to place block
         LR    R15,R1                  Copy length
         MVCL  R14,R0                  Move data
*
         ST    R3,KEY                  Get a replacement dir block
         L     R7,RPL                  -> RPL
         GET   RPL=(R7)                Get a block
         BAL   R14,CHKRPL              Deal with errors
         BNZ   DEL900                  Exit with VSAM error
*
         L     R0,BLOCK                -> VSAM i/o area
         LA    R1,4089                 Size of physical block
         L     R14,PTRBUF              -> buffer to place block
         LR    R15,R1                  Copy length
         MVCL  R14,R0                  Move data
*
*-- Current directory is in BUFF
*-- Replacement directory will be in PTRBUF
*
*
*-- Copy all of the directory entries in the current directory over
*-- to the (new) replacement directory (where we will eventually delete
*-- a directory entry).  Along the way, look for the entry to be
*-- purged.
*
         L     R4,BUFF                 -> current directory
         L     R5,PTRBUF               -> replacement directory
         L     R8,NSRECNM-NSDIR(,R4)   Get # directory entries current
         LR    R1,R8                   Copy count
         BCTR  R1,0                    Reduce for to-be-deleted file
         ST    R1,NSRECNM-NSDIR(,R4)   Store (will get copied to repl)
         ST    R3,NSBLK-NSDIR(,R4)     Store starting blk of dir (will
*                                       get copied to replacement dir)
         L     R6,NCBTAG               -> TAG data
         LH    R6,TAGID-TAG(,R6)       Get file id number
         XC    INITBLK,INITBLK         Clear file's starting blk #
*
DEL050   EQU   *
         CLC   NSLEN-NSDIR(,R4),=X'FFFE'   Ptr to next block?
         BE    DEL100                  yes
         CH    R6,NSID-NSDIR(,R4)      Is this the file to be purged?
         BE    DEL070
         CLC   NSLEN-NSDIR(,R5),=X'FFFE'   Ptr to next block?
         BE    DEL120                  yes
         MVC   0(NSDIRLN,R5),0(R4)     Copy existing dir entry to repl
         LA    R5,NSDIRLN(,R5)         -> next replacement dir entry
*
DEL060   EQU   *
         LA    R4,NSDIRLN(,R4)         -> next current dir entry
         BCT   R8,DEL050               Keep copying dir entries
         B     DEL200                  Done with copy
*
DEL070   EQU   *
         MVC   INITBLK,NSBLK-NSDIR(R4) Save starting block # of file
         B     DEL060                  Continue copy
*
*
*-- Get next current dir block (move it to BUFF)
*
DEL100   EQU   *
         ICM   R2,15,2(R4)             Get ptr to next current dir blk
*
         ST    R2,KEY                  Get next current dir block
         L     R7,RPL                  -> RPL
         GET   RPL=(R7)                Get a block
         BAL   R14,CHKRPL              Deal with errors
         BNZ   DEL900                  Exit with VSAM error
*
         L     R0,BLOCK                -> VSAM i/o area
         LA    R1,4089                 Size of physical block
         L     R14,BUFF                -> buffer to place block
         LR    R15,R1                  Copy length
         MVCL  R14,R0                  Move data
         L     R4,BUFF                 -> current directory
         B     DEL050                  Continue with copy
*
*-- Get next replacement dir block
*--  1. Write back the replacement we've been copying to (from PTRBUF)
*--  2. Get next block
*--  3. Move it to PTFBUF
*
DEL120   EQU   *
         ST    R3,KEY                  Set blk# of repl dir block
         L     R7,RPL                  -> RPL
         GET   RPL=(R7)                Get the block for update
         BAL   R14,CHKRPL              Deal with errors
         BNZ   DEL900                  Exit with VSAM error
*
         L     R0,BLOCK                -> VSAM i/o area
         LA    R1,4089                 Size of physical block
         L     R14,PTRBUF              -> buffer containing repl dir
         LR    R15,R1                  Copy length
         MVCL  R0,R14                  Move data to i/o buffer
*
         L     R7,RPL                  -> RPL
         PUT   RPL=(R7)                Update the replacement block
         BAL   R14,CHKRPL              Deal with errors
         BNZ   DEL900                  Exit with VSAM error
*
         ICM   R3,15,2(R5)             Get ptr to next current dir blk
*
         ST    R3,KEY                  Get next current dir block
         L     R7,RPL                  -> RPL
         GET   RPL=(R7)                Get a block
         BAL   R14,CHKRPL              Deal with errors
         BNZ   DEL900                  Exit with VSAM error
*
         L     R0,BLOCK                -> VSAM i/o area
         LA    R1,4089                 Size of physical block
         L     R14,PTRBUF              -> buffer to place block
         LR    R15,R1                  Copy length
         MVCL  R14,R0                  Move data
         L     R5,PTRBUF               -> replacement directory
         B     DEL050                  Continue with copy
*
*-- Fix up the last replacement dir block
*
DEL200   EQU   *
         L     R1,PTRBUF               -> start of buffer
         LA    R15,4088(,R1)           -> end of that buffer - 1
*
DEL210   EQU   *
         CR    R1,R15                  Past end of buffer?
         BH    DEL230                  Y, done searching
         CLC   0(2,R1),=X'FFFE'        Left over pointer indicator?
         BE    DEL220                  Yes
         LA    R1,NSDIRLN(,R1)         Next dir entry position
         B     DEL210
*
DEL220   EQU   *
         ICM   R7,15,2(R1)             Pick up the left over block #
         BAL   R14,FREBLK              Go free the block in R7
*
DEL230   EQU   *
         LR    R0,R5                   -> end of used part of ptrbuf
         L     R1,PTRBUF               -> start of buffer
         LA    R1,4089(,R1)            -> end of that buffer
         SR    R1,R5                   Compute length to clear
         SR    R15,R15                 Compute length to write out
         MVCL  R0,R14                  Clear to end of block
*
         ST    R3,KEY                  Set blk# of repl dir block
         L     R7,RPL                  -> RPL
         GET   RPL=(R7)                Re-get for update
         BAL   R14,CHKRPL              Deal with errors
         BNZ   DEL900                  Exit with VSAM error
*
         L     R0,BLOCK                -> VSAM i/o area
         LA    R1,4089                 Size of physical block
         L     R14,PTRBUF              -> buffer containing repl dir
         LR    R15,R1                  Copy length
         MVCL  R0,R14                  Move repl data to i/o buffer
*
         PUT   RPL=(R7)                Update the last repl block
         BAL   R14,CHKRPL              Deal with errors
         BNZ   DEL900                  Exit with VSAM error
*
*-- DEL300 is used to free all of the blocks used by the file itself
*
DEL300   EQU   *
         ICM   R7,15,INITBLK           Get 1st block # of deleted file
         BZ    DEL910                  If 0, file # wasn't found
*
DEL310   EQU   *
         ST    R7,KEY                  Set block retreival key
         BAL   R14,FREBLK              Mark the block as free in bitmap
*
         L     R7,RPL                  -> RPL
         GET   RPL=(R7)                Get the ptr block
         BAL   R14,CHKRPL              Deal with errors
         BNZ   DEL900                  Exit with VSAM error
*
         L     R4,BLOCK                -> ptr block ptrs
         LA    R5,4084(,R4)            -> end of ptr block ptrs
*
DEL330   EQU   *
         ICM   R7,15,0(R4)             Get a block #
         BZ    DEL350                  Done with ptrs
         BAL   R14,FREBLK              Free the block
         LA    R4,4(,R4)               -> next ptr field
         CR    R4,R5                   At end of ptr block?
         BL    DEL330
*                                   ** Here if ptr block chains to
*                                       another ptr block
         CLI   0(R4),X'FE'             Ptr to ptr blk indicator?
         BNE   DEL350                  No, we've processed last ptr
         SR    R7,R7                   Clear for IC
         ICM   R7,7,1(R4)              Get ptr to next ptr block
         B     DEL310
*
*-- Write back the allocation map
*
DEL350   EQU   *
         LA    R2,ALLOCNUM             Get # of alloc map blocks
         LA    R3,ALLOCBLK             Get 1st alloc map block #
         L     R4,SPLIDMAP             -> map stg area
*
DEL360   EQU   *
         ST    R3,KEY                  Set retrieval key
         L     R7,RPL                  -> RPL
         GET   RPL=(R7)                Get a map block
         BAL   R14,CHKRPL              Deal with errors
         BNZ   DEL900                  Exit with VSAM error
*
         L     R14,BLOCK               -> block just read
         LA    R15,4089                # of bytes in block
         LR    R5,R15                  Copy len
         MVCL  R14,R4                  Move alloc bitmap to i/o buffer
*
         PUT   RPL=(R7)                Put the map block
         BAL   R14,CHKRPL              Deal with errors
         BNZ   DEL900                  Exit with VSAM error
*
         LA    R3,1(,R3)               Next block number of alloc map
         BCT   R2,DEL360               Go read them all
*
*-- Now update block 1 to activate the replacement directory
*
DEL400   EQU   *
         MVC   KEY,=F'1'               Get the first block
         L     R7,RPL                  -> RPL
         GET   RPL=(R7)                Get a map block
         BAL   R14,CHKRPL              Deal with errors
         BNZ   DEL900                  Exit with VSAM error
*
         L     R1,BLOCK                -> blk #1 in stg
         USING BLKONE,R1
         L     R2,DIRBLK               Get blk# of current directory
         LA    R3,1                    Load XOR counterpart
         XR    R3,R2                   Compute alternate directry blk#
         ST    R3,DIRBLK               Plug in alternate
         DROP  R1
*
         L     R7,RPL                  -> RPL
         PUT   RPL=(R7)                Update block 1
         BAL   R14,CHKRPL              Deal with errors
         BNZ   DEL900                  Exit with VSAM error
         B     XITDIR                  Exit with RC=0
*
DEL900   EQU   *                       VSAM Error return
*                                       Error codes in NCB already
         B     XITDIR                  Exit with RC in R15
*
DEL910   EQU   *                    ** Here if directry entry not found
         MVC   NCBRTNCD(2),=X'0C04'    Set to 12,4 code
         LA    R14,*                   -> location of error source v110
         ST    R14,NCBMACAD            Store into NCB              v110
         LA    R15,12                  Set RC
         B     XITDIR                  Exit with RC in R15
*
*-- Free a block (mark it available in the allocation bitmap)
*
*-- Entry: R7 = block #
*
FREBLK   EQU   *
         BCTR  R7,0                    Make blk # relative to 0
         SR    R6,R6                   Clear for divide
         D     R6,=F'8'                Get byte offset remainder bits
*
         A     R7,SPLIDMAP             -> byte containing bit for
*                                       this block
         LA    R1,X'80'                Create a bit
         SRL   R1,0(R6)                Adjust to bit for this blk #
         LA    R0,X'FF'                Create AND mask
         XR    R1,R0                   Compute mask to turn a bit off
         EX    R1,FREBIT               Turn off the bit in the bitmap
         BR    R14                     Return
*
FREBIT   NI    0(R7),X'00'             Executed instr
*
*
*
* LOC000 - FIND a file by id in the directory.                     v120
* UPD000 - UDIR update a directory entry for a specific file.      v120
*
*
*-- UDIR functionality only updates the destination node id and    v120
*--      destination user id within the directory entry from       v120
*--      the TAG data supplied by the caller.  No other directory  v120
*--      fields are altered.                                       v120
*
*
LOC000   EQU   *
UPD000   EQU   *                                                   v120
         BAL   R14,ENQ000              Get exclusivity
*
         MVC   KEY,=F'1'               Get the first block
         L     R7,RPL                  -> RPL
         GET   RPL=(R7)                Get a map block
         BAL   R14,CHKRPL              Deal with errors
         BNZ   LOC900                  Exit with VSAM error
*
         L     R2,BLOCK                -> blk #1 in stg
         USING BLKONE,R2
         L     R2,DIRBLK               Get blk# of current directory
         DROP  R2
*
*
         ST    R2,KEY                  Get a current dir block
         GET   RPL=(R7)                Get a block
         BAL   R14,CHKRPL              Deal with errors
         BNZ   LOC900                  Exit with VSAM error
*
*
         L     R4,BLOCK                -> current directory
         USING NSDIR,R4
         L     R8,NSRECNM              Get # directory entries current
*
         L     R6,NCBTAG               -> TAG data
         USING TAG,R6
         XC    INITBLK,INITBLK         Clear file's starting blk #
*
LOC050   EQU   *
         CLC   NSLEN,=X'FFFE'          Ptr to next block?
         BNE   LOC060                  No
*
         ICM   R2,15,2(R4)             Get ptr to next current dir blk
         ST    R2,KEY                  Get next current dir block
*
         GET   RPL=(R7)                Get a block
         BAL   R14,CHKRPL              Deal with errors
         BNZ   LOC900                  Exit with VSAM error
         L     R4,BLOCK                -> next directory block
*
LOC060   EQU   *
         CLC   TAGID,NSID              Is this the file we need?
         BE    LOC070
*
         LA    R4,NSDIRLN(,R4)         -> next current dir entry
         BCT   R8,LOC050               Keep looking
         B     LOC100                  Done with search
*
LOC070   EQU   *
         CLI   NCBREQ,NCBUDIR          Is this UDIR function?      v120
         BE    UPD100                  Yes                         v120
*
         MVC   INITBLK,NSBLK           Save starting block # of file
         MVC   TAGINLOC(TAGUSELN),NSINLOC  Return the tag data to callr
*
*
LOC100   EQU   *
         ENDREQ RPL=(R7)               Release the get-for-update
*
         NC    INITBLK,INITBLK         Did we find a file?
         BZ    LOC910                  No, exit with not found error
         SR    R15,R15                 Set RC to 0
         B     XITDIR
*
*
UPD100   EQU   *                                                   v120
         MVC   NSTOLOC,TAGTOLOC        Update destination node id  v120
         MVC   NSTOVM,TAGTOVM          Update destination user id  v120
         MVC   TAGINLOC(TAGUSELN),NSINLOC  Rtrn tag data to caller v120
         MVC   INITBLK,NSBLK           Save file's startinblock #  v120
*
         PUT   RPL=(R7)                Update the directory        v120
         BAL   R14,CHKRPL              Deal with errors            v120
         BNZ   LOC900                  Exit if VSAM error          v120
         B     XITDIR
*
         DROP  R6                      TAG                         v120
         DROP  R4                      NSDIR                       v120
*
*
LOC900   EQU   *                       VSAM Error return
*                                       Error codes in NCB already
         B     XITDIR                  Exit with RC in R15
*
LOC910   EQU   *                    ** Here if directry entry not found
         MVC   NCBRTNCD(2),=X'0C04'    Set to 12,4 code
         LA    R14,*                   -> location of error source v110
         ST    R14,NCBMACAD            Store into NCB              v110
         LA    R15,12                  Set RC
         B     XITDIR                  Exit with RC in R15
*
*
*
*
*
LST000   EQU   *
         XC    LISTLEN,LISTLEN         Ensure no stray len
         XC    LISTADDR,LISTADDR       Ensure no stray address
         BAL   R14,ENQ000              Get exclusivity
*
         MVC   KEY,=F'1'               Get the first block
         L     R7,RPL                  -> RPL
         GET   RPL=(R7)                Get a map block
         BAL   R14,CHKRPL              Deal with errors
         BNZ   LST900                  Exit with VSAM error
*
         L     R2,BLOCK                -> blk #1 in stg
         USING BLKONE,R2
         L     R3,ALMBLK               Get blk# of alloc map       v200
         L     R8,MAXBLK               Get blk# in dataset         v200
         L     R2,DIRBLK               Get blk# of current directory
         DROP  R2
*
*-- Compute spool percentage full from alloc map                   v200
*
         SR    R5,R5                   Init blks used counter      v200
         LR    R6,R8                   Copy max blocks in dataset  v200
         SRL   R6,3     divide by 8    # map bytes represent'g blksv200
*
LST010   EQU   *                                                   v200
         ST    R3,KEY                  Get a block of map          v200
         L     R7,RPL                  -> RPL                      v200
         GET   RPL=(R7)                Get a map block             v200
         BAL   R14,CHKRPL              Deal with errors            v200
         BNZ   LST900                  Exit with VSAM error        v200
*                                                                  v200
         SR    R0,R0                   Clear for IC work           v200
         L     R15,BLOCK               -> record                   v200
         LA    R14,4089                # bytes to process          v200
*
LST020   EQU   *                                                   v200
         CLI   0(R15),X'00'            Map byte unallocated?       v200
         BE    LST050                  Dont count any              v200
         CLI   0(R15),X'FF'            Map byte fully allocated?   v200
         BE    LST060                  Yes, count 8 blocks         v200
         LA    R4,8                    # bits in a byte            v200
         IC    R0,0(,R15)              Get a map byte              v200
*
LST030   EQU   *                                                   v200
         SR    R1,R1                   Clear for shift             v200
         SRDL  R0,1                    Move a bit into R1          v200
         LTR   R1,R1                   Was the bit=1?              v200
         BZ    LST040                  No, dont count it           v200
         LA    R5,1(,R5)               Count the block bit         v200
*
LST040   EQU   *                                                   v200
         BCT   R4,LST030               Scan whole byte             v200
*
LST050   EQU   *                                                   v200
         BCT   R6,LST070               # map bytes remaining to scnv200
         B     LST080                  Done counting               v200
*
LST060   EQU   *                                                   v200
         LA    R5,8(,R5)               All 8 blocks allocated      v200
         B     LST050                  Decr remaining and continue v200
*
LST070   EQU   *                                                   v200
         LA    R15,1(,R15)             -> next map byte            v200
         BCT   R14,LST020              Keep scanning               v200
         LA    R3,1(,R3)               Bump alloc map block number v200
         B     LST010                  Get another map block       v200
*
LST080   EQU   *                                                   v200
         MH    R5,=Y(100)              Blocks used: prep for % calcv200
         SR    R4,R4                   Clear for divide            v200
         DR    R4,R8                   Compute % full              v200
         AR    R4,R4                   Double remainder            v200
         CR    R4,R8                   Do we need to round up?     v200
         BL    LST090                  No                          v200
         LA    R5,1(,R5)               Round up percent full       v200
*
LST090   EQU   *                                                   v200
         STH   R5,NCBPCT               Return % full in NCB        v200
*
*-- Retrieve directory contents                                    v200
*
LST100   EQU   *
         ST    R2,KEY                  Get a current dir block
         GET   RPL=(R7)                Get a block
         BAL   R14,CHKRPL              Deal with errors
         BNZ   LST900                  Exit with VSAM error
*
*
         L     R4,BLOCK                -> current directory
         USING NSDIR,R4
         L     R8,NSRECNM              Get # directory entries
         BCTR  R8,0                    Less 1 for directory itself
         STCM  R8,3,NCBRECCT           Set entries count in NCB
         LTR   R8,R8                   Were there any entries?
         BZ    LST910                  No
         SR    R0,R0                   Clear for multiply
         LA    R1,NSDIRLN              Length of directory entry
         MR    R0,R8                   Compute size of area needed
         LR    R0,R1                   Copy size to r0
         GETMAIN RU,                   Get stg area to hold entries    x
               LV=(0)
         STM   R0,R1,LISTLEN
         LR    R5,R1                   -> where to place entries
         LA    R4,NSDIRLN(,R4)         Skip over directory's own entry
*
*
LST150   EQU   *                                                   v200
         CLC   NSLEN,=X'FFFE'          Ptr to next block?
         BNE   LST160                  No                          v200
*
         ICM   R2,15,2(R4)             Get ptr to next current dir blk
         ST    R2,KEY                  Get next current dir block
*
         GET   RPL=(R7)                Get a block
         BAL   R14,CHKRPL              Deal with errors
         BNZ   LST900                  Exit with VSAM error
         L     R4,BLOCK                -> next directory block
*
LST160   EQU   *                                                   v200
         MVC   0(NSDIRLN,R5),0(R4)     Move directory entry to stg area
         LA    R4,NSDIRLN(,R4)         -> next dir entry
         LA    R5,NSDIRLN(,R5)         -> next stg area slot
         BCT   R8,LST150               Keep loading                v200
*
         DROP  R4                      NSDIR
*
*
LST200   EQU   *                                                   v200
         ENDREQ RPL=(R7)               Release the get-for-update
*
         MVC   NCBAREA,LISTADDR        Return list stg addr
         MVC   NCBAREAL,LISTLEN        Return list stg len
         MVC   NCBRECLN,=Y(NSDIRLN)    Return size of each dir entry
         SR    R15,R15                 Set RC to 0
         B     XITDIR
*
*
LST900   EQU   *                       VSAM Error return
*                                       Error codes in NCB already
         LM    R0,R1,LISTLEN           Get stg area len, addr
         LTR   R0,R0                   Is there an area?
         BZ    XITDIR                  No
         FREEMAIN RU,LV=(0),A=(1)      Else free it
         SR    R15,R15                 Clear for RC
         IC    R15,NCBRTNCD            Reinsert RC
         B     XITDIR                  Exit with RC in R15
*
LST910   EQU   *                    ** Here if no files queued
         ENDREQ RPL=(R7)               Release the get-for-update  v130
         XC    NCBAREA,NCBAREA         No directory list obtained  v110
         MVC   NCBRTNCD(2),=X'0C06'    Set to 12,6 code
         LA    R15,12                  Set RC
         LA    R14,*                   -> location of error source v110
         ST    R14,NCBMACAD            Store into NCB              v110
         B     XITDIR                  Exit with RC in R15
*
*
XITDIR   EQU   *
         LR    R5,R15                  Any RC value to R5
         BAL   R14,DEQ000              Release the ENQ
*
         ICM   R1,15,SPLIDMAP          Get spool id bitmap stg addr
         BZ    XITDIR10                Don't have a map
         L     R0,SPLIDLEN             Size of bitmap
         FREEMAIN RU,LV=(0),A=(1)      Free the bitmap
         XC    SPLIDMAP,SPLIDMAP       Clear unsed ptr
*
XITDIR10 EQU   *
         L     R13,4(,R13)             -> caller's sa                   NJE00210
*
         ST    R5,16(,R13)             Set RC in R15
         LM    R14,R12,12(R13)         Reload callers's regs            NJE00220
         BR    R14                     Return                           NJE00240
*                                                                       NJE00290
         LTORG
         DROP  R12
*                                                                       NJE00290
****  Main work area common                                             NJE00290
****  to all NJExxx CSECTs.                                             NJE00290
*                                                                       NJE00290
NJEWK    DSECT
NJEEYE   DS    CL4'NSPL'           Eyecatcher
NJEWKLEN DS    F                   Getmain size of this area
NSOWN    DS    A                   -> TCB of caller
ANJECMN  DS    A                   -> NJECNM common csect               NJE00320
*
DBLE     DS    D                   Work area                            NJE00310
TWRK     DS    2D                  Work area
*
MACLIST  DS    XL160               Macro expansion area
*
SV14     DS    A                   R14 save area
SV14GB   DS    A                   R14 save area
SV14B0   DS    A                   R14 save area
SVGB     DS    4F                  R1-R4 save area
SPLIDLEN DS    F                   Length of spool id bitmap stg
SPLIDMAP DS    A                   -> Spool file id bitmap
SPLID    DS    F                   Last assigned spool id number
LISTLEN  DS    F                   Length of contents stg area
LISTADDR DS    A                   -> directory contents stg area
*
BLOCK    DS    A                   -> buffer for NETSPOOL VSAM i/o
BLOCKEND DS    A                   -> end of BLOCK (BLOCK+4089)
PTRBUF   DS    A                   -> buffer for NJESPOOL ptr use
PTRBUFEN DS    A                   -> end of PTRBUF (PTRBUF+4089)
BUFF     DS    A                   -> buffer for NJESPOOL use
BUFFEND  DS    A                   -> end of BUFF (BUFF+4089)
*
*
INITBLK  DS    F                   Blk # of first block to be written
*                                   for a new file
PTRBLK   DS    F                   Blk # of current phys record for
*                                   pointer block (NCBGET/NCTPUT)
NEWBLK   DS    F                   Blk # of current phys record for
*                                   logical i/o (NCBGET/NCTPUT)
PUTPOS   DS    A                   Current write position in BUFF (next
*                                   available write position)
GETPOS   DS    A                   Current read position in BLOCK (next
*                                   available read position)
PTRPOS   DS    A                   Current write position in PTRBUF
*                                   (next available write position)
PUTCNT   DS    F                   Number of logical records written
GETCNT   DS    F                   Number of logical records read
GETLIM   DS    F                   Max logical records in GET file
*
KEY      DS    F                   Relative block number key
ACBL     DS    F                   ACB length
ACB      DS    A                   -> ACB
RPLL     DS    F                   RPL length
RPL      DS    A                   -> RPL
*
NJFL1    DS    X                   Flag bits
NJF1OACB EQU   X'80'  1... ....     NETSPOOL ACB is open
NJF1ENQ  EQU   X'40'  .1.. ....     Exclusive control of NETSPOOL
NJF1WPND EQU   X'20'  ..1. ....     Physical write is pending
NJF1DPND EQU   X'10'  ...1 ....     Directory add is pending
NJF1PUT  EQU   X'02'  .... ..1.     Processing PUTs to file
NJF1GET  EQU   X'01'  .... ...1     Processing GETs from file
*                     .... xx..     Available
*
NJFL2    DS    X                   Flag bits
NJFL3    DS    X                   Flag bits
NJFL4    DS    X                   Flag bits
*
*
*
*
NJESA    DS    18F                     NJESPOOL OS save area            NJE00300
NJEDIRSA DS    18F                     NJEDIR   OS save area            NJE00300
*
         DS    0D                      Force doubleword size
NJEWKSZ  EQU   *-NJEWK
*                                                                       NJE00930
*
BLKONE   DSECT                      ** Maps block #1 in NETSPOOL
DIRBLK   DS    F                       Block number of current directry
ALMBLK   DS    F                       Block number of allocation map
MAXBLK   DS    F                       Highest block number in NETSPOOL
SPLNUM   DS    F                       Last assigned spool file #
BLKONESZ EQU   *-BLKONE                Size of dsect
*                                                                       NJE00930
*
TYPPRT   EQU   X'40'                PRT dev
TYPPUN   EQU   X'80'                PUN dev
         COPY  NETSPOOL
         COPY  TAG
*
         IFGACB
         IFGRPL
*
         END   NJESPOOL                                                 NJE01000
./ ADD NAME=NJESYS
*
*
*-- NJE38 - Locate NJE38 information from an ENQ resource
*
*
*   Called by NJEINIT,NJERCV,NJETRN,NJE38,NJ38XMIT,NJ38RECV
*
*
* Change log:
*
* 01 Oct 20 - Initial creation                                     v210
*
*
         GBLC  &VERS
         REGEQU
NJESYS   CSECT
         NJEVER
         STM   R14,R12,12(R13) Save regs
         LR    R12,R15
         USING NJESYS,R12
*
*-- Determine if NJE38 is already active in another address space
*
CHK000   EQU   *
         L     R2,16           Get CVT ptr
         USING CVT,R2
         LA    R2,CVTFQCB      -> ENQ QCB chain anchor
         USING QCB,R2
*
CHK010   EQU   *
         ICM   R2,15,MAJNMAJ   -> next major QCB
         BZ    CHK080          Our guy not found
         CLC   MAJNAME,NJE38Q  Look for our QNAME "NJE38"
         BNE   CHK010          Nope, go to next QCB
*
         L     R3,MAJFMIN      -> first minor QCB
         USING MIN,R3
*
CHK020   EQU   *
         LA    R4,MINNAME      -> minor name
         CLC   NJERCON,0(R4)   Does minor name match?
         BE    CHK030          Yes. NJE38 is active
         C     R3,MAJLMIN      Is this the last minor QCB?
         BE    CHK080          Yes, we're done. NJE38 is not active
         ICM   R3,15,MINNMIN   -> next minor name
         BZR   R14             Just in case no address
         B     CHK020          Spin through the minor QCBs
*
CHK030   EQU   *
         LTR   R1,R1           Store spool DSN?
         BZ    CHK040          No
         MVC   0(44,R1),12(R4) Save off NETSPOOL dsname
*
CHK040   EQU   *
         L     R1,8(,R4)       Get CSABLK ptr from QCB minor
         SR    R15,R15         RC=0, ENQ data was found
         B     CHK090
*
CHK080   EQU   *
         LA    R15,4           RC=4, no ENQ located
*
CHK090   EQU   *
         ST    R1,24(,R13)     Return R1 value
         ST    R15,16(,R13)    Return R15 RC
*
         LM    R14,R12,12(R13) Reload regs
         BR    R14             Return
*
         DS    0D
NJE38Q   DC    CL8'NJE38'
NJERCON  DC    CL8'NJEINIT'
*
         LTORG ,
*
         CVT   DSECT=YES,PREFIX=NO
         IHAQCB
*
         END
./ ADD NAME=NJETRN
*
*-- NJE38 - TSO TRANSMIT
*
*   Command line format:
*
*   TRANSMIT node.userid
*            DATASET( )
*            OUTDATASET( )
*            VOLSER( )
*            UNIT( )
*            PDS | SEQUENTIAL
*            QUIET
*
*   where:
*
*    node.userid    - specifies the destination of the transmission
*
*    DATASET( )     - specifies the dsname of the dataset to be
*                     transmitted.  May optionally specify a member.
*
*    OUTDATASET( )  - optional. Specifies the encoded file is to be
*                     written to this dataset instead of being
*                     transmitted.  'node.userid' may be omitted if
*                     OUTDATASET is specified, but if it is present
*                     then the specified node and userid will be part
*                     of the encoded data instead of meaningless
*                     defaults. If OUTDATASET is specified, the
*                     named dataset will be used if it exists, other-
*                     wise it will be created.
*                     The contents of OUTDATASET can be input to a
*                     RECEIVE command by the use of RECEIVE INDATASET.
*
*    VOLSER( )      - optional. Specifies a volume where OUTDATASET
*                     should be created.  If not specified, a PUBLIC
*                     volume will be selected.
*
*    UNIT( )        - optional. Specifies a unit name where OUTDATASET
*                     should be created.  If not specified, SYSDA is
*                     the default unit name.
*
*    PDS            - If specified, indicates that the member name
*                     specified with DATASET is to be transmitted
*                     with IEBCOPY unload, thereby preserving the
*                     user directory data in the source PDS.
*
*    SEQUENTIAL     - DEFAULT. Indicates that any member name specified
*                     with DATASET is to be transmitted as a sequential
*                     file; no directory information is part of the
*                     transmission. SEQL must be specified or defaulted
*                     if the destination host is a VM system.
*
*    QUIET          - If specified, indicates that all informational
*                     messages from TRANSMIT are suppressed.  Error
*                     messages will always be displayed.
*
*
*    Examples (a user is logged on to TSO with userid FRED:
*
*    1. Send member COBSRC from FRED.MY.PDS to user HERC01 at
*       node MVSA.  The directory information associated with COBSRC
*       is to be part of the transmission:
*
*       TRANSMIT mvsa.herc01 da(my.pds(cobsrc)) pds
*
*    2. Encode dataset HERC02.COBOL.LISTING into FRED.NETLIB:
*
*       TRANSMIT da('herc02.cobol.listing') out(netlib)
*
*    3. Send macro GETQ from FRED.MACLIB to CMSUSER at VMSYS1.
*
*       TRANSMIT vmsys1.cmsuser da(maclib(getq))
*
*
* Change log:
*
* 24 Apr 21 - Use TSO userid as default user if no security and    v222
*              NJE38 is not active.                                v222
* 15 Feb 21 - Not picking up jobname when run as an STC.           v221
* 10 Dec 20 - Support for registered users and message queuing     v220
* 01 Oct 20 - Put ENQ existence check in common module             v210
* 09 Aug 20 - Improve TSO attention key handling                   v201
* 24 Jul 20 - Fix S013-18 if DATASET member not found              v200
* 15 Jul 20 - Don't display final record count.                    v200
* 12 Jul 20 - Add support for the UNIT parameter.                  v200
* 21 Jun 20 - Initial creation
*
*
         GBLC  &VERS
         REGEQU
NJETRN   CSECT                                                          NJE00020
         NJEVER
         STM   R14,R12,12(R13)         Save Regs                        NJE00050
         LR    R12,R15                 Base                             NJE00060
         USING NJETRN,R12                                               NJE00070
         LR    R8,R1                   Copy input parm addr
*
         GETMAIN RU,                   Get local stg area              X
               LV=4096,                                                X
               BNDRY=PAGE
         LR    R10,R1
         LR    R1,R0                   Copy length
         LR    R2,R0                   Copy length
         LR    R0,R10                  -> new stg area
         SR    R15,R15                 set pad
         MVCL  R0,R14                  Clear the page
*
         USING NJEWK,R10
         ST    R13,NJESA+4             SAVE prv S.A. ADDR               NJE00080
         LA    R1,NJESA                -> my save area
         ST    R1,8(,R13)              Plug it into prior SA
         LR    R13,R1
*
         MVC   NJEEYE,=CL4'NJET'       Work area eyecatcher
         ST    R2,NJEWKLEN             Save size of area in area
         L     R11,=A(NJECOM)          -> common csect
         USING NJECOM,R11
         ST    R8,CPARMS               Save ptr to input parms
         MVC   LCLNODE,=CL8'ORIGNODE'  Set default local node
         MVC   DESTNODE,=CL8'DESTNODE'  Set default
         MVC   DESTUSER,=CL8'DESTUSER'  Set default
         MVC   PBREM,=F'80'            Initialize
         LA    R1,REC                  -> output record area
         ST    R1,PBRPS                Initialize
*
INIT000  EQU   *
         MVC   MACLIST(ESTAEL),ESTAE   Move ESTAE parm list
         L     R6,=A(NJEDMP)           Point to local ESTAE rtn
         ESTAE (R6),                   Issue ESTAE                     X
               CT,                                                     X
               TERM=YES,                                               X
               PARAM=(R10),            PARAM is work area address      X
               MF=(E,MACLIST)
*
*-- Establish TSO userid issuing this command
*
         TESTAUTH FCTN=1               Are we authorized on entry?
         LTR   R15,R15                 Check result
         BNZ   INIT010                 Branch if not authorized
         OI    FLAGS1,F1APF            Indicate authorized on entry
*
INIT010  EQU   *
         L     R2,PSATOLD-PSA(0)       -> my TCB
         L     R2,TCBTIO-TCB(R2)       -> my TIOT
         LA    R4,TIOCNJOB-IEFTIOT(R2) -> TIOT jobname             v222
         LR    R3,R4                   Assume will use jobname     v222
*
         L     R2,PSAAOLD-PSA(0)       -> my ASCB
         L     R6,ASCBTSB-ASCB(,R2)    -> TSB (or 0)
         L     R2,ASCBASXB-ASCB(,R2)   -> my ASXB
         ICM   R2,15,ASXBSENV-ASXB(R2) -> my ACEE
         BZ    INIT015                 Exit if no ACEE
*
         USING ACEE,R2
         CLI   ACEEUSRL,X'00'          No userid available?
         BE    INIT015                 Exit if unavail
         CLI   ACEEUSR,X'00'           Userid not formed correctly?
         BE    INIT015                 Exit if unavail
         LA    R3,ACEEUSR              -> Userid
         OI    FLAGS1,F1ACEE           Valid ACEE found
         CLC   ACEEUSR,=CL8'STC'       Is this a started task?     v221
         BNE   INIT015                 No, use ACEEUSR id          v221
         LR    R3,R4                   Make the TIOT jobname the idv221
         DROP  R2                      ACEE
*
INIT015  EQU   *
         MVC   USERID,0(R3)            Set the userid
         TM    FLAGS1,F1APF            Authorized at entry?
         BO    INIT040                 yes.
         CLC   USERID,=CL8'HERC01'     Special access id?
         BE    INIT020                 Yes
         CLC   USERID,=CL8'HERC02'     Special access id?
         BNE   INIT030                 No
*
INIT020  EQU   *
         OI    FLAGS1,F1AUSR           Indicate special authorized user
         SR    0,0                     Use authorization SVC
         LA    1,1                      For TK4- HERC01/HERC02 only
         SVC   244                     Get authorized
         B     INIT040
*
INIT030  EQU   *
         TM    FLAGS1,F1APF            Authorized at entry?
         BZ    ERR006                  No, issue error
*
INIT040  EQU   *
         LA    R6,0(,R6)               Clear high order byte
         LTR   R6,R6                   Was there a TSB address
         BNZ   INIT050                 There was. Running in TSO userid
         OI    FLAGS1,F1BATCH          Indicate batch TSO
         TM    FLAGS1,F1ACEE           Valid ACEE found?
         BO    INIT050                 Yes, go with ACEE userid
         BAL   R2,CHK000               See if NJE38 is active      v210
         BNZ   INIT050                 NJE38 not act; use jobname  v222
         MVC   USERID,DEFUSER          Use default userid
*
INIT050  EQU   *
         L     R2,4(,R8)               -> UPT from input parms
         USING UPT,R2
         MVC   PREFIX,BLANKS           Init receiving field
         SR    R1,R1                   Clear for IC
         ICM   R1,1,UPTPREFL           Get prefix length
         BZ    INIT060                 No prefix value in use
         BCT   R1,*+10                 Adjust for execute
         MVC   PREFIX(0),UPTPREFX      executed instr
         EX    R1,*-6                  Copy the prefix value
         DROP  R2                      UPT
*
INIT060  EQU   *
         MVC   STAXLIST(STAXL),STAX    Move STAX parm list
         LA    R5,LIST                 -> input buffer from attn
         LA    R6,STAXXIT              Point to local exit
         STAX  (R6),                   Set exit for attention          X
               OBUF=(ATTNMSG,L'ATTNMSG),                               x
               IBUF=((5),80),                                          x
               USADDR=(10),            Parameter is our work area      x
               MF=(E,MACLIST)
*
*-- Parse command line
*
         SR    R0,R0                   Code 0: parse command line
         L     R15,=A(NJEPAR)          -> parse routine
         BALR  R14,R15
*
         TM    FLAGS1,F1ATTN           Was ATTN pressed?           v201
         BO    EXIT08                  Y, immediate exit           v201
*
         B     INIT070(R15)            Branch into table on RC
INIT070  B     INIT080                 Continue
         B     ERR004                  No parameters entered
         B     ERR005                  Invalid node.user entered
         B     ERR001                  Display IJKPARS RC
*
INIT080  EQU   *
         LA    R2,MSG000               Issue hello msg
         BAL   R14,PUTLINE
         LA    R2,MSGBLNK              Issue blank line
         BAL   R14,PUTLINE
*
*-- Check if we have the required parameters:
*
*-- 1. DATASET is required.  No exceptions.
*-- 2. Either one of:
*--    a.  OUTDATASET, or,
*--    b.  node.userid
*-- 3. If node.user specified, we need NJE38 to be active.
*
         TM    FLAGS3,F3INDS           Was DATASET specified?
         BZ    ERR002                  N, it is required
         TM    FLAGS3,F3OUTDS          Was OUTDATASET specified?
         BO    INIT090                 Y, we don't need NJE38
         TM    FLAGS3,F3DEST           Do we have a node.user?
         BZ    ERR011                  No, bail out.
*
         BAL   R2,CHK000               Determine NJE38 status      v210
         BNZ   ERR013                  NJE38 is not active         v210
*
*-- Set up user selected input dataset
*
*-- 1. Dynamically allocate it (also return DSORG and VOLSER).
*-- 2. OBTAIN the DSCB for the dataset to get DCB attributes.
*-- 3. Use DEVTYPE and TRKCALC along with the DSCB last used TTR to
*--    determine how many blocks were used in the dataset.
*-- 4. If it was a PDS, count the number of directory blocks.
*
INIT090  EQU   *
         MVC   TDSNAME,INPUTDS         Set DSNAME of user dataset
         MVC   TMEMBER,INMEM           Set member name (or null)
*
         LA    R0,DYNINDS         24   allocate input dataset
         L     R15,=A(NJEDYN)          -> dynamic allocation rtns
         BALR  R14,R15
         LTR   R15,R15                 Any errors?
         BNZ   EXIT08                  Exit if allocation error
         TM    TDSORG,X'42'            Is it DSORG=PO/PS ?
         BZ    ERR003                  No, can't support it
*
         MVC   DDSYSUT1,TDDNAME        Save off the DDNAME returned
         TM    FLAGS3,F3PDS            Was PDS forced?
         BO    INIT100                 Y, use IEBCOPY instead of PS mbr
         TM    FLAGS3,F3INMEM          Was a member name specified?
         BZ    INIT100                 No, DSORG is what it is
         MVC   TDSORG,=X'4000'         Member makes it DSORG=PS
*
INIT100  EQU   *
         XC    CAMWORK,CAMWORK         Init CAMLST work area
         MVC   CAMLST,DMYLST           Move dummy CAMLST to area
         LA    R1,CAMLST               -> CAMLST
         LA    R4,TDSNAME              -> DATASET NAME
         ST    R4,4(,R1)               Put in CAMLST
         LA    R4,TVOLSER              -> VOLSER
         ST    R4,8(,R1)               Put in CAMLST
         LA    R4,CAMWORK              -> AT WORK AREA
         ST    R4,12(,R1)              Put in CAMLST
*
         OBTAIN (1)                    Get the format 1 DSCB
         LA    R4,CAMWORK-44           -> DSCB we obtained (less DSN)
         USING DSCBF1,R4
         LTR   R15,R15                 SUCCESSFUL?
         BNZ   ABEND101                No
*
INIT110  EQU   *
         LA    R7,INMF02A              -> first INMR02 data items
         USING INMFIELD,R7
         MVC   DSORG,TDSORG            Set DSORG
         SR    R0,R0                   Clear for IC
         ICM   R0,3,DS1BLKL
         ST    R0,BLKSIZE              Set BLKSIZE
         ICM   R0,3,DS1LRECL
         ST    R0,LRECL                Set LRECL
         MVC   RECFM,DS1RECFM          Set RECFM
         MVC   DSNAME,INPUTDS          Set DSNAME
         MVC   UTLNAME,=CL8'INMCOPY'   Assume utility is sequential cpy
         TM    DSORG,X'40'             Is DSORG=PS?
         BO    INIT120                 Yes
         MVC   UTLNAME,=CL8'IEBCOPY'   Utility is for partitioned
*
*
INIT120  EQU   *
         DEVTYPE TDDNAME,DEVINFO,DEVTAB  Get device info
         LTR   R15,R15                 Success?
         BNZ   ABEND102                No
*
INIT130  EQU   *
         MVC   MACLIST(TRKCALCL),TRKCALC  Move macro model
         TRKCALC FUNCTN=TRKCAP,      Calc track capacity for this blkszX
               REGSAVE=YES,          Save all regs                     X
               TYPE=DEVUCBTY+3,      Point to device type byte         X
               R=1,                  Record 1 = calc for entire track  X
               K=0,                  No Keys                           X
               DD=DS1BLKL,           Use the BLKSIZE from DSCB         X
               MF=(E,MACLIST)        R0 = # blks per track on exit
*
*
         SR    R1,R1                   Clear
         L     R3,BLKSIZE              Get current block size
         MR    R2,R0                   Compute bytes per track
         SR    R1,R1                   Clear
         ICM   R1,3,DS1LSTAR           Get TT of last used TTR
         LA    R1,1(,R1)               One extra for partial last track
         MR    R2,R1                   Compute approx bytes in file
         ST    R3,FILESIZE             Set approx file size in bytes
         DROP  R4                      DSCBF1
*
*-- If input dataset is a PDS, count the number of directory blocks.
*-- Then, use IEBCOPY to unload the PDS into a sequential file.
*
         TM    DSORG,X'40'             Is DSORG=PS?
         BO    OUT000                  Y, done with input dataset
*
         OI    FLAGS1,F1INPDS          INDS is a PDS dataset
         MVC   INDS(DMYINDSL),DMYINDS  Set up DCB
         LA    R6,INDS                 -> DCB
         USING IHADCB,R6
         MVC   DCBDDNAM,DDSYSUT1       Set DCB DDNAME
         MVC   DCBBLKSI,=Y(256)        Set up to read dir blocks
         MVC   DCBLRECL,=Y(256)        Set up to read dir blocks
         MVI   DCBRECFM,DCBRECF        RECFM=F
         LA    R1,INIT150              -> temporary EOF addr
         ST    R1,DCBEODAD             Set it
         DROP  R6
*
         MVC   MACLIST(OPENL),OPEN     Move OPEN list
         OPEN  (INDS,INPUT),           Open the input dataset          X
               MF=(E,MACLIST)
         OI    FLAGS2,F2INOPN          Indicate DCB is open
         SR    R2,R2                   Init directory blocks counter
*
INIT140  EQU   *
         GET   INDS                    Get a dir block
         LA    R2,1(,R2)               Count it
         B     INIT140
*
INIT150  EQU   *
         ST    R2,DIRBLKS              Set DIRBLKS value
         TM    FLAGS2,F2INOPN          Is INDS DCB open?
         BZ    UNLD000                 No
         MVC   MACLIST(CLOSEL),CLOSE   Move close list
         CLOSE (INDS),                 Close it                        X
               MF=(E,MACLIST)
         NI    FLAGS2,255-F2INOPN      Indicate DCB is closed
*
*-- If DATASET is a PDS, prepare to call IEBCOPY to unload it.
*
*-- 1. Create sequential dataset for IEBCOPY to unload into.
*-- 2. Allocate other required IEBCOPY datasets.
*-- 3. If user specified a member name in DATASET, build IEBCOPY
*--    control statements.
*-- 4. Invoke IEBCOPY to unload the entire PDS or single member.
*
UNLD000  EQU   *
         LA    R6,INMF02A              -> 1st INMR02 record
         LA    R7,INMF02B              -> 2nd INMR02 record
         USING INMFIELD,R7
*
*-- Filling dynamic allocation text units for unload PS dataset
*
         LA    R1,3120                 Use 3120 for IEBCOPY SYSUT2
         STH   R1,TBLKSIZE             Set dynalloc block size
         STCM  R1,7,TBLKLEN            Set dynalloc space blk len
*
         L     R3,FILESIZE-INMFIELD(R6) Get INDS size
         ST    R3,FILESIZE             Use as temporary DS size
         SR    R2,R2                   Clear for divide
         DR    R2,R1                   Compute # blocks needed
         LA    R3,1(,R3)               Always round up
         LR    R1,R3                   Return primary blocks in R1
         SRL   R3,2                    Compute 1/4th of needed amt
         LA    R2,1(,R3)               Round up = secondary blks needed
*
         STCM  R1,7,TPRIME             Set primary space in blocks
         STCM  R2,7,TSECND             Set secondary space in blocks
*
         MVC   TDSORG,=X'4000'         Always PS
*
*
*-- Call NJEDYN to allocate the unload output dataset as "SYSUT2"
*
         LA    R0,DYNUNLD         10   allocate unload dataset
         L     R15,=A(NJEDYN)          -> dynamic allocation rtns
         BALR  R14,R15
*
         B     UNLD020(R15)            Branch on RC
UNLD020  B     UNLD040             00  Normal, proceed
         B     EXIT08              04  Dataset exists, shouldnt happen
         B     EXIT08              08  All other errors
*
*-- Prepare to launch IEBCOPY
*
UNLD040  EQU   *
         MVC   DDSYSUT2,TDDNAME        Set replacement SYSUT2 DD
*
*-- Call NJEDYN to allocate the SYSIN dataset needed by IEBCOPY
*
         LA    R0,DYNSYSIN        08   allocate SYSIN for IEBCOPY
         L     R15,=A(NJEDYN)          -> dynamic allocation rtns
         BALR  R14,R15
         LTR   R15,R15
         BNZ   EXIT08                  Exit with dynalloc error
         MVC   DDSYSIN,TDDNAME         Save generated DDNAME
*
*-- Call NJEDYN to allocate the SYSPRINT dataset needed by IEBCOPY
*
         LA    R0,DYNSYSPR        12   allocate SYSPRINT for IEBCOPY
         L     R15,=A(NJEDYN)          -> dynamic allocation rtns
         BALR  R14,R15
         LTR   R15,R15
         BNZ   EXIT08                  Exit with dynalloc error
         MVC   DDSYSPR,TDDNAME         Save generated DDNAME
*
*-- Call NJEDYN to allocate the SYSUT4 dataset needed by IEBCOPY
*
         LA    R0,DYNSYSU4        14   allocate SYSUT4 temporary
         L     R15,=A(NJEDYN)          -> dynamic allocation rtns
         BALR  R14,R15
         LTR   R15,R15
         BNZ   EXIT08                  Exit with dynalloc error
         MVC   DDSYSUT4,TDDNAME        Set replacement SYSUT4 DD
*
         TM    FLAGS3,F3INMEM          Was a member name specified?
         BZ    UNLD080                 No, skip ctl card build
         BAL   R14,CTL000              Build IEBCOPY control statements
*
*-- Invoke IEBCOPY
*
UNLD080  EQU   *
         MVC   CPYPLIST,COPYPARM       Move IEBCOPY parms to 24-bit stg
         MVC   DDLISTL,=AL2(DDLISTSZ)  Set IEBCOPY DD list length
         LA    R2,CPYPLIST
         LA    R3,DDLISTL
         MVC   MACLIST(LINKL),LINK     Move macro model
         LINK  EP=IEBCOPY,                                             x
               PARAM=((R2),(R3)),                                      x
               VL=1,                                                   x
               MF=(E,MACLIST)
         LTR   R5,R15                  Copy RC to R5
         BNZ   ERR018                  Exit on error
*
*-- Find out what we can about the IEBCOPY unloaded dataset
*
*-- 1. OBTAIN the DSCB for the dataset to get DCB attributes.
*-- 2. Use DEVTYPE and TRKCALC along with the DSCB last used TTR to
*--    determine how many blocks were used in the dataset.
*
UNLD100  EQU   *
         XC    CAMWORK,CAMWORK         Init CAMLST work area
         MVC   CAMLST,DMYLST           Move dummy CAMLST to area
         LA    R1,CAMLST               -> CAMLST
         LA    R4,TDSNAME              -> DATASET NAME
         ST    R4,4(,R1)               Put in CAMLST
         LA    R4,TVOLSER              -> VOLSER
         ST    R4,8(,R1)               Put in CAMLST
         LA    R4,CAMWORK              -> AT WORK AREA
         ST    R4,12(,R1)              Put in CAMLST
*
         OBTAIN (1)                    Get the format 1 DSCB
         LA    R4,CAMWORK-44           -> DSCB we obtained (less DSN)
         USING DSCBF1,R4
         LTR   R15,R15                 SUCCESSFUL?
         BNZ   ABEND103                No
*
UNLD110  EQU   *
         LA    R7,INMF02B              -> 2nd INMR02 data items
         USING INMFIELD,R7
         MVC   DSORG,TDSORG            Set DSORG
         SR    R0,R0                   Clear for IC
         ICM   R0,3,DS1BLKL
         ST    R0,BLKSIZE              Set BLKSIZE
         ICM   R0,3,DS1LRECL
         ST    R0,LRECL                Set LRECL
         MVC   RECFM(1),DS1RECFM       Set RECFM
         MVI   RECFM+1,X'02'           Indicate shortened variable fmt
         XC    DSNAME,DSNAME           No DSNAME in INMR02B
         MVC   UTLNAME,=CL8'INMCOPY'   Utility is sequential cpy
*
*
UNLD120  EQU   *
         DEVTYPE TDDNAME,DEVINFO,DEVTAB  Get device info
         LTR   R15,R15                 Success?
         BNZ   ABEND104                No
*
UNLD130  EQU   *
         MVC   MACLIST(TRKCALCL),TRKCALC  Move macro model
         TRKCALC FUNCTN=TRKCAP,      Calc track capacity for this blkszX
               REGSAVE=YES,          Save all regs                     X
               TYPE=DEVUCBTY+3,      Point to device type byte         X
               R=1,                  Record 1 = calc for entire track  X
               K=0,                  No Keys                           X
               DD=DS1BLKL,           Use the BLKSIZE from DSCB         X
               MF=(E,MACLIST)        R0 = # blks per track on exit
*
*
         SR    R1,R1                   Clear
         L     R3,BLKSIZE              Get current block size
         MR    R2,R0                   Compute bytes per track
         SR    R1,R1                   Clear
         ICM   R1,3,DS1LSTAR           Get TT of last used TTR
         LA    R1,1(,R1)               One extra for partial last track
         MR    R2,R1                   Compute approx bytes in file
         ST    R3,FILESIZE             Set approx file size in bytes
         DROP  R4                      DSCBF1
*
*-- Prep OUTDATASET if specified
*
*--  Determine if it exists,
*--   If yes, DSORG must be PS unless OUTDS member coded.
*--   If no, create it, 3120/80/FB,
*--      and create as PDS if user specified a OUTDS member, else SEQL,
*--      using estimated file size from input dataset.
*
OUT000   EQU   *
         TM    FLAGS3,F3OUTDS          Did user specify OUTDATASET?
         BZ    OPN000                  No, transmit to NETSPOOL
*
OUT200   EQU   *
         MVC   CAMLST,LOCATLST         Move modem CAMLST
         XC    BUFF,BUFF               Clear sufficient camlst workarea
         XC    REC,REC                 Clear more
         LA    R1,CAMLST               -> CAMLST
         LA    R2,OUTPUTDS             -> DATASET name
         ST    R2,4(,R1)               Place in CAMLST
         LA    R2,CAMWORK              -> CAMLST work area
         ST    R2,12(,R1)              Place in CAMLST
*
         LOCATE (1)                    Does dataset exist?
         LTR   R15,R15                 Any errors?
         BNZ   OUT240                  Yes, dataset doesn't exist
         OI    FLAGS2,F2EXIST          Indicate OUTDATASET exists
*
*-- Find out about this existing OUTDATASET
*
OUT210   EQU   *
         LA    R4,CAMWORK              -> CAMLST work area
         USING VOLLIST,R4              Address the volume list
         MVC   TVOLSER,VOLSER          Save off the volume
         DROP  R4                      VOLLIST
*
         XC    CAMWORK,CAMWORK         Init CAMLST work area
         MVC   CAMLST,DMYLST           Move dummy CAMLST to area
         LA    R1,CAMLST               -> CAMLST
         LA    R4,OUTPUTDS             -> DATASET NAME
         ST    R4,4(,R1)               Put in CAMLST
         LA    R4,TVOLSER              -> VOLSER
         ST    R4,8(,R1)               Put in CAMLST
         LA    R4,CAMWORK              -> AT WORK AREA
         ST    R4,12(,R1)              Put in CAMLST
*
         OBTAIN (1)                    Get the format 1 DSCB
         LA    R4,CAMWORK-44           -> DSCB we obtained (less DSN)
         USING DSCBF1,R4
         LTR   R15,R15                 SUCCESSFUL?
         BNZ   ABEND105                No
*
OUT220   EQU   *
         TM    DS1DSORG,X'40'          Is it a Seql dataset?
         BO    OUT230                  Yes
         TM    DS1DSORG,X'02'          Is it a PDS dataset?
         BZ    ERR007                  No, error; must be PS or PO
         TM    FLAGS3,F3OUTMEM         Did user also code member name?
         BZ    ERR008                  N, mem req'd if PO
         B     OUT250                  Y, proceed with allocation
*
*-- Whether OUTDATASET existed or not, ignore any member name
*-- coded on OUTDATASET if the dataset is PS.
*
OUT230   EQU   *
         NI    FLAGS3,255-F3OUTMEM     Ignore any user member name
         B     OUT250                  And go allocate it
*
*-- OUTDATASET didn't exist, prepare to create it
*
OUT240   EQU   *
         LA    R2,3120                 3120 = NETDATA output blksize
         STH   R2,TBLKSIZE             Set per NETDATA std
         STCM  R2,7,TBLKLEN            Set per NETDATA std
         MVC   TLRECL,=H'80'           Set per NETDATA std
         MVI   TRECFM,X'90'            Set FB per NETDATA std
         MVC   TDSORG,=X'4000'         Set PS per NETDATA std
         SR    R0,R0                   Clear for divide
         L     R1,FILESIZE             Get # bytes in input file
         DR    R0,R2                   Compute # of 3120 blks needed
*
         LR    R2,R1                   Copy # blks needed
         SRA   R1,3         div by 8   Compute 12% for NETDATA overhead
         AR    R1,R2                   Get # blks + 12%
         STCM  R1,7,TPRIME             Set # primary space blocks
         SRA   R2,2         div by 4   Compute 25% for secondary
         STCM  R2,7,TSECND             Set # secondary space blocks
*
OUT250   EQU   *
         MVC   TDSNAME,OUTPUTDS        Set DSNAME for allocation
         MVC   TMEMBER,OUTMEM          Set possible member name
         MVC   TVOLSER,OUTVOL          Set possible volser override
*
         LA    R0,DYNOUTDS        32   allocate OUTDATASET
         L     R15,=A(NJEDYN)          -> dynamic allocation rtns
         BALR  R14,R15
         LTR   R15,R15                 Any errors?
         BNZ   EXIT08                  Exit if allocation error
*
         MVC   DDOUTDS,TDDNAME         Save DD returned
         MVC   OUTDS(DMYOUTDL),DMYOUTDS Set up DCB
         LA    R6,OUTDS                -> DCB
         USING IHADCB,R6
         MVC   DCBDDNAM,DDOUTDS        Set DCB DDNAME
         DROP  R6                      IHADCB
*
         MVC   MACLIST(OPENL),OPEN     Move OPEN list
         OPEN  (OUTDS,OUTPUT),         Open the OUTDATASET             X
               MF=(E,MACLIST)
         OI    FLAGS2,F2OUTOPN         Indicate DCB is open
         B     TRN000                  Start transmitting to OUTDATASET
*
*-- Open NETSPOOL if not using OUTDATASET
*
OPN000   EQU   *
         BAL   R2,CHK000               Determine NJE38 status      v210
         BNZ   ERR013                  NJE38 is not active         v210
*
         MVC   DDNETSPL,=CL8'NETSPOOL' Set NETSPOOL DDN (for unalloc)
         MVC   TDDNAME,DDNETSPL        NETSPOOL DD
         MVC   TDSNAME,SPLDSN          Set spool DSN
         LA    R0,DYNETSPL        28   allocate NETSPOOL
         L     R15,=A(NJEDYN)          -> dynamic allocation rtns
         BALR  R14,R15
         LTR   R15,R15
         BNZ   EXIT08                  Exit with dynalloc error
*
         LA    R8,NCB1                 -> NCB
         USING NCB,R8
         MVI   NCBFL1,TYPPUN           Only outputting punch type recs
*
         NSIO  TYPE=OPEN,                                              x
               NCB=(R8)
         C     R15,=F'4'               NETSPOOL needs verify?
         BE    ERR025                  Yes
         BL    OPN010                  Everything is good
         BAL   R14,FMT000              Display Open error
         CLC   NCBRTNCD(2),=AL1(8,152) X'0898' Security denied access?
         BE    ERR014                  Yes, special message
         B     EXIT08                  Exit on VSAM error
*
OPN010   EQU   *
         OI    FLAGS2,F2NCBOPN         Indicate NETSPOOL is open
*
*-- Create the NETDATA and transmit the results to the destination
*-- node, or store it in the OUTDATASET.
*
*-- DDNAME setup below at TRN000 may look confusing.  To explain:
*-- The NETDATA is always built from a sequential dataset.  So the
*-- INDS DCB here represents either the original user specified
*-- input DATASET -or - the IEBCOPY unloaded sequential dataset from
*-- the original PDS.
*
*-- If the original was sequential, it is already allocated at the
*-- DDSYSUT1 ddname.
*-- If the original was a PDS, then the IEBCOPY unload dataset is
*-- allocated at the DDSYSUT2 ddname.
*
*
TRN000   EQU   *
         MVC   INDS(DMYINDSL),DMYINDS  Set up DCB
         LA    R6,INDS                 -> DCB
         USING IHADCB,R6
         MVC   DCBDDNAM,DDSYSUT2  PDS: Set DCB DDNAME (iebcopy UNLD DD)
*
         TM    FLAGS1,F1INPDS          Is input dataset a PDS?
         BO    TRN210                  Yes
         MVC   DCBDDNAM,DDSYSUT1  SEQ: Set DCB DDNAME (input DS DD)
*
TRN210   EQU   *
         MVC   MACLIST(OPENL),OPEN     Move OPEN list
         OPEN  (INDS,INPUT),           Open the input dataset          X
               MF=(E,MACLIST)
         OI    FLAGS2,F2INOPN          Indicate DCB is open
         DROP  R6                      IHADCB
*
TRN220   EQU   *
         L     R15,=A(NJENET)          -> NETDATA build and write
         BALR  R14,R15                 Go write NETDATA
         LTR   R15,R15                 Any errors?
         BNZ   ERR010                  Write i/o error
*
TRN300   EQU   *
         TM    FLAGS2,F2NCBOPN         Was spool open?
         BZ    TRN350                  No
*
         L     R5,16                   -> CVT
         L     R5,CVTSMCA-CVT(,R5)     -> SMCA
         LA    R5,SMCASID-SMCABASE(,R5) -> system id
*
*-- Fill in the tag data to satisfy the DMTXJE RSCS line driver used
*-- by NJE38.
*
TRN310   EQU   *
         LA    R6,TAGDATA              -> tag data area
         USING TAG,R6
*
         STCK  TAGINTOD                Time of spool file creation
*
         MVC   TAGDEV,=X'000C'         Pseudo card rdr CUU
         MVC   TAGINLOC,LCLNODE        Local node name of origin
         MVC   TAGINVM,USERID          Userid of origin
         MVC   TAGRECNM,OUTRECS        # of records written
         MVC   TAGRECLN,=Y(80)         Move record length
         MVI   TAGINDEV,TYPPUN         data type (PRT/PUN)
         MVC   TAGCLASS,=C'A'          Spool class
         MVC   TAGCOPY,=H'1'           # copies
         MVC   TAGNAME,BLANKS          Init receiving field
         MVC   TAGNAME(8),USERID       Insert userid
         MVC   TAGTYPE,=CL12'OUTPUT'
         MVC   TAGDIST,BLANKS          Init receiving field
         MVC   TAGDIST(4),0(R5)        Insert system id
         MVC   TAGTOLOC,DESTNODE       destination node
         MVC   TAGTOVM,DESTUSER        destination userid
         MVC   TAGPRIOR,=H'1'          priority
         DROP  R6                      TAG
*
TRN320   EQU   *
         NSIO  TYPE=CLOSE,             Close NETSPOOL                  x
               NCB=(R8),                                               x
               TAG=(R6)                Pass TAG data
         NI    FLAGS2,255-F2NCBOPN     Indicate NETSPOOL is closed
*
*-- Let NJE38 know that a new file was just placed into the spool so
*-- it can be queued for transmission.
*
         BAL   R2,CHK000               Determine NJE38 status      v210
         BNZ   TRN350                  NJE38 is not active         v210
         CLC   DESTNODE,LCLNODE        Trying to send file locally?
         BE    TRN350                  Y, but skip the POST
*
         LR    R7,R1                   -> NJE38 CSA ptr to R7      v210
         USING NJ38CSA,R7
*
         MODESET MODE=SUP,KEY=ZERO
*
         GETMAIN RU,                   Get CSA for WRE TYPE=WRENEW     x
               LV=WRESIZE,                                         v220x
               SP=241
         XC    0(WRESIZE,R1),0(R1)     Clear stg area              v220
         USING WRE,R1
         MVI   WRESP,241               Save subpool                v220
         MVI   WRETYPE,WRENEW          "New file in spool" WRE
         MVC   WRELINK,DESTNODE        Set destination node
         MVC   WREUSER,DESTUSER        Set destination userid
*
         LM    R2,R3,NJ38SWAP          Get first WRE ptr, sync count
TRN340   EQU   *
         ST    R2,WRENEXT              First WRE becomes next
         LR    R4,R1                   -> WRE to be added as first
         LA    R5,1(,R3)               Incr synchronization count
         CDS   R2,R4,NJ38SWAP          Update CSA WRE anchor, sync
         BC    7,TRN340                Gotta try again
*
         LA    R6,NJ38ECB              -> NJE38 external WRE ECB
         L     R7,NJ38ASCB             -> NJE38 ASCB
         DROP  R7                      NJ38CSA
*
         MVC   MACLIST(POSTL),POST     Move macro model
         POST  (6),                    Wake up NJE38 to new spool file x
               ASCB=(7),                                               x
               ERRET=TRN350,           Exit if can't do the post       x
               ECBKEY=0,                                               x
               MF=(E,MACLIST)
*
         MODESET MODE=PROB,KEY=NZERO
*
TRN350   EQU   *
*
*
*-- Transmission complete.  Issue # records sent and terminate.
*
*
TRN900   EQU   *
         LA    R2,MSGBLNK
         BAL   R14,PUTLINE             Write blank line
*
         MVC   LIST,BLANKS
*
*-- Record count not displayed until discrepancy with NJE counts   v200
*-- can be resolved.                                               v200
*                                                                  v200
*        L     R15,OUTRECS             # of output records written v200
*        CVD   R15,DBLE                unpk count                  v200
*        MVC   LIST+4(11),=X'2020206B2020206B202120'               v200
*        LA    R1,LIST+14              In case no significance     v200
*        EDMK  LIST+3(12),DBLE+3       Edit result                 v200
*        MVC   LIST+4(12),0(R1)        left justify displayed digitv200
*        TRT   LIST+4(12),BLANK        Look for end                v200
*        LA    R1,1(,R1)               Skip the blank              v200
         MVC   LIST+4(L'MSG009T),MSG009T Move 'file successfully'  v200
         LA    R1,LIST+L'MSG009T+4     -> next available byte      v200
*
         TM    FLAGS3,F3OUTDS          Using OUTDATASET?
         BO    TRN910
         MVC   0(10,R1),=C'queued to '
         MVC   10(8,R1),DESTNODE
         TRT   10(9,R1),BLANK          Look for end of node id
         MVI   0(R1),C'.'              Set dot
         MVC   1(8,R1),DESTUSER        Move userid
         LA    R1,9(,R1)               -> next available byte
         B     TRN920
*
TRN910   EQU   *
         MVC   0(12,R1),=C'written to '''
         MVC   12(44,R1),OUTPUTDS      Move OUTDATASET name
         TRT   12(45,R1),BLANK         Look for end of DSN
         MVI   0(R1),C''''             Set dot
         LA    R1,1(,R1)               -> next available byte
*
TRN920   EQU   *
         LA    R2,LIST                 -> msg
         MVC   0(4,R2),MSG009          Move RDW and flags
         SR    R1,R2
         STH   R1,LIST                 Set updated RDW
         BAL   R14,PUTLINE
         B     EXIT00
*
*
*--Error routines
*
ERR001   EQU   *
         MVC   LIST(4+L'MSG001T),MSG001  Move msg to work area
         CVD   R15,DBLE                unpk IKJPARS RC
         UNPK  LIST+57(2),DBLE
         OI    LIST+58,X'F0'           Fix sign
         LA    R2,LIST                 -> msg
         B     ERRPUT
*
ERR002   EQU   *
         LA    R2,MSG002               Input dataset is required
         B     ERRPUT                  Write it
*
ERR003   EQU   *
         LA    R2,MSG003               Input dataset not PS or PO
         B     ERRPUT                  Write it
*
ERR004   EQU   *
         LA    R2,MSG004               No parameters entered on cmd lin
         B     ERRPUT                  Write it
*
ERR005   EQU   *
         LA    R2,MSG005               Invalid node.user specified
         B     ERRPUT                  Write it
*
ERR006   EQU   *
         LA    R2,MSG006               Not APF authorized
         B     ERRPUT
*
ERR007   EQU   *
         LA    R2,MSG008               OUTDATASET not SEQ or PDS
         B     ERRPUT
*
ERR008   EQU   *
         LA    R2,MSG008               OUTDATASET is PDS but no mem
         B     ERRPUT
*
ERR010   EQU   *
         MVC   LIST(4+L'MSG010T),MSG010  Move msg text
         LA    R1,=CL10'OUTDATASET'    Assume writing to OUTDATASET
         TM    FLAGS3,F3OUTDS          Using OUTDATASET?
         BO    *+8                     We are
         LA    R1,=CL10'NETSPOOL'      NO, its NETSPOOL
         MVC   LIST+4+L'MSG010T(9),0(R1)  Move source of error
         LH    R1,LIST                 Get current msg length
         LA    R1,10(,R1)              Add on the source length
         STH   R1,LIST                 Put back
         LA    R2,LIST                 Write i/o error on OUTDS/SPOOL
         B     ERRPUT
*
ERR011   EQU   *
         LA    R2,MSG011               No destination node.user
         B     ERRPUT
*
ERR013   EQU   *
         LA    R2,MSG013               NJE38 is not active
         B     ERRPUT
*
ERR014   EQU   *
         LA    R2,MSG014               Security denied NETSPOOL access
         B     ERRPUT
*
*-- Member not found in DATASET (come here from ESTAE 013-18)      v200
*
ERR015   EQU   *                                                   v200
         LA    R13,NJESA               Ensure using proper SA sincev200
*                                       we came here from ESTAE    v200
*
         MVC   LIST(4+L'MSG015T),MSG015 Member not found msg       v200
         MVC   LIST+11(8),INMEM        Plug missing member name    v200
*                                                                  v200
         LA    R2,LIST                 -> start of msg             v200
         B     ERRPUT                                              v200
*
*-- TRANSMIT ended because IEBCOPY failed
*
ERR018   EQU   *
         LA    R2,MSGBLNK              -> blank line msg
         BAL   R14,PUTLINE
*
         MVC   LIST(4+L'MSG018T),MSG018 IEBCOPY fail msg
         CVD   R5,DBLE                 Convert IEBCOPY RC
         UNPK  LIST+38(2),DBLE
         OI    LIST+39,X'F0'           Fix sign
*
         LA    R2,LIST                 -> start of msg
         B     ERRPUT                  Display failure
*
ERR025   EQU   *
         LA    R2,MSG025               Need to run VERIFY
         B     ERRPUT
*
ERRPUT   EQU   *
         BAL   R14,PUTLINE
         B     EXIT08
*
*****************
* EXIT FROM     *
* TRANSMIT      *
*****************
*
*
*
EXIT00   EQU   *
         SR    R15,R15                 Set RC=0
         B     XIT000                  Clean up and exit
*
EXIT08   EQU   *
         LA    R15,8                   Set RC=8
         B     XIT000                  Clean up and exit
*
XIT000   EQU   *
         LA    R13,NJESA               Ensure using proper SA in case
*                                       we've come here due to ESTAE
         LR    R5,R15                  Save RC across shutdown
         ESTAE 0                       Disable ESTAE
*
         TM    FLAGS2,F2INOPN          Is input dataset open?
         BZ    XIT010                  No
         MVC   MACLIST(CLOSEL),CLOSE   Move close list
         CLOSE (INDS),                 Close it                        X
               MF=(E,MACLIST)
*
XIT010   EQU   *
         TM    FLAGS2,F2OUTOPN         Is OUTDATASET open?
         BZ    XIT020                  No
         MVC   MACLIST(CLOSEL),CLOSE   Move close list
         CLOSE (OUTDS),                Close it                        X
               MF=(E,MACLIST)
*
XIT020   EQU   *
         TM    FLAGS2,F2NCBOPN         Is NETSPOOL open?
         BZ    XIT030                  No
         SR    R6,R6                   Ensure no tag data
         LA    R1,NCB1                 -> NCB
         NSIO  TYPE=CLOSE,             Close the spool                 x
               NCB=(R1),TAG=(R6)
*
XIT030   EQU   *
*                                                                       NJE00200
XIT040   EQU   *                                                        NJE00210
         LA    R3,DDLIST               -> list of DD's we allocated
         LA    R4,UNLISTSZ/8           # of DD list entries
*
XIT050   EQU   *
         CLC   =XL8'00',0(R3)          Unassigned DD?
         BE    XIT060                  Skip to next
*
         MVC   UDDNAME,0(R3)
         LA    R0,UNDYN           00   unalloc
         L     R15,=A(NJEDYN)          -> dynamic allocation rtns
         BALR  R14,R15
*
XIT060   EQU   *                                                        NJE00210
         LA    R3,8(,R3)               -> next DD entry
         BCT   R4,XIT050               Continue unallocation scan
*
XIT070   EQU   *                                                        NJE00210
         TM    FLAGS1,F1AUSR           Special authorized user?
         BZ    XIT080                  Y, Don't need Auth SVC
         SR    0,0                     Use authorization SVC
         SR    1,1                      For HERC01/HERC02 only
         SVC   244                     Get un-authorized
*
XIT080   EQU   *                                                        NJE00210
*
QUIT     EQU   *                                                        NJE00210
         LR    R1,R10                  -> NJEWK main work area page
         L     R13,4(,R13)             -> caller's sa                   NJE00210
         ST    R5,16(,R13)             Set exit RC
         FREEMAIN RU,                                                  x
               LV=4096,                                                x
               A=(1)
         LM    R14,R12,12(R13)         Reload system's regs             NJE00220
         BR    R14                     Return                           NJE00240
*
*-- User ABENDs issued
*
ABEND101 EQU   *
         LA    R1,101                  OBTAIN failed for input DATASET
         B     ABEND
*
ABEND102 EQU   *
         LA    R1,102                  DEVTYPE failed for input DATASET
         B     ABEND
*
ABEND103 EQU   *
         LA    R1,103                  OBTAIN failed for IEBCOPY UNLD
         B     ABEND
*
ABEND104 EQU   *
         LA    R1,104                  DEVTYPE failed for IEBCOPY UNLD
         B     ABEND
*
ABEND105 EQU   *
         LA    R1,105                  OBTAIN failed for OUTDATASET
         B     ABEND
*
*ABEND106 EQU   *                      DSNAME build failure, See
*                                       label B2DSN020 in CSECT NJENET
*
ABEND    ABEND (1),DUMP,STEP
         DROP  R12
*
*-- STAX attention exit
*
*-- Doesn't do anything, but allows us to deallocate and get un-
*-- authorized rather than a native TSO abort.
*
STAXXIT  EQU   *
         STM   R14,R12,12(R13)         Save
         LR    R12,R15                 Get base
         USING STAXXIT,R12
         L     R10,8(,R1)              -> NJEWK area
         USING NJEWK,R10
         OI    FLAGS1,F1ATTN           Indicate ATTN pressed       v201
         LM    R14,R12,12(R13)         Load
         DROP  R12
         BR    R14                     Return
*
         LTORG ,
*
DMYINDS  DCB   DDNAME=INDS,                                            X
               MACRF=(GL),                                             X
               DSORG=PS,                                               X
               BFTEK=A,                                                X
               EODAD=EOD000
DMYINDSL EQU   *-DMYINDS
*
DMYOUTDS DCB   DDNAME=OUTDS,                                           X
               MACRF=(PM),                                             X
               DSORG=PS,                                               X
               BLKSIZE=3120,                                           X
               LRECL=80,                                               X
               RECFM=FB
DMYOUTDL EQU   *-DMYOUTDS
*
*
*
OPEN     OPEN  0,MF=L
OPENL    EQU   *-OPEN
CLOSE    CLOSE 0,MF=L
CLOSEL   EQU   *-CLOSE
LINK     LINK  EP=0,SF=L
LINKL    EQU   *-LINK
ESTAE    ESTAE 0,MF=L
ESTAEL   EQU   *-ESTAE
STAX     STAX  0,OBUF=(0,0),IBUF=(0,0),USADDR=0,MF=L
STAXL    EQU   *-STAX
DMYLST   CAMLST SEARCH,0,0,0
DMYLSTL  EQU   *-DMYLST
LOCATLST CAMLST NAME,0,,0
TRKCALC  TRKCALC MF=L
TRKCALCL EQU   *-TRKCALC
POST     POST  0,ASCB=0,ERRET=0,MF=L
POSTL    EQU   *-POST
*
COPYPARM DC    AL2(L'COPYOPT)
COPYOPT  DC    C'WORK=0512K'
COPYPRML EQU   *-COPYPARM                 TOTAL LENGTH OF PARM OPTION
*
ATTNMSG  DC  C'COMMAND TERMINATED DUE TO ATTENTION; PRESS ENTER TWICE'
*                                                                  v201
*********************
*  N J E C O M      *               NJECOM hosts small routines and
*                   *               frequently used constants that
*  Common routines  *               are available to all NJERxx csects
*  and constants    *               via base register 11
*                   *
*********************
*
NJECOM   CSECT
         DC    A(0)                 No branch around constants
         DC    AL1(23)                LENGTH OF EYECATCHERS
         DC    CL9'NJECOM'
         DC    CL9'&SYSDATE'
         DC    CL5'&SYSTIME'
         USING NJECOM,R11
*
*-- Write a record to the NJE38 spool, or to OUTDATASET
*
*-- Entry: None
*-- Exit:  RC=0 if write ok, RC=8 if write error.
*
PUT000   EQU   *
         ST    R14,SV14PUT             Save return reg
*
         TM    FLAGS3,F3OUTDS          Did user specify OUTDATASET?
         BZ    PUT050                  No, transmit to NETSPOOL
*
         PUT   OUTDS,REC               Write the record
         SR    R15,R15                 Set RC=0
         B     PUT090
*
PUT050   EQU   *
         LA    R1,NCB1
         NSIO  TYPE=PUT,               Write the record to spool       x
               NCB=(R1),                                               x
               AREA=REC,                                               x
               RECLEN=80
         LTR   R15,R15                 Any errors?
         BZ    PUT090                  No
         BAL   R14,FMT000              Display error
         LA    R15,8                   Set RC=8
*
PUT090   EQU   *
         LA    R1,1                    Get 1
         A     R1,OUTRECS              Bump record count
         ST    R1,OUTRECS              Update output counter
         L     R14,SV14PUT             Load return reg
         BR    R14                     Return with RC in R15
*
*-- Build IEBCOPY control statements
*
*-- Used if a member name was specified on DATASET and the PDS option
*-- was specified.
*
*-- Entry: None
*-- Exit:  None; card images written to the SYSIN dataset.
*
CTL000   EQU   *
         ST    R14,SV14SI              Save return reg
*
         L     R15,=A(DMYOUTDS)        -> DCB to use as model
         MVC   SYSINDS(DMYOUTDL),0(R15) Set up DCB model
         LA    R6,SYSINDS              -> DCB
         USING IHADCB,R6
         MVC   DCBDDNAM,DDSYSIN        Set DCB DDNAME
         DROP  R6                      IHADCB
*
         L     R15,=A(OPEN)            -> model list
         MVC   MACLIST(OPENL),0(R15)   Move OPEN list
         OPEN  (SYSINDS,OUTPUT),       Open the SYSIN dataset          X
               MF=(E,MACLIST)
         OI    FLAGS2,F2SYSOPN         Indicate DCB is open
*
*-- Build IEBCOPY control statements to select one member
*
         MVC   REC,BLANKS              Init record image
         MVC   REC+1(10),=C'COPY INDD='
         MVC   REC+11(8),DDSYSUT1      Set SYSUT1 DD name
         TRT   REC+11(9),BLANK         Look for end
         MVC   0(7,R1),=C',OUTDD='
         MVC   7(8,R1),DDSYSUT2        Set SYSUT2 DD name
         PUT   SYSINDS,REC             Write the COPY ctrl stmt
*
         MVC   REC,BLANKS              Init image
         MVC   REC+1(5),=C'S M=('
         MVC   REC+6(8),INMEM          User specified member name
         TRT   REC+6(9),BLANK          Look for end
         MVI   0(R1),C')'              End selection list
         PUT   SYSINDS,REC
*
         TM    FLAGS2,F2SYSOPN         Is SYSINDS open?
         BZ    CTL090                  No
         L     R15,=A(CLOSE)           -> model list
         MVC   MACLIST(CLOSEL),0(R15)  Move close list
         CLOSE (SYSINDS),              Close it                        X
               MF=(E,MACLIST)
*
CTL090   EQU   *
         L     R14,SV14SI              Load return reg
         BR    R14                     Return
*
*
*-- Format VSAM NETSPOOL errors
*
*
FMT000   EQU   *
         STM   R14,R2,PARSA+12         Borrow NJEPAR save area
         LA    R15,0(,R14)  Clear high, Get addr of call to this rtn
         L     R2,NJESA+4              -> system provided FSA
         L     R2,16(,R2)              Get R15's entry point addr
         LA    R2,0(,R2)               Ensure high byte clear
         SR    R15,R2                  Compute offset of call
         MVC   LIST+0(4+L'MSG024T),MSG024 Move msg text
         MVC   LIST+55(8),5(R2)        Move csect name
         TRT   LIST+55(9),BLANK        Look for end of csect name
         MVI   0(R1),C'+'
*
         ST    R15,DBLE                Save call offset to work area
         UNPK  TWRK(5),DBLE+2(3)       Add zones
         TR    TWRK(4),HEXTRAN-240     Display hex
         MVC   1(4,R1),TWRK            Move call offset to msg
*
         LA    R15,NCB1
         UNPK  TWRK(5),NCBRTNCD-NCB(3,R15)  Add zones
         TR    TWRK(4),HEXTRAN-240
         MVC   LIST+35(4),TWRK         Move rtncd/errcd
*
         UNPK  TWRK(3),NCBREQ-NCB(2,R15)  Add zones
         TR    TWRK(2),HEXTRAN-240
         MVC   LIST+45(2),TWRK         Move req code
*
         L     R1,NCBMACAD-NCB(,R15)   Get failing VSAM macro addr
         LA    R1,0(,R1)               Clear high byte
         S     R1,=V(NJESPOOL)         Compute offset into NJESPOOL rtn
         ST    R1,DBLE
         UNPK  TWRK(5),DBLE+2(3)       Add zones
         TR    TWRK(4),HEXTRAN-240     Display hex
         MVC   LIST+50(4),TWRK         Move NJESPOOL offset to msg
*
         LA    R2,LIST
         BAL   R14,PUTLINE
*
FMT090   EQU   *
         LM    R14,R2,PARSA+12         Restore caller regs
         BR    R14                     Return
*
*-- Write a single line to terminal
*
*-- Entry: R2 -> output msg (RDW+msg text)
*-- Exit:  R15 = RC from PUTLINE
*
PUTLINE  EQU   *
         TM    FLAGS3,F3QUIET          QUIET mode enabled?
         BZ    PUT010                  No, proceed
         CLI   3(R2),1                 Suppress this msg in QUIET mode?
         BER   R14                     Yes
*
PUT010   EQU   *
         ST    R14,SV14LN              Save return
         XC    PUTECB,PUTECB           Clear PUTLINE ECB
         L     R15,CPARMS              -> command input CPPL
         USING CPPL,R15
         LA    R1,IOPLAREA             -> IOPL
         USING IOPL,R1
         MVC   IOPLUPT,CPPLUPT         Set UPT ptr
         MVC   IOPLECT,CPPLECT         Set ECT ptr
         DROP  R15                     CPPL
*
         MVC   TWRK(PBL),PB            Move macro model
         PUTLINE PARM=TWRK,            Write a line                    x
               ECB=PUTECB,                                             x
               OUTPUT=((R2),TERM,SINGLE,DATA),                         x
               MF=(E,(1))
         DROP  R1                      IOPL
         L     R14,SV14LN              Load return
         BR    R14
*
*-- Get status of NJE38
*
*-- Entry: R1=0 (no spool dsn needed), or, R1-> 44-char spool DSN area
*-- Exit:  RC=0  NJE38 is active; R1-> NJE38 CSA block
*--        RC<>0 NJE is not active.
*
*
CHK000   EQU   *
         LA    R1,SPLDSN               => where to place spool DSN v210
         L     R15,=V(NJESYS)          -> ENQ finder               v210
         BALR  R14,R15                 Check if NJE38 already act  v210
         LTR   R15,R15                 Set CC (RC=0 NJE38 active)  v210
         BNZR  R2                      Return if NJE38 inactive    v210
         MVC   LCLNODE,NJ38NODE-NJ38CSA(R1)  Save off lcl node namev210
         MVC   DEFUSER,NJ38DUSR-NJ38CSA(R1)  Save off default user v210
         BR    R2                      Return; NJE38 active        v210
*
         LTORG
*
PB       PUTLINE MF=L
PBL      EQU   *-PB
*
NJE38Q   DC    CL8'NJE38'              QNAME
NJERCON  DC    CL8'NJEINIT'            RNAME (first 8 bytes)
*
*
*
BLANKS   DC    CL120' '
NONBLANK DC    64X'FF',X'00',191X'FF'  TR Table to locate nonblank
BLANK    DC    64X'00',X'FF',191X'00'  TR Table to locate blanks
DOTS     DC    75X'00',X'FF',180X'00'  TR Table to locate '.' char
HEXTRAN  DC    CL16'0123456789ABCDEF'  Translate table
*
NONALNUM EQU   *  0 1 2 3 4 5 6 7 8 9 A B C D E F
         DC    X'FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF'  0
         DC    X'FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF'  1   Allow alpha-
         DC    X'FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF'  2   numeric only
         DC    X'FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF'  3   and '.'
         DC    X'FFFFFFFFFFFFFFFFFFFFFF00FFFFFFFF'  4
         DC    X'FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF'  5
         DC    X'FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF'  6
         DC    X'FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF'  7
         DC    X'FF000000000000000000FFFFFFFFFFFF'  8
         DC    X'FF000000000000000000FFFFFFFFFFFF'  9
         DC    X'FFFF0000000000000000FFFFFFFFFFFF'  A
         DC    X'FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF'  B
         DC    X'FF000000000000000000FFFFFFFFFFFF'  C
         DC    X'FF000000000000000000FFFFFFFFFFFF'  D
         DC    X'FFFF0000000000000000FFFFFFFFFFFF'  E
         DC    X'00000000000000000000FFFFFFFFFFFF'  F
*
*-- TRANSMIT messages
*
*-- Note:  a '1' after the length indicates suppress this msg if QUIET
*
MSGBLNK  DC    Y(4+L'MSGBLNKT,1)
MSGBLNKT DC    C' '
*
MSG000   DC    Y(4+L'MSG000T,1)
MSG000T  DC    C'NJE38 TRANSMIT &VERS'
*
MSG001   DC    Y(4+L'MSG001T,0)
MSG001T  DC    C'Error parsing TRANSMIT command parameters. IKJPARS RC=x
               yy (dec)'
*                456789012345678901234567890123456789012345678901234567
*
MSG002   DC    Y(4+L'MSG002T,0)
MSG002T  DC    C'DATASET(dsname) parameter is missing; it is required'
*
MSG003   DC    Y(4+L'MSG003T,0)
MSG003T  DC    C'Input dataset must be sequential or partitioned (DSORGx
               =PS/PO)'
*                                                                       NJE00250
*
MSG004   DC    Y(4+L'MSG004T,0)
MSG004T  DC    C'No transmit parameters were specified'
*
MSG005   DC    Y(4+L'MSG005T,0)
MSG005T  DC    C'Invalid node.user specification'
*
MSG006   DC    Y(4+L'MSG006T,0)
MSG006T  DC    C'The TRANSMIT command is not APF-authorized'
*
MSG007   DC    Y(4+L'MSG007T,0)
MSG007T  DC    C'OUTDATASET must specify a sequential dataset or PDS wix
               th a member name'
*
MSG008   DC    Y(4+L'MSG008T,0)
MSG008T  DC    C'OUTDATASET specifies a PDS; a member name is required'
*
MSG009   DC    Y(4+L'MSG009T,1)
MSG009T  DC    C'File successfully '         queued to/written to  v200
*
MSG010   DC    Y(4+L'MSG010T,0)
MSG010T  DC    C'I/O error writing '
*
*
MSG011   DC    Y(4+L'MSG011T,0)
MSG011T  DC    C'A destination node.userid was not specified'
*
MSG012   DC    Y(4+44+L'MSG012T,0)
MSG012T  DC    C'Allocation error xxxxxxxx, DSN='
*
MSG013   DC    Y(4+L'MSG013T,0)
MSG013T  DC    C'NJE38 is not active'
*
*
MSG014   DC    Y(4+L'MSG014T,0)
MSG014T  DC    C'Access to the NETSPOOL dataset denied due to security x
               settings'
*
MSG015   DC    Y(4+L'MSG015T,0)                                    v200
MSG015T  DC    C'Member xxxxxxxx was not found'                    v200
*
MSG018   DC    Y(4+L'MSG018T,0)
MSG018T  DC    C'Transmit failed due to IEBCOPY RC=xx'
*                456789012345678901234567890123456789012345678901234567
*
MSG024   DC    Y(4+L'MSG024T,0)
MSG024T  DC    C'ERROR:  NETSPOOL RTNCD/ERRCD=X''0000'',REQ=01,O=1234,Mx
               MMMMMMM     '
*
MSG025   DC    Y(4+L'MSG025T,0)
MSG025T  DC    C'Unable to open NETSPOOL. Run IDCAMS VERIFY against thex
                NETSPOOL dataset'
*
MSG027   DC    Y(4+L'MSG027T,0)
MSG027T  DC    C' exists'
*
MSG031   DC    Y(4+L'MSG031T,0)
MSG031T  DC    C' does not exist'
*
*                                                                       NJE00250
*                                                                       NJE00250
*********************
*  N J E D Y N      *               NJEDYN handles the various
*                   *               dynamic allocations required
*  Handle DYNALLOC  *               and their unallocations as well.
*                   *
*********************
*
*        USING INMFIELD,R7          -> R7 at entry
*
NJEDYN   CSECT
         B     28(,R15)               BRANCH AROUND EYECATCHERS
         DC    AL1(23)                LENGTH OF EYECATCHERS
         DC    CL9'NJEDYN'
         DC    CL9'&SYSDATE'
         DC    CL5'&SYSTIME'
*
         STM   R14,R12,12(R13)         Save Regs                        NJE00050
         LR    R12,R15                 Base                             NJE00060
         USING NJEDYN,R12                                               NJE00070
         USING NJEWK,R10
         ST    R13,DYNSA+4             SAVE prv S.A. ADDR               NJE00080
         LA    R1,DYNSA                -> my save area
         ST    R1,8(,R13)              Plug it into prior SA
         LR    R13,R1
*
         MVC   LS99RB,CPS99RB          init THE S99RB
         LA    R1,LS99RB               -> S99RB
         USING S99RB,R1
         ST    R1,LS99PTR              Set parameter word
         OI    LS99PTR,X'80'           Set VL
         LA    R6,TXTPTRS              -> start of text unit list
         ST    R6,S99TXTPP             Put in S99RB
         DROP  R1                      S99RB
*
UNDYN    EQU   0                   00  unallocate DDNAME
DYNUNDEF EQU   4                   04  unused, undefined
DYNSYSIN EQU   8                   08  Allocate SYSIN for IEBCOPY
DYNSYSPR EQU   12                  0C  Allocate SYSPRINT for IEBCOPY
DYNUNLD  EQU   16                  10  Allocate unload dataset IEBCOPY
DYNSYSU4 EQU   20                  14  Allocate SYSUT4 IEBCOPY
DYNINDS  EQU   24                  18  Allocate user input dataset
DYNETSPL EQU   28                  1C  Allocate NETSPOOL
DYNOUTDS EQU   32                  20  Allocate OUTDATASET
*
         LR    R5,R0                   Copy action code
         B     DYN000(R5)              Branch into table
*
DYN000   B     DYN010              00  Perform DDNAME Unallocation
         DC    AL4(0)              04  undefined
         B     DYN200              08  Allocate SYSIN for IEBCOPY
         B     DYN300              0C  Allocate SYSPRINT for IEBCOPY
         B     DYN400              10  Allocate unload dataset IEBCOPY
         B     DYN500              14  Allocate SYSUT4 IEBCOPY
         B     DYN600              18  Allocate user input dataset
         B     DYN700              1C  Allocate NETSPOOL
         B     DYN800              20  Allocate OUTDATASET
*
DYN010   EQU   *
         MVC   UTXT,UTXTD              Init text unit
         LA    R1,LS99RB               -> S99RB
         USING S99RB,R1
         MVI   S99VERB,S99VRBUN        Set verb code to unallocation
         DROP  R1                      S99RB
*
         LA    R0,UTXT                 -> UNALLOC DD text unit
         ST    R0,0(,R6)               Plug into ptr list
         OI    0(R6),X'80'             End the parameter list
         B     DYN900                  Deallocate the DD
*
*-- SYSIN for IEBCOPY
*
*   Equivalent JCL  (if command line SEQL specified or defaulted):
*   //SYS00000 DD DUMMY
*
*
*   Equivalent JCL  (if command line PDS specified and a member name
*                    was coded in DATASET):
*   //SYS00000 DD DISP=(NEW,DELETE),UNIT=SYSDA,
*   //            SPACE=(CYL,1)
*
*
DYN200   EQU   *
         TM    FLAGS3,F3PDS            PDS copy forced?
         BO    DYN220                  Y, we need to set up for
*                                        IEBCOPY control statements
*
         MVC   TXT01,TXT01D            Init from the models
         MVC   TXT16,TXT16D
         LA    R0,TXT01                -> return DDNAME
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT16                -> DUMMY
         ST    R0,0(,R6)               Plug into ptr list
         OI    0(R6),X'80'             End the parameter list
         B     DYN900                  Go allocate
*
DYN220   EQU   *
         MVC   TXT01,TXT01D            Init from the models
         MVC   TXT03,TXT03D            DISP 1
         MVC   TXT04,TXT04D            DISP 2
         MVC   TXT06,TXT06D            PRIME
         MVC   TXT10,TXT10D            UNIT
         MVC   TXT19,TXT19D            CYL
*
         MVI   TXT04+6,X'04'           Adjust to DISP=,DELETE
         MVC   TXT06+6(3),=XL3'01'     1 cylinders
*
         LA    R0,TXT01                -> return DDNAME
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT03                -> DISP=NEW
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT04                -> DISP=,DELETE
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT06                -> Primary space
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT10                -> UNIT
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT19                -> SPACE CYL
         ST    R0,0(,R6)               Plug into ptr list
         OI    0(R6),X'80'             End the parameter list
         B     DYN900                  Go allocate
*
*-- SYSPRINT for IEBCOPY
*
*   Equivalent JCL:
*   //SYS00000 DD SYSOUT=*,TERM=TS
*
DYN300   EQU   *
         MVC   TXT01,TXT01D            Init from the models
         MVC   TXT16,TXT16D
         MVC   TXT17,TXT17D
         MVC   TXT18,TXT18D
         LA    R0,TXT01                -> return DDNAME
         ST    R0,0(,R6)               Plug into ptr list
*
         TM    FLAGS3,F3QUIET          QUIET mode enabled?
         BO    DYN310                  Yes, use DUMMY
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT17                -> SYSOUT=*
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT18                -> TERM=TS
         ST    R0,0(,R6)               Plug into ptr list
         B     DYN320
*
DYN310   EQU   *
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT16                -> DUMMY
         ST    R0,0(,R6)               Plug into ptr list
*
DYN320   EQU   *
         OI    0(R6),X'80'             End the parameter list
         B     DYN900                  Go allocate
*
*-- Temporary dataset that IEBCOPY will unload into
*
*   Equivalent JCL:
*   //SYS00000 DD DISP=(NEW,DELETE),UNIT=SYSDA,
*   //            SPACE=(4096,(pri,sec)),
*   //            DCB=(BLKSIZE=4096,DSORG=PS)
*
DYN400   EQU   *
         MVC   TXT01,TXT01D            Init from the models
         MVC   TXT02,TXT02D            DSN
         MVC   TXT03,TXT03D            DISP1
         MVC   TXT04,TXT04D            DISP2
         MVC   TXT05,TXT05D            Blklen
         MVC   TXT06,TXT06D            Prime
         MVC   TXT07,TXT07D            Second
         MVC   TXT09,TXT09D            volume
         MVC   TXT10,TXT10D            unit
         MVC   TXT12,TXT12D            BLKSIZE
         MVC   TXT13,TXT13D            DSORG
*
         LA    R0,TXT01                -> Return DDNAME text unit
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT03                -> DISP text unit 1
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT04                -> DISP text unit 2
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT05                -> BLKLEN text unit 2
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT06                -> PRIMARY text unit
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT07                -> SECONDARY text unit
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT12                -> BLKSIZE text unit
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT13                -> DSORG text unit
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT09                -> VOLSER text unit
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT10                -> UNIT text unit
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT02                -> DSN text unit
         ST    R0,0(,R6)               Plug into ptr list
         OI    0(R6),X'80'             End the parameter list
*
         MVI   TXT04+6,X'04'           Set DISP=,DELETE
         MVC   TXT09(2),=Y(DALRTVOL)   Set to return VOLSER
         MVC   TXT02(2),=Y(DALRTDSN)   Set to return DSN
         B     DYN900                  Go allocate
*
*-- SYSUT4 for IEBCOPY
*
*   Equivalent JCL:
*   //SYS00000 DD DISP=(NEW,DELETE),UNIT=SYSDA,
*   //            SPACE=(CYL,5)
*
DYN500   EQU   *
         MVC   TXT01,TXT01D            Init from the models
         MVC   TXT03,TXT03D            DISP 1
         MVC   TXT04,TXT04D            DISP 2
         MVC   TXT06,TXT06D            PRIME
         MVC   TXT10,TXT10D            UNIT
         MVC   TXT19,TXT19D            CYL
*
         MVI   TXT04+6,X'04'           Adjust to DISP=,DELETE
         MVC   TXT06+6(3),=XL3'05'     5 cylinders
*
         LA    R0,TXT01                -> return DDNAME
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT03                -> DISP=NEW
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT04                -> DISP=,DELETE
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT06                -> Primary space
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT10                -> UNIT
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT19                -> SPACE CYL
         ST    R0,0(,R6)               Plug into ptr list
         OI    0(R6),X'80'             End the parameter list
         B     DYN900                  Go allocate
*
*-- Dataset user.input.dataset from command line
*
*   Equivalent JCL:
*   //SYS00000 DD DISP=SHR,DSNAME=user.input.dataset(mem)
*
DYN600   EQU   *
         MVC   TXT01,TXT01D            Init from the models
         MVC   TXT02,TXT02D
         MVC   TXT03,TXT03D
         MVC   TXT09,TXT09D
         MVC   TXT13,TXT13D
         MVC   TXT21,TXT21D
*
         MVI   TXT03+6,X'08'           set DISP=SHR
         MVC   TXT09(2),=Y(DALRTVOL)   Set to return VOLSER
         MVC   TXT13(2),=Y(DALRTORG)   Set to return DSORG
*
         LA    R0,TXT01                -> return DDNAME
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT03                -> DISP=SHR
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT09                -> RETURN VOLSER
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT13                -> RETURN DSORG
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT02                -> DSNAME
         ST    R0,0(,R6)               Plug into ptr list
*
         TM    FLAGS3,F3PDS            Was PDS specified?
         BO    DYN610                  Yes, we'll use IEBCOPY, no mbr
         TM    FLAGS3,F3INMEM          Was a member specified?
         BZ    DYN610                  No
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT21                -> MEMBER
         ST    R0,0(,R6)               Plug into ptr list
*
DYN610   EQU   *
         OI    0(R6),X'80'             End the parameter list
         B     DYN900                  Go allocate
*
*-- Dataset NETSPOOL
*
*   Equivalent JCL:
*   //NETSPOOL DD DISP=SHR,DSNAME=NJE38.NETSPOOL
*
*
DYN700   EQU   *
         MVC   TXT01,TXT01D            Init from the models
         MVC   TXT02,TXT02D
         MVC   TXT03,TXT03D
*
         MVC   TXT01(2),=Y(DALDDNAM)   Use fixed DD
         MVI   TXT03+6,X'08'           set DISP=SHR
*
         LA    R0,TXT01                -> DDNAME
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT03                -> DISP=SHR
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT02                -> DSNAME
         ST    R0,0(,R6)               Plug into ptr list
*
         OI    0(R6),X'80'             End the parameter list
         B     DYN900                  Go allocate
*
*-- Dataset created for OUTDATASET
*
*   Equivalent JCL:
*   //SYS00000 DD DISP=(NEW,CATLG),UNIT=unitname,
*   //            SPACE=(3120,(pri,sec)),
*   //            DCB=(BLKSIZE=3120,LRECL=80,RECFM=FB,DSORG=PS),
*   //            DSN=dsname,VOL=SER=volser
*
DYN800   EQU   *
         TM    FLAGS2,F2EXIST          Does OUTDATASET exist?
         BO    DYN850                  Yes, don't create it
*
         MVC   TXT01,TXT01D            Init from the models
         MVC   TXT02,TXT02D
         MVC   TXT03,TXT03D
         MVC   TXT04,TXT04D
         MVC   TXT05,TXT05D
         MVC   TXT06,TXT06D
         MVC   TXT07,TXT07D
         MVC   TXT08,TXT08D
         MVC   TXT09,TXT09D
         MVC   TXT10,TXT10D
         MVC   TXT12,TXT12D
         MVC   TXT13,TXT13D
         MVC   TXT14,TXT14D
         MVC   TXT15,TXT15D
         MVC   TXT21,TXT21D
*
         LA    R0,TXT01                -> Return DDNAME text unit
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT03                -> DISP text unit 1
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT04                -> DISP text unit 2
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT12                -> BLKSIZE text unit
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT05                -> BLKLEN text unit
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT14                -> LRECL text unit
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT15                -> RECFM text unit
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT06                -> PRIMARY text unit
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT07                -> SECONDARY text unit
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT13                -> DSORG text unit
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT10                -> UNIT text unit
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT02                -> DSN text unit
         ST    R0,0(,R6)               Plug into ptr list
         TM    FLAGS3,F3VOLSER         Was there a volser?
         BZ    DYN810                  No
*
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT09                -> VOLSER text unit
         ST    R0,0(,R6)               Plug into ptr list
*
DYN810   EQU   *
         TM    FLAGS3,F3OUTMEM         Was a member specified?
         BZ    DYN820                  No
         MVC   TDSORG,=X'0200'         Force DSORG to PO if member
         MVC   TDIRBLKS,=AL3(5)        Set 5 directory blocks
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT08                -> DIRBLKS
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT21                -> MEMBER
         ST    R0,0(,R6)               Plug into ptr list
*
DYN820   EQU   *
         TM    FLAGS2,F2UNIT           User specified unit?        v200
         BZ    DYN890                  No                          v200
         MVC   TUNIT,OUTUNIT           Use user specified unit namev200
*
DYN890   EQU   *                                                   v200
         OI    0(R6),X'80'             End the parameter list
         B     DYN900                  Go allocate
*
*-- Allocate existing OUTDATASET (with optional member)
*
*   Equivalent JCL:
*   //SYS00000 DD DISP=SHR,DSNAME=out.data.set(mem)
*
DYN850   EQU   *
         MVC   TXT01,TXT01D            Init from the models
         MVC   TXT02,TXT02D
         MVC   TXT03,TXT03D
         MVC   TXT21,TXT21D
*
         MVI   TXT03+6,X'08'           set DISP=SHR
*
         LA    R0,TXT01                -> return DDNAME
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT03                -> DISP=SHR
         ST    R0,0(,R6)               Plug into ptr list
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT02                -> DSNAME
         ST    R0,0(,R6)               Plug into ptr list
*
         TM    FLAGS3,F3OUTMEM         Was a member specified?
         BZ    DYN860                  No
         LA    R6,4(,R6)               -> next ptr list slot
         LA    R0,TXT21                -> MEMBER
         ST    R0,0(,R6)               Plug into ptr list
*
DYN860   EQU   *
         OI    0(R6),X'80'             End the parameter list
         B     DYN900                  Go allocate
*
*-- Allocate the dataset
*
DYN900   EQU   *
         LA    R1,LS99RB               -> S99RB
         USING S99RB,R1
         OI    S99FLAG1,S99NOCNV        FORCE NEW ALLOCATION
         DROP  R1
         LA    R1,LS99PTR               POINTER TO S99 PTR
         SVC   99                       ISSUE DYNALLOC
         LTR   R15,R15                  Any errors?
         BZ    XITDYN00                 No
*
         LA    R1,LS99RB
         USING S99RB,R1
         UNPK  TWRK(9),S99ERROR(5)      Add zones to error code
         DROP  R1
         TR    TWRK(8),HEXTRAN-240
*
         CLI   TWRK+1,C'7'              Class 7 error code?
         BNE   ERR012                   No
         LA    R1,DYNINDS               Code for the input dataset?
         CR    R1,R5                    Was alloc for DYNINDS?
         BE    ERR031                   Yes, dataset does not exist
*
ERR012   EQU   *
         MVC   LIST(4+L'MSG012T),MSG012 Dyn alloc failure msg
         MVC   LIST+21(8),TWRK          Error codes to line
         MVC   LIST+35(44),TDSNAME      Move DSNAME
         LA    R2,LIST                  -> msg
         BAL   R14,PUTLINE              Display it
         B     XITDYN08
*
ERR031   EQU   *
         MVC   LIST,BLANKS
         MVC   LIST+4(9),=C'Dataset '''
         MVC   LIST+13(44),TDSNAME Move name
         TRT   LIST+13(45),BLANK   Look for end of name
         MVI   0(R1),C''''         Close apost
         LA    R1,1(,R1)           Skip apost
         MVC   0(L'MSG031T,R1),MSG031T  Move rest of msg
         LA    R1,L'MSG031T(,R1)   point to end
         XC    LIST(4),LIST        Clear RDW area
         LA    R2,LIST             -> start of RDW+msg
         SR    R1,R2               Compute total length
         STH   R1,LIST             Plug RDW
         BAL   R14,PUTLINE         Inform user
         B     XITDYN04            And exit with dataset doesnt exist
*
*
*-- Exit
*
XITDYN00 EQU   *
         SR    R15,R15             Set RC=0;  alloc/dealloc ok
         B     XITDYN
*
XITDYN04 EQU   *
         LA    R15,4               Set RC=4;  Exit for special action
         B     XITDYN
*
XITDYN08 EQU   *
         LA    R15,8               Set RC=8;  allocation error
*
XITDYN   EQU   *
         L     R13,4(,R13)         -> prev s.a.
         ST    R15,16(,R13)        Set RC
         LM    R14,R12,12(R13)     Reload callers regs
         BR    R14                 Return with RC
*
         LTORG
*        DROP  R7                  INMFIELD
*
*
*
*-- Text unit skeletons
*
*-- Note:  EXPDT is included for completeness but is not used.
*
*
*
TXT01D   DC    Y(DALRTDDN),AL2(1),AL2(8)          RETURN DDNAME
TXT02D   DC    Y(DALDSNAM),AL2(1),AL2(44)         DSNAME
TXT03D   DC    Y(DALSTATS),AL2(1),AL2(1),X'04'    DISP=(NEW,)
TXT04D   DC    Y(DALNDISP),AL2(1),AL2(1),X'02'    DISP=(,CATLG)
TXT05D   DC    Y(DALBLKLN),AL2(1),AL2(3)          BLK TEXT KEY, BLKLEN
TXT06D   DC    Y(DALPRIME),AL2(1),AL2(3)          PRIMARY SPACE UNITS
TXT07D   DC    Y(DALSECND),AL2(1),AL2(3)          SECONDARY SPACE UNITS
TXT08D   DC    Y(DALDIR),AL2(1),AL2(3)            DIRECTORY BLOCKS
TXT09D   DC    Y(DALVLSER),AL2(1),AL2(6)          VOLSER
TXT10D   DC    Y(DALUNIT),AL2(1),AL2(8),CL8'SYSDA' UNIT default    v200
TXT11D   DC    Y(DALEXPDT),AL2(1),AL2(5)          EXPDT C'YYDDD'
TXT12D   DC    Y(DALBLKSZ),AL2(1),AL2(2)          BLKSIZE
TXT13D   DC    Y(DALDSORG),AL2(1),AL2(2)          DSORG
TXT14D   DC    Y(DALLRECL),AL2(1),AL2(2)          LRECL
TXT15D   DC    Y(DALRECFM),AL2(1),AL2(1)          RECFM
TXT16D   DC    Y(DALDUMMY),AL2(0)                 DUMMY
TXT17D   DC    Y(DALSYSOU),AL2(0)                 SYSOUT
TXT18D   DC    Y(DALTERM),AL2(0)                  TERM
TXT19D   DC    Y(DALCYL),AL2(0)                   CYLINDER
TXT20D   DC    Y(DALCLOSE),AL2(0)                 FREE=CLOSE
TXT21D   DC    Y(DALMEMBR),AL2(1),AL2(8)          MEMBER
*
UTXTD    DC    Y(DUNDDNAM),AL2(1),AL2(8)          DD for deallocation
*
         DS    0F
CPS99RB  DS    0XL20                   DEFINE INITIAL S99RB
         DC    AL1(20)                 LENGTH OF REQ BLOCK
         DC    AL1(1)                  VERB CODE:  ALLOCATION
         DC    X'20'                   FLAGS:  NO MOUNTS,OFFLINE VOLS
         DC    X'00'                   FLAGS
         DC    AL2(0)                  ERROR REASON CODE
         DC    AL2(0)                  INFO REASON CODE
         DC    A(0)                    ADDR OF TEXT PTRS
         DC    A(0)                    ADDR OF RBX
         DC    AL4(0)                  MORE FLAGS
*                                                                       NJE00250
*
*
*********************
*  N J E N E T      *               NJENET converts the incoming
*                   *               files into NETDATA format and
*  Output NETDATA   *               writes 80-byte records to the spool
*                   *               or OUTDATASET destination.
*********************
*
NJENET   CSECT
         B     28(,R15)               BRANCH AROUND EYECATCHERS
         DC    AL1(23)                LENGTH OF EYECATCHERS
         DC    CL9'NJENET'
         DC    CL9'&SYSDATE'
         DC    CL5'&SYSTIME'
*
         STM   R14,R12,12(R13)         Save Regs
         LR    R12,R15                 Base
         USING NJENET,R12
         USING NJEWK,R10
         ST    R13,NETSA+4             SAVE prv S.A. ADDR
         LA    R1,NETSA                -> my save area
         ST    R1,8(,R13)              Plug it into prior SA
         LR    R13,R1
*
*
****************
* BUILD INMR01 *
****************
*
         USING INMFIELD,R7
         LA    R7,INMF01               -> INMR01 fields
         LA    R3,BUFF                 -> build buffer
         MVI   0(R3),0                 Init control record length
         MVI   1(R3),X'E0'             Indicate 1 segment, ctl record
         MVC   2(6,R3),INMR01          Create INMR01
         LA    R3,8(,R3)               -> next available byte
*
         BAL   R14,B1LRECL             Build the LRECL
         BAL   R14,B1FNODE             Build the FNODE
         BAL   R14,B1FUID              Build the FUID
         BAL   R14,B1TNODE             Build the TNODE
         BAL   R14,B1TUID              Build the TUID
         BAL   R14,B1FTIME             Build the time stamp
         BAL   R14,B1NUMF              Build the number of files
*
         LA    R1,BUFF                 -> start of build buffer
         SR    R3,R1                   Compute INMR01 total length
         STC   R3,0(,R1)               Plug into length byte
*
         LR    R0,R3                   Length to R0
         BAL   R14,PUTBYTES            Write the entire segment
*
****************
* BUILD INMR02 *
****************
*
         LA    R7,INMF02A              -> 1st INMR02 fields
         LA    R3,BUFF                 -> build buffer
         MVI   0(R3),0                 Init control record length
         MVI   1(R3),X'E0'             Indicate 1 segment, ctl record
         MVC   2(6,R3),INMR02          Create INMR02
         MVC   8(4,R3),=F'1'           Set file number to 1
         LA    R3,12(,R3)              -> next available byte
*
         BAL   R14,B2UTIL              Build the Utility name
         BAL   R14,B2FSIZE             Build the file size
         BAL   R14,B2DIRBLK            Build the dir blocks
         BAL   R14,B2LRECL             Build the LRECL
         BAL   R14,B2DSORG             Build the DSORG
         BAL   R14,B2BLKSI             Build the BLKSIZE
         BAL   R14,B2RECFM             Build the RECFM
         BAL   R14,B2DSN               Build the DSNAME
*
         LA    R1,BUFF                 -> start of build buffer
         SR    R3,R1                   Compute INMR02 total length
         STC   R3,0(,R1)               Plug into length byte
*
         LR    R0,R3                   Length to R0
         BAL   R14,PUTBYTES            Write the entire segment
*
****************
* BUILD INMR02 *  Second INMR02 is build if input DS was a PDS
****************
*
         TM    FLAGS1,F1INPDS          Was input DS a PDS?
         BZ    INM3                    No, dont need 2nd INMR02
         LA    R7,INMF02B              -> 2nd INMR02 fields
         LA    R3,BUFF                 -> build buffer
         MVI   0(R3),0                 Init control record length
         MVI   1(R3),X'E0'             Indicate 1 segment, ctl record
         MVC   2(6,R3),INMR02          Create INMR02
         MVC   8(4,R3),=F'1'           Set file number to 1
         LA    R3,12(,R3)              -> next available byte
*
         BAL   R14,B2UTIL              Build the Utility name
         BAL   R14,B2FSIZE             Build the file size
         BAL   R14,B2LRECL             Build the LRECL
         BAL   R14,B2DSORG             Build the DSORG
         BAL   R14,B2BLKSI             Build the BLKSIZE
         BAL   R14,B2RECFM             Build the RECFM
*
         LA    R1,BUFF                 -> start of build buffer
         SR    R3,R1                   Compute INMR02 total length
         STC   R3,0(,R1)               Plug into length byte
*
         LR    R0,R3                   Length to R0
         BAL   R14,PUTBYTES            Write the entire segment
*
****************
* BUILD INMR03 *
****************
*
INM3     EQU   *
         LA    R7,INMF02A              -> 1st INMR02 fields
         L     R0,FILESIZE             Get size from prev INMR02 buffer
         LA    R7,INMF03               -> INMR03 fields
         ST    R0,FILESIZE             Plug it into INMR03 buffer
         LA    R3,BUFF                 -> build buffer
         MVI   0(R3),0                 Init control record length
         MVI   1(R3),X'E0'             Indicate 1 segment, ctl record
         MVC   2(6,R3),INMR03          Create INMR02
         LA    R3,8(,R3)               -> next available byte
*
         BAL   R14,B3FSIZE             Build the file size
         BAL   R14,B3LRECL             Build the LRECL
         BAL   R14,B3DSORG             Build the DSORG
         BAL   R14,B3RECFM             Build the RECFM
*
         LA    R1,BUFF                 -> start of build buffer
         SR    R3,R1                   Compute INMR03 total length
         STC   R3,0(,R1)               Plug into length byte
*
         LR    R0,R3                   Length to R0
         BAL   R14,PUTBYTES            Write the entire segment
         DROP  R7                      INMFIELD
*
****************
* PERFORM      *
* "INMCOPY"    *
* FUNCTION     *
****************
*
CPY000   EQU   *
         LA    R4,INDS                 -> INDS DCB
         USING IHADCB,R4
         LA    R9,253                  Segment size (less len,ctl bytes
*
CPY020   EQU   *
         GET   INDS                    Get input record
         LR    R2,R1                   -> record to R2
         LH    R3,DCBLRECL             Get record length
         MVI   CTL,X'80'               Assume starting new segment
*
         TM    DCBRECFM,DCBRECF        RECFM=F (or U) records?
         BO    CPY060                  Handle them same way
         LH    R3,0(,R2)               Get length from RDW
         S     R3,=F'4'                Remove length of RDW
         LA    R2,4(,R1)               Skip over RDW
*
CPY060   EQU   *
         LR    R5,R3                   Working length to R5
         CR    R3,R9                   LRECL <= max segment size?
         BNH   CPY070                  Yes
         LR    R5,R9                   Else limit to max segment
*
CPY070   EQU   *
         SR    R3,R5                   Compute remaining length
         BCTR  R5,0                    Adjust working len for execute
         EX    R5,MVCREC               Move record to build buffer
         LA    R2,1(R5,R2)             -> next avail byte in record
         LA    R0,3(,R5)               Account for ex, len & ctl bytes
         STC   R0,BUFF                 Set the segment length
         LTR   R3,R3                   Is length remaining?
         BNZ   CPY080                  Yes
         OI    CTL,X'40'               Indicate this is last segment
*
CPY080   EQU   *
         MVC   BUFF+1(1),CTL           Set segment control
         BAL   R14,PUTBYTES            Write the netdata
         TM    CTL,X'40'               Did we process the final seg?
         BO    CPY020                  Yes, time for a new record
         MVI   CTL,X'00'               Clear segment ctl
         B     CPY060                  Go get another
*
MVCREC   MVC   BUFF+2(0),0(R2)         executed instr
*
EOD000   EQU   *
         LA    R3,BUFF                 -> build buffer
         MVI   0(R3),8                 Init control record length
         MVI   1(R3),X'E0'             Indicate 1 segment, ctl record
         MVC   2(6,R3),INMR06          Create INMR06
*
         LA    R0,8                    Write the INMR06 record
         BAL   R14,PUTBYTES
*
         XC    BUFF,BUFF
         L     R1,PBREM                Get # bytes remaining in REC
         LA    R0,1(,R1)               +1 more to force record write
         BAL   R14,PUTBYTES            Write a last full record
         DROP  R4                      IHADCB
         B     XITNET00                NETDATA build complete
*
*
*
*-- NETDATA text unit key build routines
*
*
         USING INMFIELD,R7
B1LRECL  EQU   *
         MVC   0(2,R3),INMLRECL        Set key
         MVC   2(2,R3),=Y(1)           Set #
         MVC   4(2,R3),=Y(4)           Set length
         MVC   6(4,R3),=A(80)          LRECL always 80 for INMR01
         LA    R3,10(,R3)              -> next available byte
         BR    R14                     Return
*
B1FNODE  EQU   *
         MVC   0(2,R3),INMFNODE        Set key
         MVC   2(2,R3),=Y(1)           Set #
         MVC   6(8,R3),LCLNODE         Use local node name
         LA    R1,6+8(,R3)             If TRT fails
         TRT   6(8,R3),BLANK           Look for end of name
         LA    R2,6(,R3)               -> start of name
         SR    R1,R2                   Compute length of name
         STCM  R1,3,4(R3)              Set length of name
         LA    R3,6(R1,R3)             -> next available byte
         BR    R14                     Return
*
B1FUID   EQU   *
         MVC   0(2,R3),INMFUID         Set key
         MVC   2(2,R3),=Y(1)           Set #
         MVC   6(8,R3),USERID          Use userid
         LA    R1,6+8(,R3)             If TRT fails
         TRT   6(8,R3),BLANK           Look for end of name
         LA    R2,6(,R3)               -> start of name
         SR    R1,R2                   Compute length of name
         STCM  R1,3,4(R3)              Set length of name
         LA    R3,6(R1,R3)             -> next available byte
         BR    R14                     Return
*
B1TNODE  EQU   *
         MVC   0(2,R3),INMTNODE        Set key
         MVC   2(2,R3),=Y(1)           Set #
         MVC   6(8,R3),DESTNODE        Use destination node name
         LA    R1,6+8(,R3)             If TRT fails
         TRT   6(8,R3),BLANK           Look for end of name
         LA    R2,6(,R3)               -> start of name
         SR    R1,R2                   Compute length of name
         STCM  R1,3,4(R3)              Set length of name
         LA    R3,6(R1,R3)             -> next available byte
         BR    R14                     Return
*
B1TUID   EQU   *
         MVC   0(2,R3),INMTUID         Set key
         MVC   2(2,R3),=Y(1)           Set #
         MVC   6(8,R3),DESTUSER        Use destination userid
         LA    R1,6+8(,R3)             If TRT fails
         TRT   6(8,R3),BLANK           Look for end of name
         LA    R2,6(,R3)               -> start of name
         SR    R1,R2                   Compute length of name
         STCM  R1,3,4(R3)              Set length of name
         LA    R3,6(R1,R3)             -> next available byte
         BR    R14                     Return
*
B1FTIME  EQU   *
         MVC   0(2,R3),INMFTIME        Set key
         MVC   2(2,R3),=Y(1)           Set #
         MVC   4(2,R3),=Y(16)          Set length
         TIME  DEC                     Get the date and time
*                                       R1 = 0yyydddF
*                                       R0 = hhmmssth
         LR    R2,R1                   Copy the date info
         SRL   R2,12                   Put year here: 0000yyyx
         ST    R2,DBLE                 Plug into work area
         OI    DBLE+3,X'0F'            Insert sign
         AP    DBLE(4),=P'1900'        Add base century
         UNPK  6(4,R3),DBLE(4)         Unpk the year
         OI    9(R3),X'F0'             Fix sign
         DP    DBLE(4),=P'4'           Check for leap year
         LA    R15,LEAP                Assume leap year
         CP    DBLE+3(1),=P'0'         Did it divide evenly?
         BE    B1FTME10                Yes, it is a leap year
         LA    R15,NONLEAP             Use non leap year table
*
B1FTME10 EQU   *
         N     R1,=X'0000FFFF'         Keep only the day and sign
         ST    R1,DBLE                 Save into work area
         LA    R2,1                    Init month counter
*
B1FTME20 EQU   *
         CP    DBLE(4),0(2,R15)        Check against days table
         BNH   B1FTME30                Found the right month
         LA    R15,2(,R15)             -> next days entry
         LA    R2,1(,R2)               Next month number
         B     B1FTME20                Continue
*
B1FTME30 EQU   *
         C     R2,=F'1'                Was it found in month 1?
         BE    B1FTME40                Yes, use day as is
         BCTR  R15,0                   Back up
         BCTR  R15,0                    to prior month's entry
         SP    DBLE(4),0(2,R15)        Compute the day number
*
B1FTME40 EQU   *
         UNPK  12(2,R3),DBLE(4)        unpk day number
         OI    13(R3),X'F0'            Fix sign
         CVD   R2,DBLE                 Convert month number
         UNPK  10(2,R3),DBLE           unpk month number
         OI    11(R3),X'F0'            Fix sign
*
         ST    R0,DBLE                 Save the time value
         UNPK  TWRK(9),DBLE(5)         Add zones
         MVC   14(8,R3),TWRK           Mov the time HHMMSSTH
*
         LA    R3,22(,R3)              -> next available byte
         BR    R14                     Return
*
B1NUMF   EQU   *
         MVC   0(2,R3),INMNUMF         Set key
         MVC   2(2,R3),=Y(1)           Set #
         MVC   4(2,R3),=Y(1)           Set length
         MVI   6(R3),1                 Only 1 file supported
         LA    R3,7(,R3)               -> next available byte
         BR    R14                     Return
*
B2UTIL   EQU   *
         MVC   0(2,R3),INMUTILN        Set key
         MVC   2(2,R3),=Y(1)           Set #
         MVC   6(8,R3),UTLNAME         Use utility name
         LA    R1,6+8(,R3)             If TRT fails
         TRT   6(8,R3),BLANK           Look for end of name
         LA    R2,6(,R3)               -> start of name
         SR    R1,R2                   Compute length of name
         STCM  R1,3,4(R3)              Set length of name
         LA    R3,6(R1,R3)             -> next available byte
         BR    R14                     Return
*
B2FSIZE  EQU   *
         MVC   0(2,R3),INMSIZE         Set key
         MVC   2(2,R3),=Y(1)           Set #
         MVC   4(2,R3),=Y(4)           Set length
         MVC   6(4,R3),FILESIZE        File size in bytes
         LA    R3,10(,R3)              -> next available byte
         BR    R14                     Return
*
B2DIRBLK EQU   *
         ICM   R0,15,DIRBLKS           Get # of dir blocks needed
         BZR   R14                     This key is not needed
         MVC   0(2,R3),INMDIR          Set key
         MVC   2(2,R3),=Y(1)           Set #
         MVC   4(2,R3),=Y(3)           Set length
         STCM  R0,7,6(R3)              Set directory blocks
         LA    R3,9(,R3)               -> next available byte
         BR    R14                     Return
*
B2LRECL  EQU   *
         MVC   0(2,R3),INMLRECL        Set key
         MVC   2(2,R3),=Y(1)           Set #
         MVC   4(2,R3),=Y(4)           Set length
         MVC   6(4,R3),LRECL           Set LRECL
         LA    R3,10(,R3)              -> next available byte
         BR    R14                     Return
*
B2DSORG  EQU   *
         MVC   0(2,R3),INMDSORG        Set key
         MVC   2(2,R3),=Y(1)           Set #
         MVC   4(2,R3),=Y(2)           Set length
         MVC   6(2,R3),DSORG           Set DSORG
         LA    R3,8(,R3)               -> next available byte
         BR    R14                     Return
*
B2BLKSI  EQU   *
         ICM   R0,15,BLKSIZE           Get block size
         BZR   R14                     This key is not needed
         MVC   0(2,R3),INMBLKSZ        Set key
         MVC   2(2,R3),=Y(1)           Set #
         MVC   4(2,R3),=Y(4)           Set length
         STCM  R0,15,6(R3)             Set blocksize
         LA    R3,10(,R3)              -> next available byte
         BR    R14                     Return
*
B2RECFM  EQU   *
         TM    RECFM,X'40'             Variable (or U) records?
         BZ    *+8                     No
         MVI   RECFM+1,X'02'           Y, indicate varying w/o RDW fmt
*
         MVC   0(2,R3),INMRECFM        Set key
         MVC   2(2,R3),=Y(1)           Set #
         MVC   4(2,R3),=Y(2)           Set length
         MVC   6(2,R3),RECFM           Set RECFM
         LA    R3,8(,R3)               -> next available byte
         BR    R14                     Return
*
B2DSN    EQU   *
         CLI   DSNAME,X'00'            DSNAME field filled?
         BER   R14                     Exit if no DSNAME avail
         MVC   0(2,R3),INMDSNAM        Set key
         LA    R1,DSNAME+44            In case TRT fails
         TRT   DSNAME,BLANK            Find end of DSNAME
         LA    R2,DSNAME               -> start
         SR    R1,R2                   Compute DSN length
         LR    R0,R1                   Keep length in R0
         LA    R1,1                    Set # qualifiers to start
         LA    R4,4(,R3)               -> where 1st length fld goes
*
B2DSN010 EQU   *
         LA    R5,2(,R4)               -> DSN qualifier goes
         SR    R6,R6                   Init qualifier length
*
B2DSN020 EQU   *
         CLI   0(R2),C'.'              Look for qualification delim
         BNE   B2DSN040                No, just a regular character
         STCM  R6,3,0(R4)              Fill in length field
         LA    R4,2(R6,R4)             -> next length field area
         LA    R1,1(,R1)               Bump qualifier count
         LA    R2,1(,R2)               -> next DSN character (skip '.')
         BCT   R0,B2DSN010             Keep building
ABEND106 ABEND 106,DUMP                Shouldn't happen
*
B2DSN040 EQU   *
         MVC   0(1,R5),0(R2)           Move a DSN char
         LA    R5,1(,R5)               Next available byte in BUFF
         LA    R6,1(,R6)               Count qualifier length
         LA    R2,1(,R2)               -> next DSN character
         BCT   R0,B2DSN020             Keep building
*
         STCM  R1,3,2(R3)              Set the # field (# qualifiers)
         STCM  R6,3,0(R4)              Fill in length field
         LA    R3,2(R6,R4)             -> next length field area
         BR    R14                     Return
*
B3FSIZE  EQU   *
         MVC   0(2,R3),INMSIZE         Set key
         MVC   2(2,R3),=Y(1)           Set #
         MVC   4(2,R3),=Y(4)           Set length
         MVC   6(4,R3),FILESIZE        File size in bytes
         LA    R3,10(,R3)              -> next available byte
         BR    R14                     Return
*
B3DSORG  EQU   *
         MVC   0(2,R3),INMDSORG        Set key
         MVC   2(2,R3),=Y(1)           Set #
         MVC   4(2,R3),=Y(2)           Set length
         MVC   6(2,R3),=X'4000'        Set DSORG to PS in INMR03
         LA    R3,8(,R3)               -> next available byte
         BR    R14                     Return
*
B3LRECL  EQU   *
         MVC   0(2,R3),INMLRECL        Set key
         MVC   2(2,R3),=Y(1)           Set #
         MVC   4(2,R3),=Y(4)           Set length
         MVC   6(4,R3),=A(80)          LRECL always 80 for INMR03
         LA    R3,10(,R3)              -> next available byte
         BR    R14                     Return
*
B3RECFM  EQU   *
         MVC   0(2,R3),INMRECFM        Set key
         MVC   2(2,R3),=Y(1)           Set #
         MVC   4(2,R3),=Y(2)           Set length
         MVC   6(2,R3),=X'0001'        Shortened transmission var fmt
         LA    R3,8(,R3)               -> next available byte
         BR    R14                     Return
*
*
*-- Request some more bytes of NETDATA formatted data
*
*-- Entry:  R0 = # of bytes to write   (1-255)
*--         BUFF contains the data
*
*-- Exit:   None
*
*-- Uses R0-R1,R5-R8,R14-R15; the caller's values in these
*--      registers are not preserved across this call.
*
PUTBYTES EQU   *
         ST    R14,SV14PB              Save return addr
         L     R5,PBREM                Get # bytes remaining in rec buf
         LA    R1,BUFF                 Point to putbytes (PB) buffer
         ST    R1,PBPOS                Set starting position
*
         LR    R8,R0                   Requested amount to R8
*
*
PB010    EQU   *
         LTR   R5,R5                   Any bytes left in phys record?
         BP    PB040                   Yes, use them first
*
         BAL   R14,PUT000              Write the record
         LTR   R15,R15                 Any errors?
         BNZ   XITNET08                Exit if yes
*
         LA    R5,80                   Reset record to 80 remaining
         LA    R1,REC                  -> physical record
         ST    R1,PBRPS                Reset start of record position
*
PB040    EQU   *
         LR    R7,R8                   Assume requested amt avail
         LR    R15,R8                  Same
*
         CR    R5,R8                   Have more than we need?
         BH    PB050                   Yes, just move requested
         LR    R7,R5                   Else move only what we have avai
         LR    R15,R5                  Same
*
PB050    EQU   *
         LR    R0,R7                   Save copy of length to move
         L     R14,PBPOS               -> PB buffer position
         L     R6,PBRPS                -> output record curr position
         MVCL  R6,R14                  Move
*
         ST    R14,PBPOS               New PB position
         ST    R6,PBRPS                New phys record curr position
*
         SR    R5,R0                   Reduce bytes left in phy record
         SR    R8,R0                   Reduce requested amt
         BP    PB010                   We need more, go get it
*
         ST    R5,PBREM                Remember whats left in phy rec
*
         L     R14,SV14PB              Load  return addr
         BR    R14                     Return from getbytes
*
*
*
*-- Exits from NJENET
*
XITNET00 EQU   *
         SR    R15,R15
         B     XITNET
*
XITNET08 EQU   *
         LA    R15,8                   I/O writing records
         B     XITNET
*
XITNET   EQU   *
         L     R13,4(,R13)             -> prev s.a.
         ST    R15,16(,R13)            Set RC
         LM    R14,R12,12(R13)         Reload callers regs
         BR    R14                     Return with RC
*
*
         LTORG
*
NONLEAP  DC    PL2'31,59,90,120,151,181,212,243,273,304,334,365'
LEAP     DC    PL2'31,60,91,121,152,182,213,244,274,305,335,366'
*
*-- Find INMR01 record
*                                                                       NET02190
*                                                                       NET02190
*- Control records that we look for and process (others ignored).       NET02190
INMR01   DC    C'INMR01'               Header Control record            NET02200
INMR02   DC    C'INMR02'               File Utility Control record      NET02210
INMR03   DC    C'INMR03'               Data Control record              NET02210
INMR06   DC    C'INMR06'               Trailer Control record           NET02210
*                                                                       NET02220
*- Keys we are supporting                                               NET02230
INMKEYS  DS    0H
INMBLKSZ DC    X'0030'                 Block size
INMDIR   DC    X'000C'                 Number of directory blocks
INMDSNAM DC    X'0002'                 Name of the file
INMDSORG DC    X'003C'                 File organization
INMFNODE DC    X'1011'                 Origin node name or node number
INMFTIME DC    X'1024'                 Origin timestamp
INMFUID  DC    X'1012'                 Origin user ID
INMLRECL DC    X'0042'                 Logical record length
INMRECFM DC    X'0049'                 Record format
INMSIZE  DC    X'102C'                 File size in bytes
INMTNODE DC    X'1001'                 Target node name or node number
INMTUID  DC    X'1002'                 Target user ID
INMUTILN DC    X'1028'                 Name of utility program
INMNUMF  DC    X'102F'                 Number of files transmitted = 1
         DC    X'FFFF'                 End of table
*                                                                       NET02220
*- Keys we are NOT supporting; for reference                            NET02230
INMCREAT EQU   X'1022'                 Creation date
INMDDNAM EQU   X'0001'                 DDNAME for the file
INMEATTR EQU   X'8028'                 Extended attribute status
INMERRCD EQU   X'1027'                 RECEIVE command error code
INMEXPDT EQU   X'0022'                 Expiration date
INMFACK  EQU   X'1026'                 Originator requested notificat'n
INMFFM   EQU   X'102D'                 Filemode number
INMFVERS EQU   X'1023'                 Origin version num of the data
INMLCHG  EQU   X'1021'                 Date last changed
INMLREF  EQU   X'1020'                 Date last referenced
INMLSIZE EQU   X'8018'                 Data set size in megabytes.
INMMEMBR EQU   X'0003'                 Member name list
INMRECCT EQU   X'102A'                 Transmitted record count
INMSECND EQU   X'000B'                 Secondary space quantity
INMTERM  EQU   X'0028'                 Data transmitted as a message
INMTYPE  EQU   X'8012'                 Data set type
INMTTIME EQU   X'1025'                 Destination timestamp
INMUSERP EQU   X'1029'                 User parameter string
*
*-- Target fields from INMRxx control records that we issue:
*
*
*                       INMR0x    R=required to be sent
*                       1 2 3 6   X=may optionally be sent
INMFIELD DSECT          - - - -
UTLNAME  DS    CL8        R           Utility name                      NET02490
FNODE    DS    CL8      R             Origin node                       NET02580
FUSER    DS    CL8      R             Origin userid                     NET02580
TNODE    DS    CL8      R             Dest node                         NET02580
TUSER    DS    CL8      R             Dest userid                       NET02580
FILESIZE DS    XL4        R R         File size in bytes                NET02500
DIRBLKS  DS    XL4        X           #directory blocks                 NET02500
BLKSIZE  DS    XL4        X           BLKSIZE                           NET02510
LRECL    DS    XL4      R R R         LRECL                             NET02520
DSORG    DS    XL2        R R         DSORG                             NET02540
RECFM    DS    XL2        R R         RECFM                             NET02530
DSNAME   DS    CL44       X           DSNAME                            NET02580
FTIME    DS    CL20     R             Origin time stamp                 NET02580
         DS    0F                     Force to halfword size
INMFSZ   EQU   *-INMFIELD             Size of DSECT
*
*                                                                       NJE00250
*********************
*  N J E P A R      *               NJEPAR calls IKJPARS to parse
*                   *               the TSO command line parameters.
*  TSO Command Line *
*  Parse            *
*                   *
*********************
*
*  Entry:  None.
*
*
*  Exit:   R15 = IKJPARS RC
*
NJEPAR   CSECT
         B     28(,R15)               BRANCH AROUND EYECATCHERS
         DC    AL1(23)                LENGTH OF EYECATCHERS
         DC    CL9'NJEPAR'
         DC    CL9'&SYSDATE'
         DC    CL5'&SYSTIME'
*
         STM   R14,R12,12(R13)         Save Regs                        NJE00050
         LR    R12,R15                 Base                             NJE00060
         USING NJEPAR,R12                                               NJE00070
         USING NJEWK,R10
         ST    R13,PARSA+4             SAVE prv S.A. ADDR               NJE00080
         LA    R2,PARSA                -> my save area
         ST    R2,8(,R13)              Plug it into prior SA
         LR    R13,R2
*
*
         LR    R7,R0                   Copy entry action code
         LR    R6,R1                   Copy any passed ptr
*
*-- Identify and parse out the nodeid.userid if present
*
NOD000   EQU   *
         L     R1,CPARMS               -> CPPL entry parms
         L     R2,0(,R1)               -> Command buffer
         LH    R3,0(,R2)               Get length of command buffer
         C     R3,=F'257'              Is buffer length within 256?
         BL    NOD010                  Yes
         LA    R3,256                  Set to max of 256
*
NOD010   EQU   *
         LR    R4,R3                   Copy final length
         ICM   R3,8,BLANKS             Set pad character
         LA    R0,BUFF                 -> internal 256 byte work buffer
         LA    R1,256                  Max length
         MVCL  R0,R2                   Move CBUF to our stg area
*
         STH   R4,BUFF                 Set adjusted buffer length
         MVC   REC,BLANKS              Use as temporary TRT over-
         MVC   LIST,BLANKS              flow areas
*
NOD020   EQU   *
         SR    R1,R1                   Clear
         LA    R3,BUFF+4               -> copy of cmd buffer (past RDW)
         AH    R3,BUFF+2               -> first parameter
         SH    R4,BUFF+2               Reduce remaining length
         S     R4,=F'4'                Back out length of buffer RDW
         BZ    XITPAR04                No parameters were entered
*
         EX    R4,TRTBLK               Look for end of first param
         BZ    PARS000                 Something wrong, give to parse
         LR    R5,R1                   Save end of param addr
         SR    R1,R3                   Compute length we traversed
         LR    R6,R1                   Save copy of length to R6
         C     R1,=F'3'                Length < 3?
         BL    PARS000                 Can't be node.user
         C     R1,=F'17'               Length > 17?
         BH    PARS000                 Can't be node.user
*
         BCTR  R1,0                    Adjust for execute
         EX    R1,TRTNAN               Look for any non-alphanumeric
         BNZ   PARS000                 Found something, not node.user
*
         EX    R6,TRTDLM               Look for '.' delimiter
         BZ    PARS000                 Didn't find it, not node.user
         LA    R4,1(,R1)               Save addr of userid start
         SR    R1,R3                   Compute length from start to dot
         BZ    PARS000                 Not valid node name
         C     R1,=F'8'                More than 8 char in node name?
         BH    XITPAR08                Not valid node name
         MVC   DESTNODE,BLANKS         Init receiving field
         BCTR  R1,0                    Adjust for execute
         EX    R1,OCNODE               Save off node name and uppercase
         LA    R1,1(,R1)               Restore length
         SR    R6,R1                   Reduce length by node name size
         BCTR  R6,0                    Reduce length of '.'
         LTR   R6,R6                   is len=0? (. in last character)
         BZ    XITPAR08                Not valid node.user combo
         C     R6,=F'8'                Userid > 8?
         BH    XITPAR08                Not valid user name
         MVC   DESTUSER,BLANKS         Init receiving field
         BCTR  R6,0                    Adjust for execute
         EX    R6,OCUSER               Save off user name and uppercase
*
         SR    R5,R3                   Compute area size of node.user
         BCTR  R5,0                    Adjust for execute
         EX    R5,MVCREM               Remove node.user from cmd buffer
         OI    FLAGS3,F3DEST           Valid node.user specified
         B     PARS000                 Turn the rest over to parser
*
MVCREM   MVC   0(0,R3),BLANKS          executed instr
OCNODE   OC    DESTNODE(0),0(R3)       executed instr
OCUSER   OC    DESTUSER(0),0(R4)       executed instr
TRTBLK   TRT   0(0,R3),BLANK           executed instr
TRTDLM   TRT   0(0,R3),DOTS            executed instr
TRTNAN   TRT   0(0,R3),NONALNUM        executed instr
*
*
PARS000  EQU   *
         L     R1,CPARMS               -> CPPL entry parms
         LM    R2,R5,0(R1)             Get TSO command entry parameters
*                                       R2 -> Command buffer
*                                       R3 -> UPT
*                                       R4 -> PSCB
*                                       R5 -> ECT
*
         LA    R8,PPLSTG               -> PPL
         USING PPL,R8
         ST    R3,PPLUPT               Set UPT addr
         ST    R5,PPLECT               Set ECT addr
         LA    R3,PARSECB              -> parse ECB
         ST    R3,PPLECB               Set it
         LA    R3,ANSWER               -> IKJPARS "answer area"
         ST    R3,PPLANS               Set it
         ST    R10,PPLUWA              Set user work area addr
*
*                                   ** Process command line
         LA    R2,BUFF                 -> local copy of TSO cmd buff
         ST    R2,PPLCBUF              Set TSO command buffer addr
         L     R3,=A(PCLDEFS)          -> command parms definitions
         ST    R3,PPLPCL               Set it
         B     PARS020
*
PARS020  EQU   *
         CALLTSSR EP=IKJPARS,MF=(E,PPLSTG)   Parse command line
         LTR   R0,R15                  Any parse errors?
         BNZ   XITPAR12                Yes
         DROP  R8                      PPL
*
*- Examine command line results
         L     R4,ANSWER               -> IKJPARS built PCEs
         USING PRDSECT,R4
*
PARS030  EQU   *
         LA    R2,QTPCE                -> QUIET PCE
         CLC   0(2,R2),=AL2(1)         Was QUIET specified?
         BNE   PARS035                 No
         OI    FLAGS3,F3QUIET          Indicate QUIET
*
PARS035  EQU   *
         LA    R2,PDSPCE               -> PDS/SEQL PCE
         CLC   0(2,R2),=AL2(2)         Was PDS specified?
         BNE   PARS040                 No
         OI    FLAGS3,F3PDS            Indic PDS copy and not SEQL copy
*
PARS040  EQU   *
         LA    R2,VOLPCE               -> VOLSER PCE
         TM    6(R2),X'80'             Was VOLSER specified?
         BZ    PARS050                 No
         L     R3,0(,R2)               -> VOLSER string
         LH    R1,4(,R2)               Length of volser
         MVC   OUTVOL,BLANKS           Init receiving field
         BCTR  R1,0                    Adjust for execute
         EX    R1,MVVOL                Move the volser
         OI    FLAGS3,F3VOLSER         Indicate volser valid
*
PARS050  EQU   *
         LA    R2,OTDAPCE              -> OUTDATASET PCE
         TM    6(R2),X'80'             Was OUTDATASET specified?
         BZ    PARS080                 No
         MVC   OUTPUTDS,BLANKS         Init receiving field
         LA    R5,OUTPUTDS             -> where to place DSN
*
         TM    6(R2),X'40'             Was dataset name in quotes?
         BO    PARS060                 Y, don't insert prefix
         CLC   PREFIX,BLANKS           Is a prefix available?
         BE    PARS060                 All blank, dont use prefix
*
         MVC   OUTPUTDS(8),PREFIX      Add the prefix
         TRT   OUTPUTDS,BLANK          Look for end of prefix
         MVI   0(R1),C'.'              Set delim after prefix
         LA    R5,1(,R1)               -> place to put rest of dsn
         LA    R2,OTDAPCE              -> OUTDATASET PCE
*
PARS060  EQU   *
         L     R3,0(,R2)               -> OUTDATASET string
         LH    R1,4(,R2)               Length of DSN
         BCTR  R1,0                    Adjust for execute
         EX    R1,MVDS                 Move the DSN
         OI    FLAGS3,F3OUTDS          Indicate OUTDATASET valid
*
PARS070  EQU   *
         TM    14(R2),X'80'            Was OUTDATASET member specified?
         BZ    PARS080                 No
         L     R3,8(,R2)               -> OUTDATASET member name
         LH    R1,12(,R2)              Length of member name
         MVC   OUTMEM,BLANKS           Init receiving field
         BCTR  R1,0                    Adjust for execute
         EX    R1,MVOUTMEM             Move the member name
         OI    FLAGS3,F3OUTMEM         Indicate OUTDATASET member valid
*
PARS080  EQU   *
         LA    R2,FDAPCE                -> DATASET PCE
         TM    6(R2),X'80'             Was DATASET specified?
         BZ    PARS130                 No                          v200
         MVC   INPUTDS,BLANKS          Init receiving field
         LA    R5,INPUTDS              -> where to place DSN
*
         TM    6(R2),X'40'             Was dataset name in quotes?
         BO    PARS090                 Y, don't insert prefix
         CLC   PREFIX,BLANKS           Is a prefix available?
         BE    PARS090                 All blank, dont use prefix
*
         MVC   INPUTDS(8),PREFIX       Add the prefix
         TRT   INPUTDS,BLANK           Look for end of prefix
         MVI   0(R1),C'.'              Set delim after prefix
         LA    R5,1(,R1)               -> place to put rest of dsn
         LA    R2,FDAPCE               -> DATASET PCE
*
PARS090  EQU   *
         L     R3,0(,R2)               -> DATASET string
         LH    R1,4(,R2)               Length of DSN
         BCTR  R1,0                    Adjust for execute
         EX    R1,MVDS                 Move the DSN
         OI    FLAGS3,F3INDS           Indicate DATASET valid
*
PARS100  EQU   *
         TM    14(R2),X'80'            Was DATASET member specified?
         BZ    PARS120                 No
         L     R3,8(,R2)               -> DATASET member name
         LH    R1,12(,R2)              Length of member name
         MVC   INMEM,BLANKS            Init receiving field
         BCTR  R1,0                    Adjust for execute
         EX    R1,MVINMEM              Move the member name
         OI    FLAGS3,F3INMEM          Indicate SEQL MEMBER specified
         B     PARS130                 We're done                  v200
*
PARS120  EQU   *
         NI    FLAGS3,255-F3PDS        Turn off;we'll do what DSORG say
*
PARS130  EQU   *                                                   v200
         LA    R2,UNIPCE               -> UNIT PCE                 v200
         TM    6(R2),X'80'             Was UNIT specified?         v200
         BZ    PARS190                 No                          v200
         L     R3,0(,R2)               -> UNIT string              v200
         LH    R1,4(,R2)               Length of unit name         v200
         MVC   OUTUNIT,BLANKS          Init receiving field        v200
         BCTR  R1,0                    Adjust for execute          v200
         EX    R1,MVUNIT               Move the unit               v200
         OI    FLAGS2,F2UNIT           Indicate unit valid         v200
*
PARS190  EQU   *
         B     XITPAR00                All done
         DROP  R4                      PRDSECT
*
MVVOL    MVC   OUTVOL(0),0(R3)         executed instr
MVDS     MVC   0(0,R5),0(R3)           executed instr
MVINMEM  MVC   INMEM(0),0(R3)          executed instr
MVOUTMEM MVC   OUTMEM(0),0(R3)         executed instr
MVUNIT   MVC   OUTUNIT(0),0(R3)        executed instr              v200
*
*
*-- Exit
*
XITPAR00 EQU   *
         LA    R1,ANSWER               -> IKJPARS "answer place"
         IKJRLSA (1)                   Release parsing storage
*
         SR    R0,R0               Set secondary RC=0
         SR    R15,R15             Set RC=0;
         B     XITPAR
*
XITPAR04 EQU   *
         SR    R0,R0               Set secondary RC=0
         LA    R15,4               Set RC=4; no parameters entered
         B     XITPAR
*
XITPAR08 EQU   *
         SR    R0,R0               Set secondary RC=0
         LA    R15,8               Set RC=8; invalid node.user combo
         B     XITPAR
*
XITPAR12 EQU   *
         LA    R15,12              Set RC=12; R0 already set by IKJPARS
         B     XITPAR
*
XITPAR   EQU   *
         L     R13,4(,R13)         -> prev s.a.
         L     R14,12(,R13)        Load r14
         LM    R1,R12,24(R13)      Reload callers regs
         BR    R14                 Return with RCs in R0/R15
*
         LTORG
*
*-- IKJPARS Description Macros
*
*-- TRANSMIT command parms:
*
*    TRANSMIT  node.userid DATASET(ddd) OUTDATASET(ooo) VOLSER(vvvvv)
*                          PDS | SEQUENTIAL
*                          QUIET
*
*   Where:
*
*     node.user is the node and userid destination for the file.
*     ddd is the dataset(+member) to be transmitted.
*     ooo is the optional output dataset to write the NETDATA encoded
*         transmission into in lieu of actually sending it.
*     vvv is an optional VOLSER of where to allocate the OUTDATASET.
*
*
PCLDEFS  IKJPARM DSECT=PRDSECT
*
*
QTPCE    IKJKEYWD
         IKJNAME  QUIET            PCE value = 1
*
PDSPCE   IKJKEYWD DEFAULT='SEQUENTIAL'
         IKJNAME  SEQUENTIAL       PCE value = 1
         IKJNAME  PDS              PCE value = 2
*
OTDSPCE  IKJKEYWD
         IKJNAME  'OUTDATASET',SUBFLD=OTDSFLD,ALIAS='OUTDSNAME'
*
FDSPCE   IKJKEYWD
         IKJNAME  'DATASET',SUBFLD=FDSFLD,ALIAS='DSNAME'
*
VSRPCE   IKJKEYWD
         IKJNAME  'VOLSER',SUBFLD=VOLSFLD,ALIAS='VOLUME'
*
USRPCE   IKJKEYWD ,                                                v200
         IKJNAME  'UNIT',SUBFLD=UNISFLD,ALIAS=('U')                v200
*
OTDSFLD  IKJSUBF
OTDAPCE  IKJPOSIT DSNAME,                                              x
               PROMPT='THE NAME OF THE DATA SET YOU WANT TO CONTAIN THEx
                ENCODED FILE'
*
FDSFLD   IKJSUBF
FDAPCE   IKJPOSIT DSNAME,                                              x
               PROMPT='THE NAME OF THE DATA SET YOU WANT TO TRANSMIT'
*
VOLSFLD  IKJSUBF
VOLPCE   IKJPOSIT DSTHING,VOLSER,                                      x
               PROMPT='THE VOLUME SERIAL OF THE VOLUME WHERE YOU WANT Tx
               HE OUTDATASET ALLOCATED'
*
UNISFLD  IKJSUBF ,                                                 v200
UNIPCE   IKJIDENT 'UNIT NAME',MAXLNTH=8,FIRST=ALPHANUM,            v200x
               OTHER=ALPHANUM                                      v200
*
         IKJENDP
*
*
*
         IKJPPL
IKJPPLSZ EQU   (*-PPL)/4           # words in PPL
*
         LTORG
*
*                                                                     *
***********************************************************************
**                                                                   **
**                        TASK ESTAE EXIT                            **
**                                                                   **
** This csect handles all abends trapped by ESTAE during the normal  **
** execution of the subtask.          This exit does not attempt     **
** any recovery other than to terminate processing.                  **
** An SVC dump is taken on abends.                                   **
**                                                                   **
** On entry:  R0=ESTAE provide entry code                            **
**            R1=SDWA address                                        **
**            R2=parameter passed on ESTAE macro                     **
**                                                                   **
**                                                                   **
** On exit: If SDWACLUP is 1, then no retry is allowed and this      **
**             exit will allow percolation back to system routines   **
**             to terminate the task.                                **
**                                                                   **
**          If SDWACLUP is 0, then retry is allowed.                 **
**                                                                   **
** Security:  N/A.                                                   **
**                                                                   **
** Register usage:                                                   **
**                                                                   **
**   R1  = SDWA address                                              **
**   R3  = SDWA address                                              **
**   R10 = Dynamic storage area base                                 **
**   R12 = This program base                                         **
**                                                                   **
**                                                                   **
**                                                                   **
***********************************************************************
*
NJEDMP   CSECT
         B     28(,R15)               BRANCH AROUND EYECATCHERS
         DC    AL1(23)                LENGTH OF EYECATCHERS
         DC    CL9'NJEDMP'
         DC    CL9'&SYSDATE'
         DC    CL5'&SYSTIME'
*
         LR    R12,R15                SET UP BASE REG
         USING NJEDMP,R12             ESTABLISH ADDRESSABILITY
         LR    R8,R14                 SAVE RETURN ADDRESS TO SYSTEM
*
         L     R10,0(,R1)             GET VALUE PASSED TO US (WORKA)
         USING NJEWK,R10
         L     R11,=A(NJECOM)          -> common csect
         USING NJECOM,R11
*
         LR    R3,R1                  SAVE R1 ENTRY CONTENTS
         USING SDWA,R3
         LR    R5,R0                  Save R0 entry code
*
         LTR   R3,R3                  Do we have an SDWA?
         BZ    NOSDWA                 Exit if no SDWA
         LA    R13,MVSSAVE            Save area
         ESTAE 0
*
         MODESET MODE=SUP,            Run this ESTAI exit privileged   x
               KEY=ZERO                to access PSW -> storage
*
         MVC   MACLIST(WTOMSGL),WTOMSG
         L     R6,PSATOLD-PSA(0)      -> my TCB
         L     R5,TCBTIO-TCB(,R6)     -> TIOT
         MVC   MACLIST+9(8),0(R5)         Plug in job name
         MVC   MACLIST+4(4),=C'USER'
         MVC   MACLIST+19(8),=C'TRANSMIT' Plug in command name
*
*
LNK020   EQU   *
         MVC   MACLIST+29(5),=C'ABEND'
         L     R5,SDWAABCC              GET ABEND CODE INFO WORD
         N     R5,=X'00FFF000'          KEEP ONLY THE SYSTEM CODE
         BZ    USERCDE                  NONE THERE, MUST BE A USER CODE
         SRL   R5,12                    Put sys code in low order  v201
         C     R5,=X'00000222'          Operator cancel, no dump?  v201
         BE    SDUMP040                 Yes, suppress dump
         CLM   R5,1,=X'3E'              Was it an x3E (DETACH) ?   v201
         BE    SDUMP040                 Yes, suppress dump         v201
         C     R5,=X'00000013'          Open 013 abend?            v201
         BNE   ACCPT                    no, do the dump            v200
         CLC   SDWAGR15,=X'00000018'    Was it 013-18?             v200
         BE    SDUMP060                 Yes, suppress dump         v200
*
ACCPT    EQU   *                                                   v200
         MVI   MACLIST+35,C'S'          INDICATE SYSTEM CODE
         UNPK  FWORK(5),SDWACMPC(3)     GET SYSTEM CMP CODE
         TR    FWORK(3),HEXTRAN-240
         MVC   FWORK+3(5),=CL5' '       CLEAR REST OF ABEND CODE
         B     NOREAS
*
USERCDE  EQU   *
         MVI   MACLIST+35,C'U'         INDICATE USER ABEND CODE
         L     R5,SDWAABCC             GET ABEND CODE
         N     R5,=X'00000FFF'         KEEP USER ABEND CODE
         CVD   R5,FSAVE                CONVERT CODE TO DECIMAL
         UNPK  FWORK(4),FSAVE          UNPK THE CODE
         OI    FWORK+3,X'F0'           FIX SIGN
         MVC   FWORK+4(2),=CL2' '      BLANKS AT END OF ABEND CODE
*
NOREAS   EQU   *
         MVC   MACLIST+36(6),FWORK     MOVE ABEND-REASON TO LINE
         MVC   ABCODE,MACLIST+36       Save a copy of formatted abcode
*
         WTO   ,MF=(E,MACLIST)        Write to console
         LA    R2,MACLIST
         BAL   14,PUTLINE             Echo to TSO terminal
*
         MVC   MACLIST(WTOMSGL),WTOMSG
         MVC   MACLIST+4(3),=C'PSW'
         UNPK  FSAVE(9),SDWAEC1(5)    Add zones to PSW word 1
         TR    FSAVE(8),HEXTRAN-240
         MVC   MACLIST+10(8),FSAVE
         UNPK  FSAVE(9),SDWAEC1+4(5)  Add zones to PSW word 2
         TR    FSAVE(8),HEXTRAN-240
         MVC   MACLIST+19(8),FSAVE
*
         SR    R5,R5                   CLEAR FOR IC
         IC    R5,SDWAILC1             GET THE ILC
         CVD   R5,FWORK                MAKE DECIMAL
         MVC   MACLIST+29(3),=C'ILC'
         UNPK  MACLIST+33(2),FWORK     UNPK
         OI    MACLIST+34,X'F0'        FIX THE SIGN
*
         MVC   MACLIST+37(4),=C'INTC'
         UNPK  FWORK(5),SDWAINC1(3)    MAKE INTC DISPLAYABLE
         TR    FWORK(4),HEXTRAN-240
         MVC   MACLIST+42(4),FWORK     MOVE INTC TO LINE
*
         WTO   ,MF=(E,MACLIST)
         LA    R2,MACLIST
         BAL   14,PUTLINE             Echo to TSO terminal
*
         MVC   MACLIST(WTOMSGL),WTOMSG
         MVC   MACLIST+4(13),=C'DATA NEAR PSW'
         MVC   MACLIST+19(8),=CL8'UNAVAIL'  ASSUME WE CANT GET DATA
         L     R4,SDWAEC1+4            Get PSW IA
         LA    R4,0(,R4)               Clear high bit
         C     R4,=F'8'                1st 8 bytes of storage?
         BH    LOC010                  No, its higher than that
         SR    R4,R4                   Yes, just use 0
         B     LOC020
*
LOC010   EQU   *
         S     R4,=F'8'                BACK UP BEFORE INTERRUPT ADDR
*
LOC020   EQU   *
         LRA   R0,0(,R4)               Do we have access?
         BNZ   UNAVAIL                 No translation, better not
         LRA   R0,14(,R4)              Do we have access?
         BNZ   UNAVAIL                 No translation, better not
*
         ST    R4,FWORK                SAVE FOR CONVERSION
         UNPK  FSAVE(9),FWORK(5)       ADD ZONES TO ADDRESS
         TR    FSAVE(8),HEXTRAN-240    MAKE DISPLAYABLE HEX
         MVC   MACLIST+19(8),FSAVE     MOVE DISPLAYABLE
*
         MVC   FWORK(4),0(R4)          MOVE 4 WORDS AT PSW
         UNPK  FSAVE(9),FWORK(5)       ADD ZONES
         TR    FSAVE(8),HEXTRAN-240    MAKE DISPLAYABLE HEX
         MVC   MACLIST+29(8),FSAVE     MOVE TO LINE
*
         MVC   FWORK(4),4(R4)          MOVE 4 WORDS AT PSW
         UNPK  FSAVE(9),FWORK(5)       ADD ZONES
         TR    FSAVE(8),HEXTRAN-240    MAKE DISPLAYABLE HEX
         MVC   MACLIST+38(8),FSAVE     MOVE TO LINE
*
         MVC   FWORK(4),8(R4)          MOVE 4 WORDS AT PSW
         UNPK  FSAVE(9),FWORK(5)       ADD ZONES
         TR    FSAVE(8),HEXTRAN-240    MAKE DISPLAYABLE HEX
         MVC   MACLIST+47(8),FSAVE     MOVE TO LINE
*
         MVC   FWORK(4),12(R4)         MOVE 4 WORDS AT PSW
         UNPK  FSAVE(9),FWORK(5)       ADD ZONES
         TR    FSAVE(8),HEXTRAN-240    MAKE DISPLAYABLE HEX
         MVC   MACLIST+56(8),FSAVE     MOVE TO LINE
*
UNAVAIL  EQU   *
         WTO   ,MF=(E,MACLIST)
         LA    R2,MACLIST
         BAL   14,PUTLINE              Echo to TSO terminal
*----
         LA    R4,4                    4 ROWS OF REGISTERS
         LA    R5,SDWAGR00             POINT TO ABEND REGS
         LA    R6,REGLIST              POINT TO REGISTER ID LITERALS
*
REG000   EQU   *
         MVC   MACLIST(WTOMSGL),WTOMSG
         MVC   MACLIST+4(8),0(R6)      MOVE REGISTERS ID
         LA    R15,MACLIST+13          WHERE 1ST REG GOES ON LINE
         LA    R14,4                   4 REGS PER LINE
*
REG010   EQU   *
         UNPK  FSAVE(9),0(5,R5)        UNPK A REGISTER
         TR    FSAVE(8),HEXTRAN-240    MAKE DISPLAYABLE HEX
         MVC   0(8,R15),FSAVE          MOVE TO THE LINE
         LA    R15,10(,R15)            NEXT SPOT ON PRINT LINE
         LA    R5,4(,R5)               NEXT REGISTER
         BCT   R14,REG010              KEEP DOING REGS
         WTO   ,MF=(E,MACLIST)
         LA    R2,MACLIST
         BAL   14,PUTLINE              Echo to TSO terminal
         LA    R6,8(,R6)               NEXT REGISTER ID
         BCT   R4,REG000               GO DISPLAY THE NEXT ROW
*
*
SDUMP000 EQU   *
         L     R5,SDWAABCC             Get abend code info word
         N     R5,=X'00FFF000'         Keep only the system code
         SRL   R5,12                   Right justify the code
         C     R5,=X'00000222'         Operator cancel, no dump?
         BE    SDUMP040                Yes, skip dump
         CLM   R5,1,=X'37'             x37 abend code?
         BE    SDUMP040                Skip the dump
*
         MVI   DHDR,C' '
         MVC   DHDR+1(29),DHDR
         MVI   DHDR,29                IBM length of header
         L     R5,PSATOLD-PSA(0)      -> my TCB
         L     R5,TCBTIO-TCB(,R5)     -> TIOT
         MVC   DHDR+1(8),0(R5)        Use jobname in description
         MVC   DHDR+11(8),=C'TRANSMIT' Use command name
         MVC   DHDR+21(7),ABCODE
*
         MVC   MACLIST(SDUMPL),SDUMP    MOVE SDUMP LIST TO WORK
         LA    R1,MACLIST
         SDUMP HDRAD=DHDR,              ISSUE SDUMP TO RECORD STATUS   x
               BUFFER=NO,                                              x
               QUIESCE=NO,                                             x
               SDATA=(RGN,CSA,LPA,SUM),                                x
               MF=(E,(1))
*
*
SDUMP040 EQU   *
         LR    R1,R3                  SDWA BACK TO R1
         L     R15,=A(NJETRN)         Main csect addr
         ST    R15,SDWASRSV+4*R12     Plug it to R12
         L     R15,=A(EXIT08)         -> TRANSMIT exit point
         B     SDUMP090                                            v200
*
SDUMP060 EQU   *                  **  Here for S013-18 abend only  v200
         LR    R1,R3                  SDWA BACK TO R1              v200
         L     R15,=A(NJETRN)         Main csect addr              v200
         ST    R15,SDWASRSV+4*R12     Plug it to R12               v200
         L     R15,=A(ERR015)         -> TRANSMIT ERRMSG           v200
*
SDUMP090 EQU   *
         SETRP RC=4,                  Retry - try to shut down TRANSMITx
               DUMP=NO,               Suppress any further dumps       x
               FRESDWA=YES,           Free the SDWA                    x
               RETREGS=YES,           Restore original regs            x
               RETADDR=(15)           Return to Transmit exit point
*
NOSDWA   EQU   *                  **  NO RETRY AVAILABLE (OR DESIRED)
         SR    R15,R15                REQUEST PERCOLATION
         LR    R14,R8                 RESTORE RETURN ADDRESS
         BR    R14                    RETURN TO SYSTEM
*
         LTORG
*
SDUMP    SDUMP MF=L
SDUMPL   EQU   *-SDUMP
*
REGLIST  DC    CL8'GR 0-3'
         DC    CL8'GR 4-7'
         DC    CL8'GR 8-11'
         DC    CL8'GR 12-15'
*
WTOMSG   WTO   '                                                       x
                                             ',MF=L
WTOMSGL  EQU   *-WTOMSG
*
         LTORG
*
*
****  Main work area common                                             NJE00290
****  to all NJExxx CSECTs.                                             NJE00290
*                                                                       NJE00290
NJEWK    DSECT
NJEEYE   DS    CL4'NJET'           Eyecatcher
NJEWKLEN DS    F                   Getmain size of this area
*
DBLE     DS    D                   Work area                            NJE00310
TWRK     DS    2D                  Work area
LCLNODE  DS    CL8                 Local node id
DEFUSER  DS    CL8                 Default 'no security' userid
USERID   DS    CL8                 TSO Userid
PREFIX   DS    CL8                 TSO PREFIX
DESTNODE DS    CL8                 Destination node
DESTUSER DS    CL8                 Destination userid
SPLDSN   DS    CL44                NETSPOOL dataset name
*
*
MACLIST  DS    CL96                   Macro expansion area
STAXLIST DS    CL20                   STAX parameter list
*                                                                       NET02360
CPARMS   DS    A                      -> input CPPL (entry parms)
PUTECB   DS    F                      ECB for PUTLINE
IOPLAREA DS    4A                     IOPL for PUTLINE
SV14PUT  DS    A                      R14 save area
SV14LN   DS    A                      R14 save area                     NET02370
SV14PB   DS    A                      R14 save area                     NET02370
SV14SI   DS    A                      R14 save area                     NET02370
*
PBREM    DS    F                      # bytes remaining in phys rec
PBPOS    DS    A                      -> current position in BUFF
PBRPS    DS    A                      -> current position in phys rec
OUTRECS  DS    F                      Count of output records written
*
BLOCKLEN DS    F                      Length of block buffer
BLOCK    DS    A                      -> Block of physical records
*
DEVINFO  DS    0XL20                  5 WORDS OF DEVTYPE INFO
DEVUCBTY DS    F                       DEV TYPE: VALUE OF UCBTYP FIELD
DEVMAXBK DS    F                       MAXIMUM BLKSIZE ON DEVICE
DEVCYLS  DS    XL2                     NUMBER OF CYLINDERS ON DEVICE
DEVTRKS  DS    XL2                     NUMBER OF HEADS ON DEVICE
DEVNUSED DS    0XL8                    2 WORDS NOT USED HERE
*
OLD      DS    F                      For PUTGET, # segments
OLDMSGAD DS    A                      -> msg len/text
*
PARSECB  DS    F                      IKJPARS ECB
ANSWER   DS    F                      IKJPARS Answer area
PPLSTG   DS    (IKJPPLSZ)A            Space for PPL
OUTVOL   DS    CL6                    User specified output volser
OUTPUTDS DS    CL44                   User specified OUTDATASET DSN
OUTMEM   DS    CL8                    User specified OUTDATASET member
OUTUNIT  DS    CL8                    User specified UNIT name     v200
INPUTDS  DS    CL44                   Input dataset name
INMEM    DS    CL8                    User specified input member
*
*
FLAGS1   DS    X                      Flag bits
F1INPDS  EQU   X'80'  1... ....        Input dataset is a PDS, 0=SEQL
F1ATTN   EQU   X'40'  .1.. ....        User pressed ATTN key       v201
F1BATCH  EQU   X'08'  .... 1...        Running in BATCH TSO
F1ACEE   EQU   X'04'  .... .1..        Security is available on system
F1AUSR   EQU   X'02'  .... ..1.        Special user
F1APF    EQU   X'01'  .... ...1        Authorized at invocation
*                     ..xx ....        available bits
*
FLAGS2   DS    X                      Flag bits
F2INOPN  EQU   X'80'  1... ....        INDS DCB open
F2NCBOPN EQU   X'40'  .1.. ....        NETSPOOL NCB open
F2OUTOPN EQU   X'20'  ..1. ....        OUTDS DCB open
F2NJE38  EQU   X'10'  ...1 ....        NJE38 is active (LCLNODE valid)
F2SYSOPN EQU   X'08'  .... 1...        SYSINDS DCB open
F2EXIST  EQU   X'04'  .... .1..        OUTDATASET previously existed
F2UNIT   EQU   X'02'  .... ..1.        UNIT specified              v200
*                     .... ...x        available bits
*
FLAGS3   DS    X                      Flag bits from CMD line parse
F3DEST   EQU   X'80'  1... ....        Valid node.user destination spec
F3PDS    EQU   X'40'  .1.. ....        1=PDS,0=SEQL specified
F3VOLSER EQU   X'20'  ..1. ....        VOLSER specified
F3OUTDS  EQU   X'10'  ...1 ....        OUTDATASET specified
F3OUTMEM EQU   X'08'  .... 1...        OUTDATASET MEMBER specified
F3INDS   EQU   X'04'  .... .1..        DATASET specified
F3INMEM  EQU   X'02'  .... ..1.        DATASET member specified
F3QUIET  EQU   X'01'  .... ...1        1=QUIET suppress info msgs
*
FLAGS4   DS    X                      Flag bits
*                     xxxx xxxx        available bits
*                                                                       NET02470
         DS    0F
INMF01   DS    (INMFSZ)X              Fields for INMR01 record
INMF02A  DS    (INMFSZ)X              Fields for 1st INMR02 record
INMF02B  DS    (INMFSZ)X              Fields for 2nd INMR02 record
INMF03   DS    (INMFSZ)X              Fields for INMR03 record
*                                                                       NET02590
         DS    0F
CAMWORK  DS    0XL140                 CAMLST work area
BUFF     DS    CL256                  GB buffer containing request data NET02600
LIST     DS    CL80                   Print line
REC      DS    CL133                  Physical record from spool
*
*----
LS99PTR  DS    A                       PTR TO S99RB
LS99RB   DS    XL20                    SPACE FOR S99RB
*
TXTPTRS  DS    15A                     -> Text unit ptr list
*
         DS    0H
UTXT     DS    0XL06,Y,AL2,AL2         DDNAME Unallocation
UDDNAME  DS    CL8                      DDNAME
*
         DS    0H
TXT01    DS    0XL06,Y,AL2,AL2         Return DDNAME
TDDNAME  DS    CL8                      DDNAME
*
         DS    0H
TXT02    DS    0XL06,Y,AL2,AL2         DSN=
TDSNAME  DS    CL44                     DSNAME
*
         DS    0H
TXT03    DS    0XL07,Y,AL2,AL2,X       DISP=(NEW,
*
         DS    0H
TXT04    DS    0XL07,Y,AL2,AL2,X       DISP=(,CATLG)
*
         DS    0H
TXT05    DS    0XL06,Y,AL2,AL2         SPACE BLOCK LEN
TBLKLEN  DS    XL3                      BLKLEN
*
         DS    0H
TXT06    DS    0XL06,Y,AL2,AL2         SPACE PRIMARY
TPRIME   DS    XL3                      Primary
*
         DS    0H
TXT07    DS    0XL06,Y,AL2,AL2         SPACE SECONDARY
TSECND   DS    XL3                      Secondary
*
         DS    0H
TXT08    DS    0XL06,Y,AL2,AL2         SPACE DIRECTORY BLOCKS
TDIRBLKS DS    XL3                      DIR BLKS
*
         DS    0H
TXT09    DS    0XL06,Y,AL2,AL2         VOLUME
TVOLSER  DS    CL6                      VOLSER
*
         DS    0H
TXT10    DS    0XL14,Y,AL2,AL2         UNIT                        v200
TUNIT    DS    CL8                      UNITNAME                   v200
*
         DS    0H
TXT11    DS    0XL06,Y,AL2,AL2         EXPDT
TEXPDT   DS    CL5                      EXPDT=yyddd
*
         DS    0H
TXT12    DS    0XL06,Y,AL2,AL2         BLKSIZE
TBLKSIZE DS    XL2                      BLKSIZE
*
         DS    0H
TXT13    DS    0XL06,Y,AL2,AL2         DSORG
TDSORG   DS    XL2                      DSORG
*
         DS    0H
TXT14    DS    0XL06,Y,AL2,AL2         LRECL
TLRECL   DS    XL2                      LRECL
*
         DS    0H
TXT15    DS    0XL06,Y,AL2,AL2         RECFM
TRECFM   DS    XL1                      RECFM
*
         DS    0H
TXT16    DS    0XL04,Y,AL2             DUMMY
*
         DS    0H
TXT17    DS    0XL04,Y,AL2             SYSOUT
*
         DS    0H
TXT18    DS    0XL04,Y,AL2             TERM
*
         DS    0H
TXT19    DS    0XL04,Y,AL2             CYLINDER
*
         DS    0H
TXT20    DS    0XL04,Y,AL2             FREE=CLOSE
*
         DS    0H
TXT21    DS    0XL06,Y,AL2,AL2         MEMBER
TMEMBER  DS    CL8
*---
*
CTL      DS    X                      Segment descriptor byte
*
*
         DS    0F
TAGDATA  DS    XL108                  TAG data area
TYPPRT   EQU   X'40'                   PRT dev
TYPPUN   EQU   X'80'                   PUN dev
*
NCB1     DS    XL48                   NCB for Spool Access
SYSINDS  DS    0X                     SYSIN DCB for IEBCOPY ctl cards
INDS     DS    (DMYINDSL)X            Input dataset DCB
OUTDS    DS    (DMYOUTDL)X            OUTDATASET DCB
CAMLST   DS    (DMYLSTL)X             Space to hold a CAMLST
*
CPYPLIST DS    XL(COPYPRML)            IEBCOPY PARM FIELD
*
         DS    0H
DDLISTL  DS    AL2(DDLISTSZ)           DDNAME LIST LENGTH
DDLIST   DS    4XL8'00'                    FOUR DDNAMES UNDEFINED
DDSYSIN  DS    CL8    DDNAME representing IEBCOPY's SYSIN
DDSYSPR  DS    CL8    DDNAME representing IEBCOPY's SYSPRINT
         DS    XL8'00'                     UNDEFINED DD
DDSYSUT1 DS    CL8    DDNAME of the dataset to be transmitted (SYSUT1)
DDSYSUT2 DS    CL8    DDNAME representing IEBCOPY's SYSUT2
         DS    XL8'00'                    SYSUT3 unused
DDSYSUT4 DS    CL8    DDNAME representing IEBCOPY's SYSUT4
DDLISTSZ EQU   *-DDLIST                LENGTH OF DDLIST for IEBCOPY
DDOUTDS  DS    XL8'00'                 OUTDATASET DDNAME
DDNETSPL DS    XL8'00'                 NETSPOOL DDNAME
UNLISTSZ EQU   *-DDLIST                TOTAL of all DDs in list
*
*-- ESTAE exit used areas
*
FSAVE    DS    2D
FWORK    DS    D
DHDR     DS    CL30
ABCODE   DS    CL7
MVSSAVE  DS    18F                 ESTAE exit OS save
*-- End of ESTAE area
*
*
NJESA    DS    18F                    NJERCV OS save area               NJE00300
DYNSA    DS    18F                    NJEDYN OS save area               NJE00300
NETSA    DS    18F                    NJENET OS save area               NJE00300
PARSA    DS    18F                    NJEPAR OS save area               NJE00300
*
         DS    0D                     Force doubleword size
NJEWKSZ  EQU   *-NJEWK
*                                                                       NJE00930
*
*-- System DSECTs
*
         CVT   DSECT=YES,PREFIX=NO
         IEFZB4D0
         IEFZB4D2
         DCBD  DSORG=PS,DEVD=DA
*
IEFUCBOB DSECT
         IEFUCBOB LIST=YES
         IHAPSA
         IEESMCA
         IKJTCB
         IHASDWA
IEFTIOT  DSECT
         IEFTIOT1
         IHAASCB
         IHAASXB
         IKJUPT
         IKJCPPL
         IKJPGPB
         IKJIOPL
DSCBF1   DSECT
         IECSDSL1 (1)
*
VOLLIST  DSECT                         Volume list returned by LOCATE
VOLCOUNT DS    H                       Volume count
VOLDEV   DS    CL4                     UCB dev type
VOLSER   DS    CL6                     Volser
VOLSTAT  DS    H                       Status bytes
*
ACEE     DSECT                         Maps a portion of ACEE in MVS3.8
ACEEEYE  DS    CL4'ACEE'
         DS    16X
ACEEUSRL DS    X                       Length of userid
ACEEUSR  DS    CL8                     Userid
*
         COPY  NETSPOOL                                                 NJE00940
         COPY  TAG
*
*-- NJE38 DSECTs
*
         NJEWRE                                                    v220
*
         END   NJETRN                                                   NJE01000
@@
//*
//*  Installs SYSGEN.NJE38.SAMPLIB
//*
//SAMPLIB   EXEC PGM=PDSLOAD
//STEPLIB  DD  DSN=SYSC.LINKLIB,DISP=SHR
//SYSPRINT DD  SYSOUT=*
//SYSUT2   DD  DSN=SYSGEN.NJE38.SAMPLIB,DISP=(NEW,CATLG),
//             VOL=SER=PUB001,
//             UNIT=3390,SPACE=(CYL,(2,1,10)),
//             DCB=(BLKSIZE=6160,LRECL=80,RECFM=FB)
//SYSUT1   DD  DATA,DLM=@@
./ ADD NAME=CRLY
//HERC01R JOB  CLASS=A,MSGCLASS=X,REGION=4096K
//C    EXEC GCCCL,
//           PARM.ASM=(DECK,LIST),
//           PARM.LKED=(XREF,LIST,CALL)
//COMP.SYSIN DD *
#include <stdio.h>

#define REGISTER   1
#define DEREGISTER 2
#define WAIT       3
#define GETMSG     4
#define GETECB     5

extern   int NJERLY(int*,int,char*);
int main(void)
{
   int njetkn;
   int njerc;
   int *njeecb;
   char useridÝ9¨;
   char msgÝ121¨;

   /* Register userid HERC01 */
   strcpy(userid,"HERC01  ");
   njerc=NJERLY(&njetkn,REGISTER,userid);
   printf("register rc=%d\n",njerc);
   if (njerc) return njerc;

   /* Get the ECB address to demonstrate, but not used here */
   njeecb=(int*)NJERLY(&njetkn,GETECB,"");
   printf("get ecb  addr=%x \n",njeecb);

   /* Begin message loop; else wait for message or STOP action */
   do
   {
      while (!NJERLY(&njetkn,GETMSG,msg))
      {
         printf("getmsg rc=%d\n",njerc);
         printf("msg txt  =%s\n",msg);
      }
      njerc=NJERLY(&njetkn,WAIT,"");
   } while (!njerc);

   printf("wait rc=%d\n",njerc);

   /* Wait returned non-zero RC, so deregister and exit */
   njerc=NJERLY(&njetkn,DEREGISTER,"");
   printf("deregister rc=%d\n",njerc);
   return njerc;
}
/*
//LKED.SYSIN DD *
  INCLUDE SYSLMOD(NJERLY)
  SETCODE AC(1)
  NAME CRLY(R)
/*
//LKED.SYSLMOD DD DSN=HERC01.AUTHLIB,DISP=SHR
//*
//TESTRUN EXEC PGM=CRLY
//STEPLIB DD DSN=HERC01.AUTHLIB,DISP=SHR
//SYSUDUMP DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSTERM  DD SYSOUT=*
//SYSIN    DD DUMMY
./ ADD NAME=JOB000
//HERC01A JOB CLASS=A,MSGCLASS=X
//*
//* JOB000
//* THIS JOB UNLOADS THE NJE38 DISTRIBUTION TAPE
//*
//UNLOAD   PROC VOL=PUB000,                        <== VERIFY
//            SAMPLIB='NJE38.SAMPLIB',             <== VERIFY
//            AUTHLIB='NJE38.AUTHLIB',             <== VERIFY
//            CMDLIB='SYS2.CMDLIB'                 <== VERIFY
//*
//CPY      EXEC PGM=IEBCOPY
//SYSPRINT DD SYSOUT=*
//SYSUT3   DD UNIT=VIO,SPACE=(CYL,5)
//SYSUT4   DD UNIT=VIO,SPACE=(CYL,5)
//IN1      DD UNIT=TAPE,DSN=N38.SAMPLIB,DISP=(OLD,KEEP),
//            VOL=(,RETAIN,SER=NJE38),LABEL=(1,SL)
//IN2      DD UNIT=TAPE,DSN=N38.AUTHLIB,DISP=(OLD,KEEP),
//            VOL=(,RETAIN,SER=NJE38),LABEL=(2,SL)
//IN3      DD UNIT=TAPE,DSN=N38.CMDLIB,DISP=(OLD,KEEP),
//            VOL=(,RETAIN,SER=NJE38),LABEL=(3,SL)
//*
//OUT1     DD DISP=(NEW,CATLG),DSN=&SAMPLIB,
//            SPACE=(CYL,(1,1,5)),UNIT=SYSDA,VOL=SER=&VOL,
//            DCB=(BLKSIZE=3120,LRECL=80,RECFM=FB)
//OUT2     DD DISP=(NEW,CATLG),DSN=&AUTHLIB,VOL=SER=&VOL,
//            SPACE=(CYL,(1,1,5)),UNIT=SYSDA,
//            DCB=(BLKSIZE=6144,RECFM=U)
//OUT3     DD DISP=SHR,DSN=&CMDLIB
//         PEND
//RUN      EXEC UNLOAD
//CPY.SYSIN DD *
 COPY INDD=IN1,OUTDD=OUT1
 COPY INDD=IN2,OUTDD=OUT2
 COPY INDD=((IN3,R)),OUTDD=OUT3
/*
./ ADD NAME=JOB010
//HERC01B  JOB CLASS=A,MSGCLASS=X
//*
//* JOB010
//* CREATE THE NJE38 NETSPOOL DATASET
//*
//* VERIFY THE VOLUME NAME, THE DATASET NAME, AND THE NUMBER OF
//* CYLINDERS OF SPACE.
//*
//*
//SPOOL    EXEC PGM=IDCAMS
//SYSPRINT DD SYSOUT=*
//*
//SPLVOL   DD UNIT=SYSDA,DISP=SHR,VOL=SER=PUB002        <== VERIFY
//*
//SYSIN    DD *
          DEF CL (  NAME( NJE38.NETSPOOL )           /* <== VERIFY */ -
                    RECSZ(4089,4089)                                  -
                    CYL(50)                          /* <== VERIFY */ -
                    NUMBERED                                          -
                    CISZ(4096)                                        -
                    SHR(4 4)                                          -
                    FILE( SPLVOL )                                    -
                    VOLUMES( PUB002))                /* <== VERIFY */ -
            DATA (  NAME( NJE38.NETSPOOL.DATA )      /* <== VERIFY */ -
                    UNIQUE )
/*
./ ADD NAME=JOB020
//HERC01C  JOB  CLASS=A,MSGCLASS=X
//*
//* JOB020
//* FORMAT THE NJE38 NETSPOOL DATASET
//*
//* VERIFY THE NJE38 AUTHLIB AND NETSPOOL DATASET NAMES.
//*
//*
//FMT      EXEC PGM=NJEFMT
//STEPLIB  DD DISP=SHR,DSN=NJE38.AUTHLIB                  <== VERIFY
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//NETSPOOL DD DISP=OLD,DSN=NJE38.NETSPOOL                 <== VERIFY
//
./ ADD NAME=JOB030
//HERC01D  JOB  CLASS=A,MSGCLASS=X
//*
//* JOB030
//* CREATE THE NJE38 CONFIGURATION PDS AND LOAD THE EXAMPLE
//* CONFIGURATION MEMBER.
//*
//*
//NJECFG   PROC CONFIG='NJE38.CONFIG',                  <== VERIFY
//            SAMPLIB='NJE38.SAMPLIB'                   <== VERIFY
//*
//COPY     EXEC PGM=IEBGENER
//SYSPRINT DD SYSOUT=*
//SYSIN    DD DUMMY
//SYSUT1   DD DSN=&SAMPLIB(SAMPCFG),DISP=SHR
//SYSUT2   DD DSN=&CONFIG(CONFIG00),DISP=(NEW,CATLG),
//            DCB=(BLKSIZE=3120,LRECL=80,RECFM=FB,DSORG=PO),
//            UNIT=SYSDA,SPACE=(3120,(10,5,5))
//         PEND
//*
//RUN      EXEC NJECFG
//
./ ADD NAME=JOB040
//HERC01A JOB CLASS=A,MSGCLASS=X
//*
//* JOB040
//* THIS JOB UNLOADS THE NJE38 OPTIONAL SOURCE MATERIALS
//*
//*
//CPY      EXEC PGM=IEBCOPY
//SYSPRINT DD SYSOUT=*
//SYSUT3   DD UNIT=VIO,SPACE=(CYL,5)
//SYSUT4   DD UNIT=VIO,SPACE=(CYL,5)
//IN1      DD UNIT=TAPE,DSN=N38.ASMSRC,DISP=(OLD,KEEP),
//            VOL=(,RETAIN,SER=NJE38),LABEL=(4,SL)
//IN2      DD UNIT=TAPE,DSN=N38.MACLIB,DISP=(OLD,KEEP),
//            VOL=(,RETAIN,SER=NJE38),LABEL=(5,SL)
//*
//OUT1     DD DISP=(NEW,CATLG),DSN=NJE38.ASMSRC,           <-- VERIFY
//            SPACE=(CYL,(2,1,10)),UNIT=SYSDA,
//            DCB=(BLKSIZE=6160,LRECL=80,RECFM=FB)
//*
//OUT2     DD DISP=(NEW,CATLG),DSN=NJE38.MACLIB,           <-- VERIFY
//            SPACE=(CYL,(1,1,5)),UNIT=SYSDA,
//            DCB=(BLKSIZE=3120,RECFM=FB,LRECL=80)
//SYSIN    DD *
 COPY INDD=IN1,OUTDD=OUT1
 COPY INDD=IN2,OUTDD=OUT2
/*
./ ADD NAME=NJE38
//NJE38    PROC M=CONFIG00,
//            D='NJE38.CONFIG'                  <== VERIFY DSN
//*
//* STARTED TASK PROCEDURE FOR NJE38
//*
//NJEINIT  EXEC PGM=NJEINIT,REGION=4096K
//STEPLIB  DD DSN=NJE38.AUTHLIB,DISP=SHR        <== VERIFY DSN
//NETSPOOL DD DSN=NJE38.NETSPOOL,DISP=SHR       <== VERIFY DSN
//CONFIG   DD DSN=&D(&M),DISP=SHR,FREE=CLOSE
//IEFRDER  DD DUMMY
./ ADD NAME=PRDMP
//HERC01D  JOB CLASS=A,MSGCLASS=X
//*
//* THIS JOB WILL PRINT THE DUMP DATASET FOR DUMP ANALYSIS.
//*
//* VERIFY THE DUMP DATASET NAME OF WHERE THE DUMP WAS WRITTEN.
//*
//WORKY  EXEC PGM=AMDPRDMP
//SYSPRINT DD SYSOUT=*
//SYSABEND DD SYSOUT=*
//PRINTER  DD SYSOUT=*
//TAPE     DD DSN=SYS1.DUMP00,DISP=SHR              <= VERIFY
//*
//SYSUT1   DD DSN=&&WORK,
//            UNIT=VIO,
//            SPACE=(CYL,(20,20))
//*
//*
//SYSIN    DD  *
    PRINT CURRENT
    GO
    END
//*
//*
//*
//*  CLEAR THE DUMP DATASET FOR REUSE AFTER PRINTING.
//*
//*  ** A COMPLETION CODE OF 12 IS A NORMAL COMPLETION **
//*
//D1      EXEC PGM=IEBGENER,COND=(4,LT)
//SYSPRINT DD SYSOUT=*
//SYSIN    DD DUMMY
//SYSUT1   DD DUMMY
//SYSUT2   DD DSN=SYS1.DUMP00,DISP=SHR
//
./ ADD NAME=RECV
//HERC01X  JOB  CLASS=A,MSGCLASS=X
//*
//* EXAMPLE RETRIEVAL JOB FOR A PLAIN "FLAT" FILE
//*
//* SPECIFY THE DCB ATTRIBUTES BASED ON WHAT WAS TRANSMITTED
//*
//RETR     EXEC PGM=NJ38RECV,PARM=''
//*
//* Optional PARM parameters (specify one or both separated by comma):
//*   NOPURGE    - Leave the file in the NJE38 spool after retrieval.
//*   FILE=##    - Specifies the exact spool file id of the file to
//*                receive.
//*
//STEPLIB  DD DSN=NJE38.AUTHLIB,DISP=SHR
//SYSPRINT DD SYSOUT=*
//*
//SYSUT2  DD DSN=HERC01.LIST,
//           DISP=(NEW,CATLG),UNIT=SYSDA,
//           SPACE=(CYL,(2,1)),
//           DCB=(BLKSIZE=3200,
//           LRECL=80,
//           RECFM=FB)
//
./ ADD NAME=RECVPDS1
//HERC01X JOB CLASS=A,MSGCLASS=X
//*
//*  RECEIVE A PARTITIONED DATASET - LOADLIB EXAMPLE
//*
//*  1. SPECIFY THE DATASET NAME OF A NEW DATASET TO HOLD THE
//*     RESULTS OF THE TRANSMISSION.
//*
//*  2. CHANGE SPACE= PARAMETER SIZES IF YOUR DATASET IS LARGE,
//*     BUT OTHERWISE DO NOT ADD OR CHANGE ANY DCB INFORMTION ON
//*     A RECEIVE JOB.  THE FINAL DCB WILL BE EXACTLY AS THE
//*     ORIGINAL DATASET.
//*
//*
//*
//RETR     EXEC PGM=NJ38RECV
//STEPLIB  DD DSN=NJE38.AUTHLIB,DISP=SHR
//SYSPRINT DD SYSOUT=*
//SYSUT2  DD DSN=&&XMIT,DISP=(NEW,PASS),UNIT=SYSDA,
//           SPACE=(CYL,(10,10)),
//           DCB=(BLKSIZE=3200,LRECL=80,RECFM=FB)
//*
//*
//R370     EXEC PGM=RECV370,COND=(4,LT)
//RECVLOG  DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSIN    DD DUMMY
//*
//SYSUT1   DD UNIT=SYSDA,DISP=(,DELETE),SPACE=(CYL,(10,10)),
//            DSN=&&SYSUT1
//*
//SYSUT2   DD DSN=HERC01.RECVD.LOADLIB,
//            DISP=(NEW,CATLG),DCB=DSORG=PO,
//            UNIT=SYSDA,SPACE=(CYL,(10,10,30))       <== SIZE ?
//*
//XMITIN   DD DSN=&&XMIT,DISP=(OLD,DELETE)
//
./ ADD NAME=RECVPDS2
//HERC01X JOB CLASS=A,MSGCLASS=X
//*
//*  RECEIVE A PARTITIONED DATASET - SOURCE CODE PDS EXAMPLE
//*
//*  1. SPECIFY THE DATASET NAME OF A NEW DATASET TO HOLD THE
//*     RESULTS OF THE TRANSMISSION.
//*
//*  2. CHANGE SPACE= PARAMETER SIZES IF YOUR DATASET IS LARGE,
//*     BUT OTHERWISE DO NOT ADD OR CHANGE ANY DCB INFORMTION ON
//*     A RECEIVE JOB.  THE FINAL DCB WILL BE EXACTLY AS THE
//*     ORIGINAL DATASET.
//*
//*
//*
//RETR     EXEC PGM=NJ38RECV
//STEPLIB  DD DSN=NJE38.AUTHLIB,DISP=SHR
//SYSPRINT DD SYSOUT=*
//SYSUT2  DD DSN=&&XMIT,DISP=(NEW,PASS),UNIT=SYSDA,
//           SPACE=(CYL,(10,10)),
//           DCB=(BLKSIZE=3200,LRECL=80,RECFM=FB)
//*
//*
//R370     EXEC PGM=RECV370,COND=(4,LT)
//RECVLOG  DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSIN    DD DUMMY
//*
//SYSUT1   DD UNIT=SYSDA,DISP=(,DELETE),SPACE=(CYL,(10,10)),
//            DSN=&&SYSUT1
//*
//SYSUT2   DD DSN=HERC01.RECVD.COBOL.SOURCE,
//            DISP=(NEW,CATLG),DCB=DSORG=PO,
//            UNIT=SYSDA,SPACE=(CYL,(2,2,10))        <= SIZE ?
//*
//XMITIN   DD DSN=&&XMIT,DISP=(OLD,DELETE)
//
./ ADD NAME=RECVSEQL
//HERC01X JOB CLASS=A,MSGCLASS=X
//*
//*  RECEIVE A SEQUENTIAL DATASET
//*
//*  1. SPECIFY THE DATASET NAME OF A NEW DATASET TO HOLD THE
//*     RESULTS OF THE TRANSMISSION.
//*
//*  2. CHANGE SPACE= PARAMETER SIZES IF YOUR DATASET IS LARGE,
//*     BUT OTHERWISE DO NOT ADD OR CHANGE ANY DCB INFORMTION ON
//*     A RECEIVE JOB.  THE FINAL DCB WILL BE EXACTLY AS THE
//*     ORIGINAL DATASET.
//*
//RETR     EXEC PGM=NJ38RECV
//STEPLIB  DD DSN=NJE38.AUTHLIB,DISP=SHR
//SYSPRINT DD SYSOUT=*
//SYSUT2  DD DSN=&&XMIT,DISP=(NEW,PASS),UNIT=SYSDA,
//           SPACE=(CYL,(10,10)),
//           DCB=(BLKSIZE=3200,LRECL=80,RECFM=FB)
//*
//*
//R370     EXEC PGM=RECV370,COND=(4,LT)
//RECVLOG  DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSIN    DD DUMMY
//*
//SYSUT1   DD DSN=HERC01.RECVD.LISTING,
//            DISP=(NEW,CATLG),DCB=DSORG=PS,
//            UNIT=SYSDA,SPACE=(CYL,(10,10),RLSE)        <== SIZE ?
//*
//XMITIN   DD DSN=&&XMIT,DISP=(OLD,DELETE)
./ ADD NAME=SAMPCFG
*
* NJE38 EXAMPLE CONFIGURATION FILE
*
*-- Local parameters
*
LOCAL MVSA     DEFUSER HERC01
*
*-- Physical links to remote nodes
*
LINK  MVSB     LINE 090   AUTO YES   BUFF 1012
*
*-- Routes to indirect nodes
*
*ROUTE nodeid   TO linkid
*
*
*-- Authorized users
*
*     Userid   AT Node
*     -------- -- --------
AUTH  HERC01   AT MVSA
AUTH  HERC01   AT MVSB
*
./ ADD NAME=TSOAUTH
//HERC01X JOB  1,
//             'Rebuild IKJEFT02',
//             CLASS=A,
//             MSGCLASS=X,
//             MSGLEVEL=(1,1)
//*********************************************************************
//*
//* Desc: Adds TSO command NJE38 to be an authorized command
//*
//* Please refer to Appendix C of the NJE38 documentation before
//*  running this job.
//*
//*
//*********************************************************************
//*
/*MESSAGE  ******************************************
/*MESSAGE  *                                        *
/*MESSAGE  * This change becomes effective only     *
/*MESSAGE  * if you do an IPL with the CLPA option  *
/*MESSAGE  *                                        *
/*MESSAGE  ******************************************
//*
//ASM      EXEC  PGM=IFOX00,REGION=4096K,
// PARM=('XREF(FULL),OBJ,NODECK')
//SYSUT1   DD DSN=&&SYSUT1,UNIT=SYSDA,SPACE=(1700,(5600,500))
//SYSUT2   DD DSN=&&SYSUT2,UNIT=SYSDA,SPACE=(1700,(1300,500))
//SYSUT3   DD DSN=&&SYSUT3,UNIT=SYSDA,SPACE=(1700,(1300,500))
//SYSPRINT DD SYSOUT=*
//SYSGO    DD DSN=&&LOADSET,DISP=(,PASS),UNIT=SYSDA,
//            SPACE=(800,(320,100))
//SYSIN    DD *
         ENTRY APFCTABL
IKJEFTE2 CSECT
         DC    CL8'IKJEFTE2'
         DC    CL8'&SYSDATE'
APFCTABL DC    CL8'#       '       CMDSBSYS TSO interface
         DC    CL8'CMDSBTSO'       CMDSBSYS TSO interface
         DC    CL8'IEBCOPY '       Copy under TSO
         DC    CL8'IM      '       IMON/370
         DC    CL8'LISTD   '       TSO List Dataset commands
         DC    CL8'LISTDS  '       ditto
         DC    CL8'IKJEHDS1'       ditto
         DC    CL8'NJE38   '       NJE38 Command
         DC    CL8'PDS     '       PDS Utility
         DC    CL8'PDSAA   '       PDS Utility (Test)
         DC    CL8'PDS73   '       PDS Utility (Alias)
         DC    CL8'PDS85   '       PDS Utility (Alias)
         DC    CL8'QUEUE   '       QUEUE COMMAND
         DC    CL8'Q       '       ALIAS
         DC    CL8'QUE     '       ALIAS
         DC    CL8'RECEIVE '       NJE38 RECEIVE
         DC    CL8'RPF     '       SPARE TABLE ENTRIES
         DC    CL8'RPFMAIN '       SPARE TABLE ENTRIES
         DC    CL8'SPFCOPY '       Copy under TSO
         DC    CL8'TRANSMIT'       NJE38 TRANSMIT
         DC    CL8'TSOUSER '
         DC    CL8'XMIT    '       NJE38 TRANSMIT Alias
         DC    CL8'        '       8 BLANKS TABLE TERMINATOR
         END
         ENTRY APFCTABL
/*
//LKED    EXEC PGM=IEWL,PARM='NCAL,LIST,XREF,LET,REUS,RENT',COND=(4,LT)
//SYSPRINT DD SYSOUT=*
//SYSUT1   DD DSN=&&SYSUT1,UNIT=SYSDA,SPACE=(1024,(50,20))
//SYSLMOD  DD DSN=SYS1.LPALIB,DISP=SHR
//AOST4    DD DSN=SYS1.AOST4,DISP=SHR
//SYSLIN   DD DSN=&&LOADSET,DISP=(OLD,PASS)
//         DD *
   INCLUDE AOST4(IKJEFT02,IKJEFT03,IKJEFT06)
   INCLUDE AOST4(IKJEFTNS,IKJEFT08)
   INCLUDE AOST4(IKJEFTE8)
   ORDER IKJEFT02(P)
   ORDER IKJEFTNS
   ORDER IKJEFTE2
   ORDER IKJEFT03
   ORDER IKJEFT06
   ORDER IKJEFT08
   ORDER IKJEFTE8
   ENTRY IKJEFT02
   ALIAS IKJEFT03
   ALIAS IKJEFT0B
   NAME IKJEFT02(R)
/*
./ ADD NAME=VERIFY
//HERC01V  JOB CLASS=A,MSGCLASS=X
//*
//* VERIFY THE NETSPOOL DATASET.  THIS JOB SHOULD BE RUN IF NJE38
//* OR ANY OF ITS UTILITIES SHOULD ABEND.
//*
//INIT     EXEC PGM=IDCAMS,REGION=512K
//SYSPRINT DD SYSOUT=*
//*
//NETSPOOL DD DSN=NJE38.NETSPOOL,DISP=SHR              <== VERIFY
//*
//SYSIN    DD *
  VERIFY FILE(NETSPOOL)
/*
./ ADD NAME=XMIT
//HERC01X  JOB  CLASS=A,MSGCLASS=X
//*
//* EXAMPLE JOB TO TRANSMIT A SIMPLE 'FLAT' FILE
//*
//* 1. SPECIFY THE NODEID AND USERID OF THE TARGET USER.
//*
//* 2. SPECIFY THE SEQUENTIAL DATASET (OR MEMBER) OF THE DATA TO
//*    BE SENT.
//*
//*
//*
//XMIT     EXEC PGM=NJ38XMIT,PARM='MVSB.HERC01'       <= TARGET USER
//STEPLIB  DD DSN=NJE38.AUTHLIB,DISP=SHR
//SYSPRINT DD SYSOUT=*
//*
//SYSUT1  DD DISP=SHR,DSN=HERC01.COBOL.SOURCE(COPYBK1)
//
./ ADD NAME=XMITPDS1
//HERC01X JOB CLASS=A,MSGCLASS=X
//*
//*  TRANSMIT A PDS DATASET - LOADLIB EXAMPLE
//*
//*  1. SPECIFY THE DATASET NAME TO BE SENT ON THE SYSUT1 DD OF
//*     THE X370 STEP.
//*
//*  2. LOOK UP THE DCB ATTRIBUTES FOR THAT DATASET ELSEWHERE AND
//*     SPECIFY THEM EXACTLY THE SAME WAY ON SYSUT1.  BE SURE THE
//*     DSORG IS PO.
//*
//*  3. SPECIFY THE NODE.USERID OF THE DESTINATION IN THE PARM=
//*     FIELD OF THE 'SEND' STEP.
//*
//X370     EXEC PGM=XMIT370
//XMITLOG  DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSIN    DD DUMMY
//*
//SYSUT1   DD DISP=SHR,DSN=HERC01.LOADLIB,
//            DCB=(BLKSIZE=27998,RECFM=U,DSORG=PO)
//*
//SYSUT2   DD UNIT=SYSDA,DISP=(,DELETE),SPACE=(CYL,(10,10)),
//            DSN=&&SYSUT2
//*
//XMITOUT  DD DSN=&&XMIT,
//            DISP=(NEW,PASS),
//            UNIT=SYSDA,SPACE=(CYL,(10,10))
//*
//*
//SEND     EXEC PGM=NJ38XMIT,PARM='MVSB.HERC01'       <== TARGET USER
//STEPLIB  DD DSN=NJE38.AUTHLIB,DISP=SHR
//SYSPRINT DD SYSOUT=*
//SYSUT1   DD DSN=&&XMIT,DISP=(OLD,DELETE)
//
./ ADD NAME=XMITPDS2
//HERC01X JOB CLASS=A,MSGCLASS=X
//*
//*  TRANSMIT A PDS DATASET - SOURCE CODE PDS EXAMPLE
//*
//*  1. SPECIFY THE DATASET NAME TO BE SENT ON THE SYSUT1 DD OF
//*     THE X370 STEP.
//*
//*  2. LOOK UP THE DCB ATTRIBUTES FOR THAT DATASET ELSEWHERE AND
//*     SPECIFY THEM EXACTLY THE SAME WAY ON SYSUT1.  BE SURE THE
//*     DSORG IS PO.
//*
//*  3. SPECIFY THE NODE.USERID OF THE DESTINATION IN THE PARM=
//*     FIELD OF THE 'SEND' STEP.
//*
//X370     EXEC PGM=XMIT370
//XMITLOG  DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSIN    DD DUMMY
//*
//SYSUT1   DD DISP=SHR,DSN=HERC01.COBOL.SOURCE,
//            DCB=(BLKSIZE=3120,LRECL=80,RECFM=FB,DSORG=PO)
//*
//SYSUT2   DD UNIT=SYSDA,DISP=(,DELETE),SPACE=(CYL,(10,10)),
//            DSN=&&SYSUT2
//*
//XMITOUT  DD DSN=&&XMIT,
//            DISP=(NEW,PASS),
//            UNIT=SYSDA,SPACE=(CYL,(10,10))
//*
//*
//SEND     EXEC PGM=NJ38XMIT,PARM='MVSB.HERC01'       <== TARGET USER
//STEPLIB  DD DSN=NJE38.AUTHLIB,DISP=SHR
//SYSPRINT DD SYSOUT=*
//SYSUT1   DD DSN=&&XMIT,DISP=(OLD,DELETE)
//
./ ADD NAME=XMITSEQL
//HERC01X JOB CLASS=A,MSGCLASS=X
//*
//*  TRANSMIT A SEQUENTIAL DATASET
//*
//*  1. SPECIFY THE DATASET NAME TO BE SENT ON THE SYSUT1 DD OF
//*     THE X370 STEP.
//*
//*  2. LOOK UP THE DCB ATTRIBUTES FOR THAT DATASET ELSEWHERE AND
//*     SPECIFY THEM EXACTLY THE SAME WAY ON SYSUT1.  BE SURE THE
//*     DSORG IS PS.
//*
//*  3. SPECIFY THE NODE.USERID OF THE DESTINATION IN THE PARM=
//*     FIELD OF THE 'SEND' STEP.
//*
//*
//*
//X370     EXEC PGM=XMIT370
//XMITLOG  DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSIN DD DUMMY
//*
//SYSUT1   DD DSN=HERC01.LISTING,DISP=SHR,
//            DCB=(BLKSIZE=23474,LRECL=121,RECFM=FBA,DSORG=PS)
//*
//XMITOUT  DD DSN=&&XMIT,
//            DISP=(NEW,PASS),
//            UNIT=SYSDA,SPACE=(CYL,(10,10))
//*
//*
//SEND     EXEC PGM=NJ38XMIT,PARM='MVSB.HERC01'      <= TARGET USER
//STEPLIB  DD DSN=NJE38.AUTHLIB,DISP=SHR
//SYSPRINT DD SYSOUT=*
//SYSUT1   DD DSN=&&XMIT,DISP=(OLD,DELETE)
//
@@
//*
//* These steps will assemble all components of NJE38 and link it
//* into SYSGEN.NJE38.AUTHLIB
//*
//* All steps should receive COND CODE 0
//*
//ASSEM    PROC R=RENT,M=
//ASSEMBLE EXEC  PGM=IFOX00,REGION=4096K,
// PARM=('XREF(FULL),OBJ,SYSPARM((ON,GEN,NODATA,YES,YES))',
//       'NODECK,&R')
//SYSLIB   DD    DSN=SYSGEN.NJE38.MACLIB,DISP=SHR,DCB=BLKSIZE=32720
//         DD    DSN=SYS1.SMPMTS,DISP=SHR
//         DD    DSN=SYS1.SMPSTS,DISP=SHR
//         DD    DSN=SYS1.MACLIB,DISP=SHR
//         DD    DSN=SYS1.AMODGEN,DISP=SHR
//SYSUT1   DD    DSN=&&SYSUT1,UNIT=SYSDA,SPACE=(1700,(5600,500))
//SYSUT2   DD    DSN=&&SYSUT2,UNIT=SYSDA,SPACE=(1700,(1300,500))
//SYSUT3   DD    DSN=&&SYSUT3,UNIT=SYSDA,SPACE=(1700,(1300,500))
//SYSPRINT DD SYSOUT=*
//SYSPUNCH DD SYSOUT=B
//SYSGO    DD DSN=&&NJE38OBJ(&M),DISP=(MOD,PASS),
//            SPACE=(800,(2000,1000,10)),UNIT=SYSDA
//SYSIN    DD DSN=SYSGEN.NJE38.ASMSRC(&M),DISP=SHR
// PEND
//* ***********************************
//         EXEC ASSEM,M=NJEINIT,R=RENT
//         EXEC ASSEM,M=NJECMX,R=RENT
//         EXEC ASSEM,M=NJEDRV,R=RENT
//         EXEC ASSEM,M=NJEFMT,R=RENT
//         EXEC ASSEM,M=NJERCV,R=RENT
//         EXEC ASSEM,M=NJERLY,R=RENT
//         EXEC ASSEM,M=NJESCN,R=RENT
//         EXEC ASSEM,M=NJESPOOL,R=RENT
//         EXEC ASSEM,M=NJESYS,R=RENT
//         EXEC ASSEM,M=NJETRN,R=RENT
//         EXEC ASSEM,M=NJE38,R=RENT
//         EXEC ASSEM,M=NJ38RECV,R=RENT
//         EXEC ASSEM,M=NJ38XMIT,R=RENT
//         EXEC ASSEM,M=DMTXJE,R=NORENT
//         EXEC ASSEM,M=DMTMSG,R=RENT
//* ***********************************
//LINKAUTH EXEC PGM=IEWL,PARM='XREF,LET,LIST,NCAL,RENT',COND=(4,LT)
//SYSPRINT DD  SYSOUT=*
//SYSUT1   DD  DSN=&&SYSUT1,UNIT=SYSDA,SPACE=(1024,(50,20))
//SYSLMOD  DD  DISP=(NEW,CATLG),DSN=SYSGEN.NJE38.AUTHLIB,
//             VOL=SER=MVS000,SPACE=(CYL,(1,1,5)),UNIT=3350,
//             DCB=(BLKSIZE=6144,RECFM=U)
//NJEOBJ   DD  DSN=&&NJE38OBJ,DISP=(OLD,PASS)
//SYSLIN   DD  *
        ORDER NJEDRV(P)
        ORDER NJECOM
        ORDER NJEREQ
        ORDER NJEAXS
        ORDER NJESIO
        ORDER NJESPL
        ORDER NJEWT
        ORDER NJEGPG
        ORDER NJEGMQ
        ORDER NJEGLQ
        ORDER NJEGRQ
        ORDER NJEALQ
        ORDER NJETOD
        ORDER DMTXJE(P)
        ORDER DMTXJE1
        ORDER DMTXJE2
        ORDER DMTXJE3
        ORDER DMTXJEA
        ORDER DMTXJEB
        ORDER DMTMSG
        INCLUDE NJEOBJ(NJEDRV)
        INCLUDE NJEOBJ(DMTXJE)
        INCLUDE NJEOBJ(DMTMSG)
        ENTRY NJEDRV
   NAME NJEDRV(R)
        ORDER NJECMX(P)
        INCLUDE NJEOBJ(NJECMX)
        INCLUDE NJEOBJ(NJESCN)
        ENTRY NJECMX
   NAME NJECMX(R)
        INCLUDE NJEOBJ(NJERLY)
        INCLUDE NJEOBJ(NJESYS)
        SETCODE AC(1)
   NAME NJERLY(R)
        ORDER NJESPOOL(P)
        INCLUDE NJEOBJ(NJESPOOL)
   NAME NJESPOOL(R)
        ORDER NJEINIT(P)
        INCLUDE NJEOBJ(NJEINIT)
        INCLUDE NJEOBJ(NJESCN)
        INCLUDE NJEOBJ(NJESYS)
        ENTRY NJEINIT
        SETCODE AC(1)
   NAME NJEINIT(R)
        INCLUDE NJEOBJ(NJEFMT)
   NAME NJEFMT(R)
        ORDER NJ38RECV
        INCLUDE NJEOBJ(NJ38RECV)
        INCLUDE NJEOBJ(NJESYS)
        INCLUDE NJEOBJ(NJESPOOL)
        ENTRY NJ38RECV
   NAME NJ38RECV(R)
        ORDER NJ38XMIT
        INCLUDE NJEOBJ(NJ38XMIT)
        INCLUDE NJEOBJ(NJESYS)
        INCLUDE NJEOBJ(NJESPOOL)
        ENTRY NJ38XMIT
        SETCODE AC(1)
   NAME NJ38XMIT(R)
        INCLUDE NJEOBJ(NJE38)
        INCLUDE NJEOBJ(NJESYS)
        ENTRY NJE38
        SETCODE AC(1)
   NAME NJE38(R)
        ORDER NJERCV(P)
        INCLUDE NJEOBJ(NJERCV)
        INCLUDE NJEOBJ(NJESYS)
        INCLUDE NJEOBJ(NJESPOOL)
        ENTRY NJERCV
        SETCODE AC(1)
        ALIAS RECV
   NAME RECEIVE(R)
        ORDER NJETRN(P)
        INCLUDE NJEOBJ(NJETRN)
        INCLUDE NJEOBJ(NJESYS)
        INCLUDE NJEOBJ(NJESPOOL)
        ENTRY NJETRN
        SETCODE AC(1)
        ALIAS XMIT
   NAME TRANSMIT(R)
/*
//*
//LKCMDLIB EXEC PGM=IEWL,PARM='XREF,LET,LIST,NCAL,RENT',COND=(4,LT)
//SYSPRINT DD  SYSOUT=*
//SYSUT1   DD  DSN=&&SYSUT1,UNIT=SYSDA,SPACE=(1024,(50,20))
//SYSLMOD  DD  DSN=SYS2.CMDLIB,DISP=SHR
//NJEOBJ   DD  DSN=&&NJE38OBJ,DISP=(OLD,PASS)
//SYSLIN   DD *
        INCLUDE NJEOBJ(NJE38)
        INCLUDE NJEOBJ(NJESYS)
        ENTRY NJE38
        SETCODE AC(1)
   NAME NJE38(R)
        ORDER NJERCV(P)
        INCLUDE NJEOBJ(NJERCV)
        INCLUDE NJEOBJ(NJESYS)
        INCLUDE NJEOBJ(NJESPOOL)
        ENTRY NJERCV
        SETCODE AC(1)
        ALIAS RECV
   NAME RECEIVE(R)
        ORDER NJETRN(P)
        INCLUDE NJEOBJ(NJETRN)
        INCLUDE NJEOBJ(NJESYS)
        INCLUDE NJEOBJ(NJESPOOL)
        ENTRY NJETRN
        SETCODE AC(1)
        ALIAS XMIT
   NAME TRANSMIT(R)
/*
//*
//* This step will add SYSGEN.NJE38.AUTHLIB to IEAAPF00
//*
//ADDAPF   EXEC PGM=IKJEFT01,REGION=1024K,DYNAMNBR=50
//SYSPRINT DD  SYSOUT=*
//SYSTSPRT DD  SYSOUT=*
//SYSTERM  DD  SYSOUT=*
//SYSTSIN  DD  *
EDIT 'SYS1.PARMLIB(IEAAPF00)' DATA OLD
LIST
TOP
FIND LINK
INSERT  SYSGEN.NJE38.AUTHLIB MVS000, NJE38 LIB
LIST
END SAVE
//*
//* CREATE THE NJE38 NETSPOOL DATASET
//*
//CRTSPOOL EXEC PGM=IDCAMS
//SYSPRINT DD SYSOUT=*
//SPLVOL   DD UNIT=SYSDA,DISP=SHR,VOL=SER=PUB001
//SYSIN    DD *
  DELETE (PUB001.NJE38.NETSPOOL) CLUSTER PURGE
  /* IF THERE WAS NO DATASET TO DELETE, RESET CC           */
  IF LASTCC = 8 THEN
    DO
        SET LASTCC = 0
        SET MAXCC  = 0
    END

   /* DEFINE NJE38 CLUSTER */

  DEF CL (  NAME( PUB001.NJE38.NETSPOOL )                     -
            RECSZ(4089,4089)                                  -
            CYL(100)                                          -
            NUMBERED                                          -
            CISZ(4096)                                        -
            SHR(4 4)                                          -
            FILE( SPLVOL )                                    -
            VOLUMES( PUB001 ))                                -
  DATA (  NAME( PUB001.NJE38.NETSPOOL.DATA )                  -
            UNIQUE )
/*
//*
//* FORMAT THE NJE38 NETSPOOL DATASET
//*
//FMTSPOOL EXEC PGM=NJEFMT
//STEPLIB  DD DISP=SHR,DSN=SYSGEN.NJE38.AUTHLIB
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//NETSPOOL DD DISP=OLD,DSN=PUB001.NJE38.NETSPOOL
//*
//* ADD THE NJE CONFIG FILE TO SYS2.PARMLIB(NJE38C00)
//*
//COPYPARM EXEC PGM=IEBGENER
//SYSPRINT DD SYSOUT=*
//SYSIN    DD DUMMY
//SYSUT1   DD *
*
* NJE38 EXAMPLE CONFIGURATION FILE
*
*-- Local parameters
*
LOCAL MVSA     DEFUSER IBMUSER
*
*-- Physical links to remote nodes
*
LINK  MVSB     LINE 602   AUTO YES   BUFF 1012
*
*-- Routes to indirect nodes
*
*ROUTE nodeid   TO linkid
*
*
*-- Authorized users
*
*     Userid   AT Node
*     -------- -- --------
AUTH  HMVS01   AT MVSA
AUTH  HMVS01   AT MVSB
*
//SYSUT2   DD DSN=SYS2.PARMLIB(NJE38C00),DISP=SHR
//*
//* Add the NJE38 proc to SYS2.PROCLIB(NJE38)
//*
//NJEPROC  EXEC PGM=PDSLOAD
//STEPLIB  DD  DSN=SYSC.LINKLIB,DISP=SHR
//SYSPRINT DD  SYSOUT=*
//SYSUT2   DD  DSN=SYS2.PROCLIB,DISP=SHR
//SYSUT1   DD  DATA,DLM=@@
./ ADD NAME=NJE38
//NJE38    PROC M=NJE38C00,
//            D='SYS2.PARMLIB'
//*
//* STARTED TASK PROCEDURE FOR NJE38
//*
//NJEINIT  EXEC PGM=NJEINIT,REGION=4096K
//STEPLIB  DD DSN=SYSGEN.NJE38.AUTHLIB,DISP=SHR
//NETSPOOL DD DSN=PUB001.NJE38.NETSPOOL,DISP=SHR
//CONFIG   DD DSN=&D(&M),DISP=SHR,FREE=CLOSE
//IEFRDER  DD DUMMY
@@
/*
//*
//* Edit SYS1.UMODSRC(IKJEFTE2) Adding NJE38 programs
//* that need auth
//*
//EDITUMOD EXEC PGM=IKJEFT01,REGION=1024K,DYNAMNBR=50
//SYSPRINT DD  SYSOUT=*
//SYSTSPRT DD  SYSOUT=*
//SYSTERM  DD  SYSOUT=*
//SYSTSIN  DD  *
 EDIT 'SYS1.UMODSRC(IKJEFTE2)' DATA 
 LIST
 TOP
 FIND /TERMINATOR/
 UP
 INSERT          DC    C'NJE38   '             NJE38 Command
 INSERT          DC    C'RECEIVE '             NJE38 RECEIVE
 INSERT          DC    C'RECV    '             NJE38 RECEIVE Alias
 INSERT          DC    C'TRANSMIT'             NJE38 TRANSMIT
 INSERT          DC    C'XMIT    '             NJE38 TRANSMIT Alias
 LIST
 END SAVE
/*
//*
//* Install NJE001 Usermod to IKJEFTE2
//*
//NJSMPASM EXEC SMPASML,M=IKJEFTE2,COND=(0,NE)
//*
//NJERECV  EXEC SMPAPP,COND=(0,NE),WORK=SYSALLDA
//SMPPTFIN DD  *
++USERMOD(NJE0001)
  .
++VER(Z038)
  FMID(EBB1102)
  PRE(JLM0003)
  .
++MOD(IKJEFTE2)
  DISTLIB(AOST4)
  LKLIB(UMODLIB)
  .
/*
//SMPCNTL  DD  *
 RECEIVE
         SELECT(NJE0001)
         .
  APPLY
        SELECT(NJE0001)
        DIS(WRITE)
        .
/*
//*
//* ADD RAKF PROFILE
//*
//ADDRAKFP    EXEC PGM=SORT,REGION=512K,PARM='MSG=AP'
//STEPLIB DD   DSN=SYSC.LINKLIB,DISP=SHR
//SYSOUT  DD   SYSOUT=A
//SYSPRINT DD  SYSOUT=A
//SORTLIB DD   DSNAME=SYSC.SORTLIB,DISP=SHR
//SORTOUT DD   DSN=SYS1.SECURE.CNTL(PROFILES),DISP=SHR
//SORTWK01 DD  UNIT=2314,SPACE=(CYL,(5,5)),VOL=SER=SORTW1
//SORTWK02 DD  UNIT=2314,SPACE=(CYL,(5,5)),VOL=SER=SORTW2
//SORTWK03 DD  UNIT=2314,SPACE=(CYL,(5,5)),VOL=SER=SORTW3
//SORTWK04 DD  UNIT=2314,SPACE=(CYL,(5,5)),VOL=SER=SORTW5
//SORTWK05 DD  UNIT=2314,SPACE=(CYL,(5,5)),VOL=SER=SORTW6
//SYSIN  DD    *
 SORT FIELDS=(1,80,CH,A)
 RECORD TYPE=F,LENGTH=(80)
 END
/*
//SORTIN DD DSN=SYS1.SECURE.CNTL(PROFILES),DISP=SHR
//       DD *
DATASET PUB001.NJE38.NETSPOOL                               UPDATE
/*
//*
//* Reload profile table
//*
//RAKFUPDT EXEC RAKFPROF
//RAKFUPDT EXEC RAKFUSER
//*
//* REXX and MVP to write the new config file
//* First create temp REXX file
//*
//MAKEREXX EXEC PGM=IEBGENER
//SYSPRINT DD SYSOUT=*
//SYSIN DD DUMMY
//SYSUT1    DD *
say ''
say '******************************************'
say '* REXX Script to Add NJE38 custom config *'
say '******************************************'
say ''

file = "conf/local/nje38.cnf"
cmd = 'CP SH MVP/MVP WRITE "'

say "*** Writing to" file

command.1 = "#############################################"
command.2 = "#"
command.3 = "# NJE38 Config"
command.4 = "#"
command.5 = "#############################################"
command.6 = "#"
command.7 = "# Temporary NJE38 settings below, modify for your environment"
command.8 = "#"
command.9 = "0602 tcpnje 2703 lnode=SYSA rnode=SYSB lport=1175"||,
" rport=1175 rhost=10.10.10.10"
command.10 = "#############################################" 

command.0 = 10

do i=1 to command.0
    say "*** Adding" COMMAND.i
    say "*** Issuing "||cmd||file||' '||COMMAND.i||'"' 
    ADDRESS COMMAND cmd||file||' '||COMMAND.i||'"'
end

say "*** Appending to conf/local/custom.cnf"
conffile = "conf/local/custom.cnf"
say "*** Issuing " cmd||conffile||' INCLUDE '||file||'"'
ADDRESS COMMAND cmd||conffile||' INCLUDE '||file||'"'

say "*** Done"
/*
//SYSUT2   DD DSN=&&REXXCONF(NJECONF),DISP=(,PASS),UNIT=VIO,
//            SPACE=(TRK,(5,5,5))
//*
//* Execute the REXX script in TSO
//*
//EXECREXX EXEC PGM=IKJEFT01,
//       PARM='BREXX NJECONF',
//       REGION=8192K
//TSOLIB   DD   DSN=BREXX.CURRENT.RXLIB,DISP=SHR
//RXLIB    DD   DSN=BREXX.CURRENT.RXLIB,DISP=SHR
//SYSEXEC  DD   DSN=&&REXXCONF,DISP=SHR
//SYSPRINT DD   SYSOUT=*
//SYSTSPRT DD   SYSOUT=*
//SYSTSIN  DD   DUMMY
//STDOUT   DD   SYSOUT=*,DCB=(RECFM=FB,LRECL=140,BLKSIZE=5600)
//STDERR   DD   SYSOUT=*,DCB=(RECFM=FB,LRECL=140,BLKSIZE=5600)
//STDIN    DD   DUMMY
//**************************** \/\/\/\/
