*DECK MFLCALL 
          IDENT  MFLCALL
          ENTRY  MFLCALL
          SYSCOM B1 
          BASE   D
          TITLE  MFLCALL - PROGRAM CALLABLE INTERFACE TO MFLINK.
          COMMENT MFLCALL - PROGRAM CALLABLE INTERFACE TO MFLINK. 
          COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1994. 
  
*CALL COMCMAC 
 NBEONLY  IFEQ   OS$NOS 
 MFLCALL  SUBR
          EQ     MFLCALL
 NBEONLY  ELSE
 MFLCALL  SPACE  4,10 
*****     MFLCALL - PROGRAM CALLABLE INTERFACE TO MFLINK. 
* 
*         P. C. HAHN               08/15/81 
* 
*         THIS PROGRAM PROVIDES AN ACCESS TO THE FILE TRANSFER
*         FACILITY (*MFLINK*) OF THE NOS/BE REMOTE HOST FACILITY (*RHF*)
*         FROM WITHIN A COMPASS PROGRAM, FROM WITHIN FTN4, AND FROM 
*         WITHIN OTHER HIGHER LEVEL LANGUAGES THAT SUPPORT AN FTN4-LIKE 
*         CALLING SEQUENCE. 
          SPACE  4,10 
*** 
* 
*         ENTRY  (X1) = FWA OF PARAMETER LIST IN FOLLOWING FORMAT:  
*                (THE *LDB* MACRO IS USED TO SET UP THE PARAMETER 
*                BLOCK IN COMPASS PROGRAMS.)
* 
*                PARM+0 VFD 42/0LLFN,6/SUB-ERROR,12/RETURN CODE 
*                    +1 VFD 18/3LST,42/0
*                    +2 VFD 12/2LUU,48/0
*                    +3 VFD 42/0LI,18/0 
*                    +4 VFD 24/0,12/EP,12/RT,12/RC
* 
*                WHERE:   LFN - FILE NAME TO BE USED FOR FILE TRANSFERS.
*                               ONE TO SEVEN DISPLAY CODE CHARACTERS. 
*                         SUB-ERROR, RETURN CODE - IGNORED ON ENTRY.
*                               (SEE EXIT CONDITIONS, BELOW.) 
*                         ST  - MAINFRAME ID FOR FILE TRANSFERS.
*                               THREE DISPLAY CODE CHARACTERS.
*                         DD  - DATA DECLARATION OF FILE. 
*                               TWO DISPLAY CODE CHARACTERS.
*                         I   - LOCAL FILE NAME OF FILE CONTAINING
*                               COMMANDS TO BE EXECUTED ON THE REMOTE 
*                               MAINFRAME. ONE TO SEVEN DISPLAY CODE
*                               CHARACTERS. 
*                         EP  - IF NON-ZERO, DESELECT ERROR PROCESSING. 
*                         RT  - IF NON-ZERO, REAL-TIME TRANSFER 
*                               REQUESTED.
*                         RC  - IF NON-ZERO, RETURN CODE RETURNED TO
*                               LEAST SIGNIFICANT SIX BITS OF PARMLIST. 
* 
*         EXIT   IF RC NOT SPECIFED, DAYFILE MESSAGE ISSUED AND 
*                JOB ABORTED IF ANY PROBLEMS CALLING MFLINK. ELSE,MFLINK
*                SUCCESSFULLY CALLED. 
* 
*                IF RC SPECIFIED, 
* 
*                PARM+0 = 42/0LLFN, 6/SUB-ERROR, 12/RETURN CODE.
* 
*                RETURN CODE =
* 
*                0 - NORMAL RETURN. 
*                1 - NORMAL RETURN.  NO FILE TRANSFERRED. 
*                2 - NOT ENOUGH FL TO LOAD MFLINK.
*                10B - SWT ERROR. CONTROL POINT NOT QUIET.
*                11B - SWT ERROR. ZZZZZSW FILE ALREADY EXISTS.
*                12B - SWT ERROR. ILLEGAL CALL. 
*                14B - SWT ERROR. I/O ERROR ON *ZZZZZSW* FILE.
*                15B - SWT ERROR. FNT FULL. 
*                20B - MFLINK ERROR.  DURING FILE TRANSFER. 
*                21B - MFLINK ERROR.  NO FILE TRANSFER. 
*                22B - MFLINK ERROR.  AFTER FILE TRANSFER.
*                23B - MFLINK ERROR.  ABORTED BY SYSTEM.
*                77B - INVALID RETURN CODE RECEIVED FROM MFLINK OR SWT. 
* 
*                SUB-ERROR (DEFINED ONLY FOR RETURN CODE 21B) = 
* 
*                0 - MFLINK ERROR.  BAD CONTROL CARD. 
*                1 - MFLINK ERROR.  ERROR DURING NETON. 
*                2 - MFLINK ERROR.  ERROR STARTING TRANSFER.
* 
* 
*         USES   ALL BUT A0.
*                (B1) = 1 ON EXIT.
* 
*         CALLS  SYS=, RCL=, CIO=, MSG=.
* 
*         PROCESS - FIRST CALL PRS TO RETURN *ZZZZZSW* AND PRESET SOME
*         VARIABLES. THEN CALL PPL TO TRANSFORM THE PARAMETER LIST INTO 
*         A VALID *FTFPC* CONTROL CARD IMAGE IN RA.CCD. THEN, CALL SUO. 
*         SUO CALLS PP ROUTINE *SWT* TO SAVE OUR FIELD LENGTH, AND TO 
*         CAUSE THE CONTROL CARD IMAGE IN RA.CCD TO BE EXECUTED. ON 
*         RETURN, SUO CHECKS THE RETURN CODE FROM SWT. IF IT IS ANYTHING
*         BUT *CONTROL POINT BUSY*, SUO EXITS. ELSE, SUO TRIES TO 
*         CALL *SWT* AGAIN, UP TO SOME ARBITRARY NUMBER OF TIMES. 
*         PRC IS THEN CALLED TO HANDLE THE RETURN CODE, WHICH INVOLVES
*         EITHER SENDING A DAYFILE MESSAGE OR RETURNING AN ERROR CODE TO
*         THE USER/S PARAMETER LIST, AS SPECIFIED BY THE *RC* OPTION. 
*         WE THEN RETURN, OR ABORT, AS NECESSARY. 
* 
*         EXAMPLE - THE FOLLOWING SKELETON PROGRAM: 
* 
*           . 
*           . 
*           . 
*         SA1    PARMAD 
*         RJ     =XMFLCALL
*           . 
*           . 
*           . 
* PARMAD  VFD    60/PARM
* PARM    VFD    42/5LLFILE,6/0,12/0
*         VFD    18/3LMFX,42/0
*         VFD    12/2LUU,48/0 
*         VFD    42/5LINPUT,18/0
*         VFD    24/0,12/1,12/1,12/1
*           . 
*           . 
*           . 
* 
*         EFFECTS RESULTS SIMILAR TO THOSE OF THE CONTROL 
*         STATEMENT:  
*         *MFLINK(LFILE,ST=MFX,DD=UU,I=INPUT,EP,RT)*
*         WHILE ALLOWING USER PROCESSING OF ERRORS. 
 MFLCALL  SPACE  4,10 
 MFLCALL  SUBR   X                 ENTRY/EXIT 
          SB1    1
          RJ     PRS               PRESET 
          RJ     PPL               PROCESS PARMLIST 
          NZ     X6,MF2            IF BAD PARAM 
          RJ     CFL               CHECK FIELD LENGTH 
          PL     X4,MF1            FL OK
          SX7    FLE               ELSE LOAD SWT ERROR CODE 
          BX6    X6-X6             ZERO MFLINK ERROR
          IX5    X5-X5             ZERO SUB-ERROR CODE
          EQ     MF2               PROCESS ERROR CODE, ABORT IF NEEDED
  
 MF1      BSS    0
          RJ     SUO               SWITCH USER OUT
          RJ     XRC               EXTRACT RETURN CODE FROM PARMLIST
  
 MF2      BSS    0
          RJ     PRC               PROCESS RETURN CODE
          RJ     FIN               FINISH 
          SA1    KILL              TEST FLAG TO ABORT JOB 
          ZR     X1,MFLCALLX       NOT TO ABORT - EXIT
          ABORT                    KILL JOB 
 CFL      TITLE  CFL - CHECK FIELD LENGTH.
**        CFL - CHECK FIELD LENGTH. 
* 
*         ENTRY  (B1) = 1.
* 
*         EXIT   (X4) NEGATIVE IF NOT ENOUGH FL.
* 
*         USES   X - 1, 2, 4, 6.
*                A - 1, 2, 4, 6.
*                B - NONE.
* 
*         CALLS  SYS=.
  
  
 CFL      SUBR   X                 ENTRY/EXIT 
  
*         GET MAXIMUM FL AVAILABLE TO THIS JOB
  
          MX6    1                 (X6) = 1/1,59/0
          AX6    59-31             (X6) = 30/-1,30/0
          SA6    CFLA              STORE IN PARM TO MEM 
  
*         FIND OUT IF ENOUGH FL TO LOAD MFLINK
*         CHECK FOR A NOMINAL VALUE OF CFLB 
  
          MEMORY CM,CFLA,R         GET MAMIMUM FL AVAILABLE 
          MX0    -18               MASK FOR FL
          SA4    CFLA              MAXIMUM FL 
          SA2    CFLB              NOMINAL FL TO LOAD MFLINK
          LX4    30                SHIFT FL INTO LOW BITS 
          BX4    -X0*X4            MASK OUT FL
          IX4    X4-X2             FL - NOMINAL FL
          EQ     CFLX              EXIT 
          SPACE  4,10 
 CFLA     BSS    1                 STORE FOR MAXIMUM FL 
 CFLB     DATA   20000B            NOMINAL FL TO LOAD MFLINK
 FIN      TITLE  FIN - FINISH PROCESSING. 
**        FIN - FINISH PROCESSING.
* 
*         ENTRY  (B1) = 1.
*                (FLSAV-FLSAV+77) = OLD RA.SSW,RA.MTR+1-RA+77B. 
*                (SAVEA0) = OLD (A0). 
* 
*         EXIT   RA.SSW,RA.MTR+1-RA+77B RESTORED. 
*                OLD (A0) RESTORED. 
*                *ZZZZZSW* RETURNED.
* 
*         USES   X - 1, 4, 5, 6.
*                A - 0, 1, 4, 5, 6. 
*                B - 5, 6.
* 
*         CALLS  CIO=.
  
  
 FIN      SUBR   X           ENTRY/EXIT 
          RETURN ZZZZZSW,R   DON/T LEAVE *ZZZZZSW* LYING AROUND 
          SA1    FLSAV       GET OLD RA.SSW 
          BX6    X1 
          =A6    RA.SSW      RESTORE IT 
          =B5    RA.MTR+1    INITIALIZE POINTER 
          SB6    100B        INITIALIZE SENTINEL
  
 FIN1     BSS    0
          SA4    FLSAV-1+B5  GET WD TO RESTORE
          BX6    X4 
          SA6    B5          RESTORE IT 
          SB5    B5+B1       INCREMENT POINTER
          LT     B5,B6,FIN1  IF NOT DONE
          SA5    SAVEA0      RESTORE A0 FOR FTN 
          SA0    X5 
          EQ     FINX        EXIT 
 PPL      SPACE  4,10 
 PPL      TITLE  PPL - PROCESS PARAMETER LIST.
**        PPL - PROCESS PARAMETER LIST. 
* 
*         ENTRY  (B1) = 1.
*                (SAVEX1) = FWA OF PARMLIST.
* 
*         EXIT   PARMLIST TRANSFORMED INTO CONTROL CARD IMAGE IN RA.CCD.
* 
*         USES   X - ALL. 
*                A - 1-7. 
*                B - 2-7. 
* 
*         CALLS  ASR, CCS.
  
  
 PPL      SUBR   X                 ENTRY/EXIT 
          SA2    PPLA              GET *MFLINK( * IN ASSEMBLY REGISTER
          SB7    RA.CCD            SET POINTER TO STORE AREA
          SB5    7                 SET CHAR COUNT IN ASSEMBLY REGISTER
  
*         PROCESS FIRST PARM (LFN)
  
          SA1    SAVEX1            (X1) = ADDRESS OF PARMLIST 
          SA3    X1                X3 = FIRST PARAMTER
          RJ     CCS               COUNT CHARACTERS IN STRING 
          RJ     ASR               ADD STRING TO ASSEMBLY REGISTER
  
*         2ND PARM (ST) 
  
          SA3    X1+B1
          SX1    X1+B1
          ZR     X3,PPL1           IF NO ST PARAM 
          RJ     CCS               COUNT NUMBER OF CHARS
          SB4    3
          SX7    B4-B6
          SB2    B1+B1
          NZ     X7,PPL3           IF NOT 3 CHARS FOR ST PARAM
          SA3    PPLB              GET *,ST=* 
          SB6    4                 STRING COUNT 
          RJ     ASR               ADD TO ASSEMBLY REGISTER 
          SA3    X1                (X3) = STAGING MF ID 
          SB6    3                 STRING COUNT 
          RJ     ASR               ADD TO ASSEMBLY REGISTER 
 PPL1     BSS    0
  
*         3RD PARAM (DD)
  
          SA3    X1+B1
          SX1    X1+B1
          ZR     X3,PPL2           IF NO DD PARAM 
          RJ     CCS               COUNT NUMBER OF CHARS
          SB4    B1+B1
          SX7    B4-B6
          SB2    B1 
          NZ     X7,PPL3           IF NOT 2 CHARS FOR DD PARAM
          SA3    PPLC              GET *,DD=* 
          SB6    4                 STRING COUNT 
          RJ     ASR               ADD TO ASSEMBLY REGISTER 
          SA3    X1                (X3) = DD SPECIFIED
          SB6    2                 STRING COUNT 
          RJ     ASR               ADD TO ASSEMBLY REGISTER 
 PPL2     BSS    0
  
*         FOURTH PARAMETER (I)
  
          SA3    X1+B1
          SX1    X1+B1
          SB2    B0 
          ZR,X3,PPL3               IF NO I PARAM
          SA3    PPLD              GET *,I=*
          SB6    3                 STRING COUNT 
          RJ     ASR               ADD TO ASSEMBLY REGISTER 
          SA3    X1                (X3) = INPUT LFN SPECIFIED 
          RJ     CCS               COUNT CHARACTERS IN STRING 
          RJ     ASR               ADD TO ASSEMBLY REGISTER 
          SX7    0                 SET NO BAD PARAM 
          SB2    0
  
 PPL3     BSS    0
          SA7    PPLZ              SAVE BAD PARAM FLAG
          SX1    X1+B2
  
*         5TH PARAM - (EP)
  
          MX0    12                FORM MASK FOR EP PARM
          LX0    36                SHIFT INTO POSITION
          SX1    X1+B1             GET ADDRESS OF EP PARM 
          SA1    X1                (X1) = 24/UNUSED,12/EP,12/RT,12/RC 
          BX5    X0*X1             MASK OUT EP PARM 
          ZR     X5,PPL4           IF NO EP SPECIFIED 
          SA3    PPLE              GET *,EP*
          SB6    3                 STRING COUNT 
          RJ     ASR               ADD TO ASSEMBLY REGISTER 
 PPL4     BSS    0
  
*         SIXTH PARAM - (RT)
  
          MX0    12                FORM MASK FOR RT 
          LX0    24                SHIFT MASK INTO POSN.
          BX5    X0*X1             X5 .NE. 0 IF RT SPECIFIED
          ZR     X5,PPL5           IF NO RT SPECIFIED 
          SA3    PPLF              GET *,RT*
          SB6    3                 STRING COUNT 
          RJ     ASR               ADD TO ASSEMBLY REGISTER 
 PPL5     BSS    0
  
*         SEVENTH PARAM - (RC)
  
          MX0    -12               FORM MASK FOR RC PARM
          BX6    -X0*X1            MASK OUT RC PARM 
          ZR     X6,PPL6           IF NO RC SPECIFIED 
          SA3    PPLG              GET *,RC*
          SA6    UEP               SET USER ERROR PROCESSING .NE. 0 
          SB6    3                 STRING COUNT 
          RJ     ASR               ADD TO ASSEMBLY REGISTER 
  
 PPL6     BSS    0
          SA1    PPLZ              FETCH BAD PARAM FLAG 
          SA3    UEP
          ZR     X1,PPL8           IF NO BAD PARAM
          NZ     X3,PPL7           IF RETURNING CODE
          MESSAGE  PERR            *BAD PARAMETER IN CALL*
 PPL7     BSS    0
          SX5    B0                NO SUB ERROR CODE
          SX6    MFFEN             NO FILE XFERRED CODE 
          SX7    B0                NO SWT ERROR 
          EQ     PPLX 
  
 PPL8     BSS    0
  
*         LAST PARAM - (SW)  TELL MFLINK - MFLCALL
  
          SA3    PPLH              GET *,SW*
          SB6    3                 STRING COUNT 
          RJ     ASR               ADD TO ASSEMBLY REGISTER 
  
*         FINISH - ADD CTRL CARD TERMINATOR 
  
          SA3    PPLI              GET * )* 
          SB6    B1                STRING COUNT 
          RJ     ASR               ADD TO ASSEMBLY REGISTER 
          BX7    X2                GET ANY UNSTORED STRING
          MX6    0                 ZERO X6
          SA7    B7                STORE UNSTORED STRING
          SA6    B7+B1             STORE ZERO TERMINATOR
          EQ     PPLX              EXIT 
  
  
 PPLA     CON    7LMFLINK(
 PPLB     CON    4L,ST= 
 PPLC     CON    4L,DD= 
 PPLD     CON    3L,I=
 PPLE     CON    3L,EP
 PPLF     CON    3L,RT
 PPLG     CON    3L,RC
 PPLH     CON    3L,SW
 PPLI     CON    1L)
 PPLZ     BSSZ   1                 BAD PARAM FLAG 
 PRC      TITLE  PRC - PROCESS RETURN CODE. 
**        PRC - PROCESS RETURN CODE.
* 
*         ENTRY  (X5) = SUB-ERROR CODE. 
*                (X6) = MFLINK ERROR. 
*                (X7) = SWT ERROR. (NOTE THAT FL ERROR IS TREATED AS AN 
*                       SWT ERROR). 
*                (UEP) = 0 IF NO USER ERROR PROCESSING. 
* 
*         EXIT   (KILL) = .NE. 0 IF TO KILL JOB, ELSE = 0.
*                DAYFILE MESSAGE ISSUED OR ERROR CODE RETURNED, 
*                AS APPROPRIATE.
*         USES   X - 0, 1, 2, 3, 5, 6, 7. 
*                A - 0, 1, 6, 7.
*                B - 2, 3.
* 
*         CALLS  REC, IDK.
* 
*         PROCESS - IF NO ERRORS, LOW 18 BITS OF PARAMETER LIST 
*         WORD ZERO ZEROED, TO INDICATE NORMAL COMPLETION.
*         ELSE, IF USER ERROR PROCESSING SPECIFIED, RETURN
*         THE ERROR CODE, AND THE SUB-ERROR CODE, IF ANY, TO
*         PARAMETER LIST WORD ZERO. IF USER ERROR PROCESSING NOT
*         SPECIFIED (AND ERROR) ISSUE APPROPRIATE DAYFILE MESSAGE 
*         AND FLAG MAIN LOOP TO ABORT JOB ON COMPLETION.
  
  
 PRC2     BSS    0
  
*         NO USER ERROR PROCESSING. EXPLAIN ERROR A LITTLE HARDER.
  
          RJ     IDK               ISSUE DAYFILE MESSAGE AND KILL 
  
 PRC      SUBR   X                 ENTRY/EXIT 
          BX0    X5+X6             SUB-ERROR + MFLINK ERROR 
          BX0    X0+X7             SUB-ERROR + MFLINK ERROR + SWT ERROR 
          NZ     X0,PRC1           SOME KIND OF ERROR, HANDLE IT
  
*         NO ERROR, CLEAR LOW 18 BITS OF PARM LIST
*         TO INDICATE OK COMPLETION 
  
          SA1    SAVEX1            (X1) = ADDRESS OF PARMLIST 
          MX6    -18               MASK FOR ERROR, SUB-ERROR
          SA2    X1                (X2) = PARMLIST WD ZERO (ABCDEFGXYZ) 
          BX6    X6*X2             (X6) = ABCDEFG---
          SA6    X1                RESET PARMLIST 
          EQ     PRCX              EXIT 
  
 PRC1     BSS    0
  
*         SOME ERROR - CHECK ERROR PROCESSING AND ACT ACCORDINGLY.
  
          SA1    UEP               TEST USER ERROR PROCESSING OPTION
          ZR     X1,PRC2           NO USER ERROR PROCESSING 
  
*         USER ERROR PROCESSING SPECIFIED, EXPLAIN ERROR. 
  
          RJ     REC               RETURN ERROR CODE
          EQ     PRCX              EXIT 
 PRS      TITLE  PRS - PRESET PROGRAM.
**        PRS - PRESET PROGRAM. 
* 
*         ENTRY  (B1) = 1.
* 
*         EXIT   (SAVEA0) = OLD CONTENTS OF A0. 
*                (SAVEX1) = OLD CONTENTS OF X1. 
*                (FLSAV-FLSAV+77) = RA+0,RA+2-RA+77.
*                (UEP) = 0. 
*                (KILL) = 0.
* 
*         USES   X - 1, 4, 6, 7.
*                A - 1, 4, 6, 7.
*                B - 5, 6.
* 
*         CALLS  CIO=.
  
  
 PRS      SUBR   X                 ENTRY/EXIT 
          BX7    X7-X7
          SA7    UEP               PRESET FOR NO USER ERROR PROCESSING
          SA7    KILL              PRESET NOT TO DROP JOB 
          SX6    A0 
          SX7    X1 
          SA6    SAVEA0            SAVE A0
          SA7    A6+B1             SAVE X1
  
*         SAVE LOW CORE 
  
          =A1    RA.SSW            GET SENSE SWITCHS
          BX6    X1 
          =B5    RA.MTR+1          INITIALIZE POINTER 
          SA6    FLSAV             SAVE SENSE SWITCHS 
          SB6    100B              INITIALIZE SENTINEL
  
 PRS1     BSS    0
          SA4    B5                GET NEXT WORD TO SAVE
          SB5    B5+B1             INCR. POINTER
          BX6    X4 
          SA6    FLSAV-2+B5        SAVE WORD
          LT     B5,B6,PRS1        IF NOT ALL WORDS NOT MOVED 
  
*         RETURN ZZZZZSW, JUST IN CASE
  
          CLOSE  ZZZZZSW,UNLOAD,R 
          EQ     PRSX              EXIT 
  
 SUO      TITLE  SUO - SWITCH USER OUT. 
**        SUO - SWITCH USER OUT.
* 
*         ENTRY  (B1) = 1.
*                (RA.CCD-RA.CCD+X) = CONTROL CARD IMAGE FOR SWT.
* 
*         EXIT   BITS 1-6 OF RPLY CONTAIN RETURN CODE FROM SWT. 
*                BITS 7-12 OF RPLY CONTAIN RETURN CODE FROM MFLINK. 
*                BITS 13-24 OF RPLY CONTAIN ERROR SUB-CODE FROM MFLINK. 
* 
*         USES   X - 0, 1, 6. 
*                A - 1, 6.
*                B - 2, 3.
* 
*         CALLS  SYS=, RCL=.
  
*         PROCESS  CALL SWT. CHECK RETURN CODE. IF RETURN CODE IS 
*                  *CP NOT QUIET*, TRY AGAIN, UP TO A MAXIMUM NUMBER
*                  OF TIMES. ELSE, EXIT.
  
  
 SUO      SUBR   X                 ENTRY/EXIT 
          SB2    B0                INITIALIZE COUNTER FOR NO. OF TRIES
          SB3    10                MAXIMUM NO. OF TRIES 
          BX6    X6-X6             ZERO X6
          SA6    RPLY              ZERO RPLY
  
 SUO1     BSS    0
          SYSTEM SWT,R,RPLY,1      CALL SWT 
          SA1    RPLY              GET REPLY WORD 
          MX0    -6                MASK 
          LX1    59-1              SHIFT REPLY WORD 
          BX6    -X0*X1            MASK OUT ERROR CODE
          SX6    X6-CNQ            TEST ERROR CODE
          NZ     X6,SUOX           EXIT - NOT *CONTROL POINT BUSY*
          SB2    B2+B1             INCREMENT COUNTER FOR NO. OF TRIES 
          GT     B2,B3,SUOX        EXIT - TRIED OFTEN ENOUGH
          SA6    A1                ELSE RESET REPLY WORD
          RECALL                   TAKE A SHORT BREAK 
          EQ     SUO1              TRY AGAIN
 XRC      TITLE  XRC - EXTRACT RETURN CODE. 
**        XRC - EXTRACT RETURN CODE.
* 
*         ENTRY  (B1) = 1.
*                (RPLY) = SWT REPLY WORD -
*                41/UNUSED,6/SUBERROR,6/MFLINK ERROR,6/SWT ERROR,1/CMP
* 
*         EXIT   (X5) = SUB-ERROR 
*                (X6) = MFLINK ERROR. 
*                (X7) = SWT ERROR.
* 
*         USES   X - 1, 5, 6, 7.
*                A - 1. 
*                B - NONE.
  
 XRC      SUBR   X                 ENTRY/EXIT 
          SA1    RPLY              GET REPLY WORD 
          MX5    -6                SET MASK 
          LX1    -1                RIGHT-JUSTIFY BITS 6-1 
          BX7    -X5*X1            SWT ERROR
          LX1    -6                RIGHT-JUSTIFY BITS 12-7
          BX6    -X5*X1            MFLINK ERROR 
          LX1    -6                RIGHT-JUSTIFY BITS 18-13 
          BX5    -X5*X1            SUB CODE 
          EQ     XRCX              EXIT 
          TITLE  UTILITY ROUTINES.
 ASR      SPACE  4,10 
**        ASR - ADD STRING TO REGISTER. 
* 
*         ENTRY  (B1) = 1.
*                (X2) = ASSEMBLY REGISTER.
*                (X3) = STRING TO ADD.
*                (B5) = CHAR COUNT IN ASSEMBLY REGISTER.
*                (B6) = CHAR COUNT IN STRING. 
*                (B7) = POINTER TO WORK AREA TO STORE COMPLETED STRINGS.
* 
*         EXIT   (B1) = 1.
*                (X2) = OLD STRING CONCATENATED WITH NEW. 
*                (B5) = NEW CHAR COUNT IN ASSEMBLY REGISTER.
*                (B7) = POINTER TO WORK AREA. INCREMENTED 
*                       IF COMPLETED WORD STORED. 
* 
*         USES   X - 0, 2-7.
*                B - 2-7. 
*                A - 2-7. 
  
  
 ASR      SUBR   X                 ENTRY/EXIT 
          MX0    1
          SB4    10 
          SB3    B4-B5             COUNT OF CHARS THAT CAN BE ADDED 
          SB4    B3+B3             B4 = 2 * B3
          SB4    B4+B3             B4 = 3 * B3
          SB4    B4+B4             B4 = 6 * B3 (SHIFT COUNT)
          SB2    B4-B1             SHIFT COUNT - 1 = MASK SHIFT COUNT 
          AX0    B2                FORM MASK FOR CHARS TO STORE 
          BX6    X0*X3             MASK OUT CHARACTERS
          LX6    B4                SHIFT INTO POSITION
          BX2    X2+X6             ADD CHARACTERS TO ASSEMBLY REGISTER
          LT     B6,B3,ASR2        STILL ROOM IN ASSEMBLY REGISTER
  
*         ASSEMBLY REGISTER FULL
  
          BX7    X2                GET COMPLETED WORD 
          SA7    B7                STORE
          SB7    B7+B1             BUMP POINTER 
          EQ     B3,B6,ASR1        NO REMAINING STRING
          LX3    B4                SHIFT NEW STRING INTO POSITION 
          SB5    B6-B3             (B5) = CHARS LEFT IN STRING
          SB2    B5+B5             (B2) = 2 * B5
          SB2    B2+B5             (B2) = 3 * B5
          SB2    B2+B2             (B2) = 6 * CHARS LEFT IN STRING
          SB2    B2-B1
          MX0    1
          AX0    B2 
          BX2    X0*X3             MASK OUT CHARS TO BE SAVED 
*         SB5    B6-B3             SET NEW ASSEMBLY REG. CHAR COUNT 
          EQ     ASRX              EXIT 
  
 ASR1     BSS    0
          SB5    B0                ZERO ASSEMBLY REG. CHAR COUNT
          IX2    X2-X2             ZERO ASSEMBLY REGISTER 
          EQ     ASRX              EXIT 
  
  
 ASR2     BSS    0
          SB5    B5+B6             INCREMENT ASSEMBLY COUNT 
          EQ     ASRX              EXIT 
 CCS      SPACE  4,10 
**        CCS - COUNT CHARACTERS IN STRING. 
* 
*         ENTRY  (X3) = STRING. 
* 
*         EXIT   (B6) = COUNT.
*                (B1) = 1.
* 
*         USES   X - 0, 4, 5. 
*                A - NONE.
*                B - 2, 4, 6. 
  
 CCSX     SB6    B4+10             CALC CHAR COUNT
  
 CCS      SUBR   -                 ENTRY/EXIT 
  
          MX0    -6                CHARACTER MASK 
          BX4    X3                MOVE STRING TO WORKING REGISTER
          SB4    -10               MAX CHAR COUNT 
 CCS1     BSS    0
          LX4    6                 POSITION NEXT CHAR 
          BX5    -X0*X4            ISOLATE CHAR 
          SB2    X5-45B 
          ZR     X5,CCSX           STOP IF ZERO CHAR
          PL     B2,CCSX           STOP IF NOT ALPHA-NUMERIC CHAR 
          SB4    B4+B1
          NZ     B4,CCS1           IF NOT END OF STRING 
          EQ     CCSX 
 IDK      SPACE  4,10 
**        IDK - ISSUE DAYFILE MESSAGE AND KILL. 
* 
*         ENTRY  (B1) = 1.
*                (X5) = SUB-ERROR CODE. 
*                (X6) = MFLINK ERROR CODE.
*                (X7) = SWT ERROR CODE. 
* 
*         EXIT   DAYFILE MESSAGE ISSUED, (KILL) SET NONZERO,
*                UNLESS ERROR IS *NO FILE TRANSFERRED*. 
* 
*         USES   X - 1, 2, 5, 6, 7. 
*                A - 0, 1, 2, 6, 7. 
*                B - 2, 5.
* 
*         CALLS  MSG=.
  
  
 IDK      SUBR   X                 ENTRY/EXIT 
          RJ     MEC               MAP ERRORS INTO OUR ERROR CODES
          SB5    X7                SAVE ERROR CODE
          SA2    MET+X7            GET ADDRESS OF DAYFILE MESSAGE 
          MESSAGE X2               ISSUE MESSAGE
          SB5    B5-MFFNN          TEST FOR NO ERROR, NO TRANSFER 
          ZR     B5,IDKX           IF NO ERROR, NO TRANSFER 
          SX6    B1+
          SA6    KILL              FLAG MAIN LOOP TO KILL JOB 
          EQ     IDKX              EXIT 
 MEC      SPACE  4,10 
**        MEC    MAP ERROR CODE. MAP ERROR CODE TO OUR ERR CODE.
* 
*         ENTRY  (X5) = SUB-ERROR CODE. 
*                (X6) = MFLINK ERROR CODE.
*                (X7) = SWT ERROR CODE. 
*                (B1) = 1.
* 
*         EXIT   (X6) = SUB-ERROR CODE. 
*                (X7) = MFLCALL ERROR CODE. 
* 
*         USES   X - 1, 5, 6, 7 
*                A - 1. 
*                B - 2. 
* 
*         CALLS  NONE.
  
  
 MEC1     BSS    0
          IX5    X5-X5             ZERO SUB-ERROR 
          SX7    URC               SET UNKNOWN RETURN CODE
  
 MEC      SUBR   X                 ENTRY/EXIT 
          ZR     X7,MEC2           NO SWT ERROR 
          SB2    X7-SETL           (B7) = SWT ERROR - MAX 
          PL     B2,MEC1           OUT OF RANGE 
          SA1    SET+X7            GET CORRESPONDING MFLCALL ERROR
          BX6    X5                MOVE SUB-ERROR CODE
          IX5    X5-X5
          BX7    X1                X7 = MFLCALL ERROR 
          EQ     MECX              EXIT 
  
 MEC2     BSS    0
  
*         TEST MFLINK ERROR 
  
  
          NZ     X6,MEC3           SOME MFLINK ERROR
          IX5    X5-X5             ZERO SUB-ERROR 
*         BX7    X7-X7             ZERO ERROR 
          EQ     MECX              EXIT 
  
 MEC3     BSS    0
          SB2    X6-FSTL           B2 = MFLINK ERROR CODE - MAX 
          PL     B2,MEC1           IF UNKNOWN ERROR CODE
          SA1    FST+X6            ERROR CODE IS OFFSET INTO TABLE
          BX6    X5                MOVE SUB-ERROR CODE
          IX5    X5-X5             ZERO SUB-ERROR 
          BX7    X1                (TABLE ENTRY) = MFLINK ERROR 
          EQ     MECX              EXIT 
 REC      SPACE  4,10 
**        REC    RETURN ERROR CODE(S) TO LOW 18 BITS
*                OF USER PARAMETER LIST.
* 
*         ENTRY  (B1) = 1.
*                (X5) = SUB-ERROR.
*                (X6) = MFLINK ERROR. 
*                (X7) = SWT ERROR.
* 
*         EXIT   PARMLIST+0 = 42/LFN(UNCHANGED),6/SUB-ERROR,12/ERROR. 
* 
*         USES   X - 0, 1, 6, 7.
*                A - 1, 7.
*                B - NONE.
* 
*         CALLS  MEC. 
  
  
 REC      SUBR   X                 ENTRY/EXIT 
          RJ     MEC               MAP ERROR CODE(S) INTO MFLCALL ERROR 
          LX6    12                SHIFT SUB-ERROR INTO POSN. 
          SA1    SAVEX1            (X1) = FWA OF PARMLIST 
          MX0    -18               MASK FOR HIGH ORDER OF PARMLIST WD 0 
          SA1    X1                GET PARMLIST WORD ZERO 
          BX7    X6+X7             MERGE SUB-ERROR AND ERROR
          BX1    X0*X1             CLEAR LOW 18 OF PARMLIST WORD 0
          BX7    -X0*X7            CLEAR TOP 42 OF SUB-ERROR+ERROR
          BX7    X1+X7             MERGE TOP 42 + SUB-ERROR + ERROR 
          SA7    A1                RESTORE PARMLIST WORD ZERO 
          EQ     RECX              EXIT 
 TABLES   TITLE  ERROR RETURN CODE TABLES.
 FST      SPACE  4,10 
**        FST - MFLINK ERROR CODE TABLE.
*         EACH ENTRY IS THE MFLINK ERROR CORRESPONDING
*         TO THE MFLINK ERROR CODE. MFLINK ERROR CODE 
*         IS THE INDEX TO THIS TABLE. 
  
  
 FST      BSS    0
          LOC    0
          CON    URC               0 - INVALID
          CON    MFFNN             NO ERROR. NO FILE TRANSFERRED. 
          CON    URC               2 - SWT ERROR
          CON    URC               3 - UNKNOWN
          CON    URC               4 - UNKNOWN
          CON    URC               5 - UNKNOWN
          CON    URC               6 - UNKNOWN
          CON    URC               7 - UNKNOWN
          CON    URC               10B -SWT ERROR 
          CON    URC               11B - SWT ERROR
          CON    URC               12B - SWT ERROR
          CON    URC               13B - SWT ERROR
          CON    URC               14B - SWT ERROR
          CON    URC               15B - SWT ERROR
          CON    URC               16B - UNKNOWN
          CON    URC               17B - UNKNOWN
          CON    MFFEX             ERROR. DURING FILE TRANSFER
          CON    MFFEN             ERROR. NO FILE TRANSFERRED.
          CON    MFFAT             ERROR. AFTER FILE TRANSFER.
          CON    MFSAB             ABORTED BY SYSTEM
          LOC    *O 
 FSTL     EQU    *-FST             TABLE LENGTH 
 SET      SPACE  4,10 
**        SET - SWT ERROR TABLE.
*         SWT ERROR IS AN INDEX TO THIS TABLE. CONTENTS OF
*         THE ENTRY IS THE CORRESPONDING MFLCALL ERROR. 
*         NOTE THAT FL ERROR IS TREATED AS AN SWT ERROR.
  
  
 SET      BSS    0
          LOC    0
          DATA   0                 0 - NORMAL RETURN
          CON    1                 1 - MFLINK ERROR CODE * MFFNN *
 FLE      CON    FLE               2 - NOT ENOUGH FL TO LOAD MFLINK.
          CON    URC               3 - UNKNOWN
          CON    URC               4 - UNKNOWN
          CON    URC               5 - UNKNOWN
          CON    URC               6 - UNKNOWN
          CON    URC               7 - UNKNOWN
 CNQ      CON    MFCNQ             10B - CONTROL POINT NOT QUIET
 ZFE      CON    MFZFE             11B - *ZZZZZSW* EXISTS 
 ILC      CON    MFSIC             12B - ILLEGAL CALL 
 ZNE      CON    URC               13B - *Z-SW* DOESNT EXIST - SENSELESS
 IOE      CON    MFIOE             14B - I/O ERROR ON *ZZZZZSW* 
 FNF      CON    MFFNF             15B - FNT FULL 
          LOC    *O 
 SETL     EQU    *-SET             TABLE LENGTH 
 ERRORS   TITLE  DAYFILE ERROR MESSAGES.
 MET      SPACE  4,10 
**        MET - MFLCALL ERROR TABLE.
  
 MET      BSS    0
          LOC    0
          CON    MFLE 
 MFFNN    CON    =C* MFLCALL/MFLINK - NO ERROR. NO FILE TRANSFERRED.* 
 FLE      CON    =C* MFLCALL - NOT ENOUGH FL TO LOAD MFLINK.* 
          DUP    7-*+1,1
          CON    MFLE 
 MFCNQ    CON    =C* MFLCALL/SWT - CONTROL POINT NOT QUIET.*
 MFZFE    CON    =C* MFLCALL/SWT - ZZZZZSW ALREADY EXISTS.* 
 MFSIC    CON    =C* MFLCALL/SWT - SWT CALL ERROR.* 
          CON    MFLE 
 MFIOE    CON    =C* MFLCALL/SWT - I/O ERROR ON ZZZZZSW.* 
 MFFNF    CON    =C* MFLCALL/SWT - FNT FULL.* 
          DUP    17B-*+1,1
          CON    MFLE 
 MFFEX    CON    =C* MFLCALL/MFLINK - ERROR. DURING FILE TRANSFER.* 
 MFFEN    CON    =C* MFLCALL/MFLINK - ERROR. NO FILE TRANSFERRED.*
 MFFAT    CON    =C* MFLCALL/MFLINK - ERROR. AFTER FILE TRANSFER.*
 MFSAB    CON    =C* MFLCALL/MFLINK - ABORTED BY SYSTEM.* 
          DUP    76B-*+1,1
          CON    MFLE 
 URC      CON    =C* MFLCALL - UNKNOWN ERROR CODE RECEIVED.*
          LOC    *O 
  
  
 MFLE     DATA   C* MFLCALL INTERNAL ERROR* 
 PERR     DATA   C* MFLCALL - BAD PARAMETER IN CALL.* 
 DATA     TITLE  GLOBAL DATA FOR MFLCALL. 
 ZZZZZSW  FILEB  RA.ARG,65B SWT SAVE FILE 
 UEP      DATA   0                 NZ IF USER ERROR PROCESSING
 KILL     DATA   0                 NZ IF TO KILL JOB
 SAVEA0   BSS    1
 SAVEX1   BSS    1
 P        ERRNZ  SAVEX1-SAVEA0-1
 RPLY     VFD    41/0,6/0,6/0,6/0,1/0  SWT REPLY WORD  - 41/RESERVED
*                                                      - 6/SUB-ERROR
*                                                      - 6/MFLINK ERROR 
*                                                      - 6/SWT ERROR
*                                                      - 1/COMPLETE 
 FLSAV    BSS    100B-1            SAVE FOR 1ST 100B WORDS EXCEPT RA.MTR
 NBEONLY  ENDIF 
  
          END 
