Retro1.org codex

          IDENT  CPUPFM,FWA
          ABS
          SST
          ENTRY  CPF
          ENTRY  DMP=
          ENTRY  LIB=
          ENTRY  MFL=
          ENTRY  SSJ=
          ENTRY  UTL=
          SYSCOM B1
          TITLE  CPUPFM - COPY INDIRECT ACCESS FILES.
*COMMENT  CPUPFM - COPY INDIRECT ACCESS FILES.
          COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC.  1992.
 CPF      SPACE  4,10
***       CPUPFM - COPY INDIRECT ACCESS FILES.
*
*         R. C. SCHMITTER.   84/03/28.
          SPACE  4,10
***       *CPUPFM* IS CALLED BY *PFM* TO PERFORM THE COPY OF AN
*         INDIRECT ACCESS FILE FOR *GET*, *OLD*, *SAVE*, *REPLACE*
*         AND *APPEND* OPERATIONS IF THE FILE LENGTH IS GREATER
*         THAN THE THREHOLD DEFINED IN *COMSPFM*.  THE ONLY ENTRY
*         IS BY *DMP=* CALL TO *CPF*.  *CPUPFM* CANNOT BE CALLED
*         AT THE COMMAND LEVEL.
          SPACE  4,10
***       COMMAND FORMAT.
*
*         *SPCW* FORMAT FROM *PFM*.
*
*T        18/ *CPF*,6/ 30B,18/ 0,18/ COMMAND CODE
*
*         *CPUPFM* REPLY TO *PFM*.
*
*T        24/ 0,3/ 1,1/E ,8/ EC,24/ 0
*
*                E  = ERROR IDLE FLAG.  IF SET, ERROR IDLE STATUS IS
*                     TO BE SET FOR THE MASTER DEVICE BY *PFM*.
*
*                     THIS FLAG IS SET WHEN THE FILE TRANSFER IS
*                     INCOMPLETE FOR *APPEND*, *REPLACE*, AND *SAVE*
*                     COMMANDS.  THIS CONDITION CAN OCCUR WITH
*                     *TRACK LIMIT*, *PFM ABORTED*, AND *MASS STORAGE
*                     ERROR* ERROR CODES .
*
*                     THIS FLAG IS SET WITH *FILE LENGTH ERROR* ERROR
*                     CODE WHEN THERE IS A LOGICAL ERROR IN THE LENGTH
*                     OF THE FILE.
*
*                EC = *PFM* ERROR CODE.
*                     DTE(17) - DATA TRANSFER ERROR.
*                     TKL(31) - TRACK LIMIT.
*                     FLE(32) - FILE LENGTH ERROR.
*                     ABT(36) - PFM ABORTED.
*                     MSE(37) - MASS STORAGE ERROR.
*                     RTR(127) - RETRY REQUEST.
*
*
*         THE *DMPN* BLOCK IN NFL IS SET BY *PFM* WITH THE FOLLOWING
*         FORMAT.
*
*T        42/ LFN,18/ FLAGS
*T,       12/ ,24/ APFL, 24/ LF
*T,       36/ ,24/ RANDOM ADDRESS
*T,       60/ SRB (WORD 0)
*T,       60/ SRB (WORD 1)
*T,       60/ SRB (WORD 2)
*T,       60/ SRB (WORD 3)
*
*         LFN  = LOCAL FILE NAME.
*         FLAGS = 17/ ,1/ FGIA
*                FGIA = INDIRECT ALLOCATION INTERLOCK HELD.
*         LF   = TOTAL LENGTH OF FILE TO BE TRANSFERRED (BOTH PERMANENT
*                AND LOCAL FOR *APPEND*).
*         APFL = LENGTH OF THE LOCAL FILE FOR *APPEND*.
*              = 0, IF NOT *APPEND*.
*         SRB  = SPECIAL REQUEST BLOCK FOR THE ORIGINAL FILE FOR
*                *APPEND*.
*
*         IF *APFL* = *LF*, THEN THE *APPEND* IS AT THE END OF
*         THE INDIRECT CHAIN.
          SPACE  4,10
*         COMMON DECKS.
 
 
*CALL     COMCMAC
*CALL     COMCCMD
*CALL     COMSMLS
*CALL     COMSPFM
*CALL     COMSPFU
*CALL     COMSPRD
*CALL     COMSRPV
*CALL     COMSSSD
*CALL     COMSSSJ
          SPACE  4,10
*         MACROS.
 
 
 DELPFC   MACRO  LFN,SRB
          MACREF DELPFC
          =4     LFN,,,,SRB,,,,,,,,27B
 DELPFC   ENDM
          SPACE  4,10
****      ASSEMBLY CONSTANTS.
 
 
 BUFL     EQU    10030B      BUFFER LENGTH FOR SINGLE BUFFER COPY
 EIDF     EQU    400B        ERROR IDLE FLAG
****
          TITLE  FETS AND STORAGE LOCATIONS.
          ORG    120B
          SPACE  4,10
 FWA      BSS    0
 
*         FETS.
 
 
 I        BSS    0           INPUT FILE
 INPUT    FILEB  BUF,BUFL,FET=10D,EPR
 
 O        BSS    0           OUTPUT FILE
 OUTPUT   FILEB  BUF,BUFL,FET=16D,EPR,UPR
          SPACE  4,10
*         STORAGE LOCATIONS.
 
 
 APFL     CON    0           APPEND ORIGINAL FILE LENGTH
 ERRF     CON    0           ERROR FLAG
 FTCF     CON    0           FILE TRANSFER COMPLETE FLAG
 LENG     CON    0           FILE LENGTH
 LFAL     CON    0           LOCAL FILE ACCESS LEVEL
 LFNM     CON    0           LOCAL FILE NAME
 PFMC     CON    0           *PFM* COMMAND CODE
          SPACE  4,10
*         SPECIAL *PFM* COMMUNICATION FILE NAMES.
 
 
 APFN     VFD    42/7L"APF",18/3  APPEND FILE NAME
 ILKN     VFD    42/7L"ILK",18/3  INTERLOCK FILE NAME
 PFNM     VFD    42/7L"PFN",18/3  PERMANENT FILE NAME
          SPACE  4,10
*         *SSJ=* SPECIAL ENTRY POINT PARAMETER BLOCK.
 
 
 SSJ=     VFD    12/0,24/-0,12/PFCS,12/IRSI
          BSSZ   SSJL-1
 
 LIB=     EQU    0           ALLOW WRITE ON EXECUTE-ONLY FILE
 
 UTL=     EQU    0           ALLOW ACCESS TO SUSPECT DEVICE
          TITLE  MAIN PROGRAM.
*         MAIN PROGRAM.
 
 
 CPF      SB1    1           ENTRY
          RJ     PRS         PRESET
          SA1    APFL
          SA5    LENG        GET FILE LENGTH
          ZR     X1,CPF2     IF NOT *APPEND*
          IX5    X5-X1       SET ORIGINAL FILE LENGTH
          ZR     X5,CPF1     IF *APPEND* AT END OF CHAIN
 
*         PROCESS COPY OF ORIGINAL FILE (*APPEND* ONLY).
 
          SA1    APFN        SET INPUT FILE NAME
          BX6    X1
          SA6    I
          RJ     SBC         COPY PERMANENT FILE
          NZ     X1,CPF4     IF ERROR DETECTED
          SA1    I+FTFT      RESET BUFFER POINTERS
          SX6    X1
          SA6    A1+B1
          SA6    A6+B1
          SA1    O+FTFT
          SX6    X1
          SA6    A1+B1
          SA6    A6+B1
          SA1    LFNM        SET LOCAL FILE NAME
          BX6    X1
          SA6    I
 CPF1     SA5    APFL        GET FILE LENGTH
 
*         PROCESS FILE COPY (ALL FUNCTIONS).
 
 CPF2     RJ     SBC         COPY FILE
          NZ     X1,CPF4     IF ERROR DETECTED
          SX6    B1          SET FILE TRANSFER COMPLETE
          SA6    FTCF
          SA1    O+FTFT      CLEAR USER PROCESSING IN OUTPUT FET
          MX0    59
          LX0    45
          BX6    X0*X1
          SA6    A1
          SA1    LFNM        REWIND LOCAL FILE
          BX6    X1
          SA6    O
          REWIND O,R
          RJ     COS         CHECK OUTPUT FET STATUS
          NZ     X1,CPF4     IF ERROR DETECTED
          RJ     DOF         DELETE ORIGINAL FILE
          SA1    ERRF
          NZ     X1,CPF4     IF ERROR DETECTED
 
*         RETURN ALL *PFM* FILES.
 
 CPF3     RECALL I
          RECALL O
          SA1    PFNM        RETURN PERMANENT FILE
          BX6    X1
          SA6    O
          RETURN O,R
          SA1    ILKN        RETURN INTERLOCK FILE
          BX6    X1
          SA6    O
          RETURN O,R
          SA1    APFL
          ZR     X1,CPF4     IF NOT *APPEND*
          SA5    LENG
          IX5    X5-X1
          ZR     X5,CPF4     IF *APPEND* TO END OF CHAIN
          SA1    APFN        RETURN APPEND FILE
          BX6    X1
          SA6    O
          RETURN O,R
 
*         SET REPLY TO *PFM*.
 
 CPF4     SA1    ERRF        GET ERROR FLAG
          SX6    B1
          LX6    33
          ZR     X1,CPF6     IF NO ERROR DETECTED
          SA2    FTCF        CHECK FILE TRANSFER COMPLETE FLAG
          SA3    PFMC        CHECK COMMAND CODE
          NZ     X2,CPF5     IF FILE TRANSFER COMPLETE
          SX2    X3-CCGT
          ZR     X2,CPF5     IF *GET* COMMAND
          SX2    X3-CCOD
          ZR     X2,CPF5     IF *OLD* COMMAND
          SX1    X1+EIDF     SET ERROR IDLE FLAG
 CPF5     LX1    24          ADD ERROR FLAG TO REPLY
          BX6    X1+X6
 CPF6     SA6    SPPR        SET *SPCW*
          ENDRUN
          TITLE  SUBROUTINES.
 COS      SPACE  4,20
**        COS - CHECK OUTPUT FET STATUS,
*
*         ENTRY  (O) = OUTPUT FET.
*                (PFMC) = *PFM* FUNCTION.
*
*         EXIT   (X1) = 0 IF NO ERROR STATUS IN FET.
*                     .NE. 0 IF ERROR SET IN FET.
*                (ERRF) = ERROR FLAG SET IF ERROR SET IN FET.
*                         SET TO *RETRY REQUEST* FOR WRITE ERROR
*                         ON *GET* AND *OLD* REQUESTS AND TO
*                         *MASS STORAGE ERROR* FOR WRITE ERROR
*                         ON OTHER REQUESTS.
*                         SET TO *TRACK LIMIT* FOR FULL DISK ERROR.
*                         SET TO *PFM ABORTED* FOR ANY OTHER ERROR.
*
*         USES   X - 0, 1, 2, 6, 7.
*                A - 1, 2, 6, 7.
 
 
 COS      SUBR               ENTRY/EXIT
          SA2    O           OUTPUT FET
          BX1    X1-X1
          LX2    59-0
          PL     X2,COSX     IF FET BUSY
          LX2    59-13-59+0
          NG     X2,COS1     IF FATAL ERROR
          LX2    59-11-59+13
          NG     X2,COS2     IF PARITY ERROR
          LX2    59-10-59+11
          PL     X2,COSX     IF NO ERROR
 
*         PROCESS TRACK LIMIT ERROR.
 
          SX6    /ERRMSG/TKL *EQXXX,DNYY, TRACK LIMIT.*
          EQ     COS3        SET ERROR FLAG
 
*         PROCESS FATAL ERROR.
 
 COS1     SX6    /ERRMSG/ABT *PFM ABORTED.*
          EQ     COS3        SET ERROR FLAG
 
*         PROCESS PARITY ERROR.
 
 COS2     SA1    PFMC        CHECK *PFM* FUNCTION
          SX6    /ERRMSG/RTR RETRY REQUEST
          SX2    X1-CCGT
          ZR     X2,COS3     IF *GET*
          SX2    X1-CCOD
          ZR     X2,COS3     IF *OLD*
          SX6    /ERRMSG/MSE *EQXXX,DNYY, MASS STORAGE ERROR.*
 
*         SET ERROR FLAG AND CLEAR ERROR CODE FROM FET.
 
 COS3     SA6    ERRF        SET ERROR FLAG
          SA2    O           CLEAR ERROR CODE FROM FET
          MX0    56
          LX0    10
          BX7    X0*X2
          SA7    A2
          BX1    X6
          EQ     COSX        RETURN WITH (X1) .NE. 0
 ERR      SPACE  4,10
**        ERR - *REPRIEVE* ERROR PROCESSOR.
*
*
*         EXIT   (ERRF) = ERROR FLAG.
*                TO *CPF3* TO RETURN *PFM* COMMUNICATION FILES.
 
 
 ERR      BSS    0           ENTRY
          SX6    /ERRMSG/ABT *PFM ABORTED.*
          SA6    ERRF        SET ERROR FLAG
          EQ     CPF3        RETURN COMMUNICATION FILES
 
 
 ERRA     RPVBLK ERR         REPRIEVE PARAMETER BLOCK
 DOF      SPACE  4,10
**        DOF - DELETE ORIGINAL FILE.
*
*         EXIT   *PFM* CALLED TO DELETE PFC ENTRY FOR ORIGINAL
*                FILE ON *APPEND* OPERATION.
*                (ERRF) = ERROR RETURNED FROM *PFM*.
*
*         USES   X - 0, 1, 2, 6, 7.
*                A - 1, 2, 6, 7.
*
*         MACROS DELPFC.
 
 
 DOF      SUBR               ENTRY/EXIT
          SA1    APFL
          ZR     X1,DOFX     IF NOT *APPEND*
          SA2    LENG
          IX6    X1-X2
          ZR     X6,DOFX     IF *APPEND* AT END OF CHAIN
          DELPFC O,SPPR+4
          SA1    O           CHECK FOR ERROR
          MX0    -8
          LX0    10
          BX6    -X0*X1
          ZR     X6,DOFX     IF NO ERROR
          BX7    X0*X1       CLEAR ERROR CODE FROM FET
          SA7    A1
          LX6    0-10
          SA6    ERRF        SAVE ERROR CODE
          EQ     DOFX        RETURN
 SBC      SPACE  4,30
**        SBC - SINGLE BUFFER COPY.
*
*         ENTRY  (X5) = LENGTH OF FILE.
*
*         EXIT   (X1) = 0 IF FILE COPY COMPLETE.
*                     .NE. 0 IF FILE COPY INCOMPLETE.
*                (ERRF) = ERROR FLAG.
*
*         ERROR  WHEN READ PARITY ERROR DETECTED -
*                IF CORRECT SECTOR WAS READ, SET *DATA TRANSFER ERROR*
*                AND CONTINUE TRANSFER.
*                IF INCORRECT SECTOR WAS READ, SET *FILE LENGTH
*                ERROR* AND PAD OUTPUT FILE WITH EOF-S.
*
*         USES   X - ALL.
*                A - 0, 1, 2, 3, 4, 6.
*
*         CALLS  COS.
*
*         MACROS READCW, RECALL, WRITECW, WRITEW.
*
*         PROGRAMMER-S NOTE - WHEN CHECKING FOR FET COMPLETE AND
*         DATA IN THE BUFFER, THE FET STATUS MUST BE PICKED UP
*         BEFORE THE BUFFER POINTER.
*
*         THIS ROUTINE IS ADAPTED FROM *SBC* IN *COPYB*.
 
 
 SBC      SUBR               ENTRY/EXIT
          RECALL O
          WRITECW O,*        PRESET CONTROL WORD WRITE
          SA2    I+FTOT
          SA0    X2+         INITIALIZE INPUT PSEUDO OUT POINTER
          BX0    X0-X0       INDICATE NO BLOCKS AVAILABLE OR COMPLETE
          EQ     SBC9        INITIATE CONTROL WORD READ
 
*         CHECK FOR INPUT BLOCK AVAILABLE.
 
 SBC1     SA2    I           CHECK INPUT FILE STATUS
          SA3    I+FTIN      CHECK INPUT IN = PSEUDO OUT POINTER
          BX0    X0-X0       INDICATE NO BLOCKS AVAILABLE OR COMPLETE
          SX1    A0
          IX1    X3-X1
          LX2    59-0
          NZ     X1,SBC2     IF INPUT BLOCK AVAILABLE
          PL     X2,SBC4     IF BUFFER BUSY
          LX2    59-9-59+0
          NG     X2,SBC11    IF EOI
          LX2    59-13-59+9
          PL     X2,SBC1.1   IF NO FATAL ERROR
          SX1    /ERRMSG/ABT *PFM ABORTED.*
          BX6    X1
          SA6    ERRF        SET ERROR FLAG
          EQ     SBCX        RETURN WITH (X1) .NE. 0
 
 SBC1.1   LX2    59-11-59+13
          PL     X2,SBC4     IF NO READ PARITY ERROR STATUS IN FET
          SX7    /ERRMSG/DTE *DATA TRANSFER ERROR*
          SA7    ERRF
          SA1    I+6         CHECK DETAILED ERROR CODE
          LX1    59-11
          PL     X1,SBC1.2   IF CORRECT SECTOR READ
          SX6    B1          SET LENGTH ERROR DUE TO HARDWARE FAILURE
          SA6    SBCC
          EQ     SBC11       PAD FILE WITH EOF-S
 
 SBC1.2   MX6    1           CLEAR PARITY ERROR BIT IN FET
          BX6    X2-X6
          LX6    59-59-59+11
          SA6    A2
          EQ     SBC4        CONTINUE TRANSFER
 
*         PROCESS INPUT BLOCK.
 
 SBC2     SX0    B1          INDICATE INPUT BLOCK TRANSFERRED
          SA3    SBCB        INCREMENT BLOCK COUNT
          SX4    B1          INDICATE DATA TRANSFERRED
          IX6    X3+X4
          SA4    A0          CRACK CONTROL WORD HEADER
          MX7    -24
          SA6    A3
          BX7    -X7*X4      BYTE COUNT
          SX2    4           CALCULATE WORD COUNT
          IX7    X7+X2
          SX2    X2+B1
          IX7    X7/X2
          SA2    I+FTLM
          SX3    X7+2        ADVANCE OVER BLOCK AND CONTROL WORDS
          SX1    A0
          SX2    X2+
          IX2    X2-X1
          IX6    X3-X2
          NG     X6,SBC3     IF NO WRAP AROUND
          SA2    I+FTFT      FIRST
          BX3    X6
          SX1    X2
 SBC3     IX6    X1+X3
          SA1    A0          GET CONTROL WORD HEADER
          PL     X1,SBC3.1   IF NO READ ERROR OCCURRED ON THIS BLOCK
          SX7    /ERRMSG/DTE *DATA TRANSFER ERROR*
          SA7    ERRF
 
*         TRANSFER BLOCK TO OUTPUT.
 
 SBC3.1   ZR     X5,SBC13    IF SUPPLIED PRU COUNT NOT ALREADY WRITTEN
          SX1    B1          DECREMENT PRU COUNT
          IX5    X5-X1
          SA6    O+FTIN      ADVANCE OUTPUT IN POINTER
          SA0    X6          ADVANCE INPUT PSEUDO OUT POINTER
 
*         CHECK FOR REINITIATE CONTROL WORD WRITE.
 
 SBC4     SA1    O
          LX1    59-0
          PL     X1,SBC6     IF BUFFER BUSY
          RJ     COS         CHECK OUTPUT FILE STATUS
          NZ     X1,SBCX     IF ERROR OCCURRED
          SA1    O+FTIN
          SA2    A1+B1
          SX3    BUFL/3
          IX1    X1-X2       (IN-OUT)
          IX2    X1-X3       (IN-OUT) - 1/3(BUFFER SIZE)
          ZR     X1,SBC6     IF BUFFER EMPTY
          PL     X1,SBC5     IF IN .GT. OUT
          LX3    1
          IX2    X3+X1       2/3(BUFFER SIZE) - (OUT-IN)
 SBC5     NG     X2,SBC6     IF BUFFER THRESHOLD NOT REACHED
          WRITECW O          REINITIATE CONTROL WORD WRITE
 
*         CHECK FOR OUTPUT BLOCK WRITTEN.
 
 SBC6     SA1    O+FTOT      CHECK OUTPUT OUT = INPUT OUT
          SA2    I+FTOT
          IX3    X1-X2
          ZR     X3,SBC7     IF BLOCK NOT WRITTEN
          BX6    X1
          SX0    X0+1        INDICATE OUTPUT BLOCK COMPLETE
          SA6    A2+         UPDATE INPUT OUT = OUTPUT OUT
 
*         CHECK FOR REINITIATE CONTROL WORD READ.
 
 SBC7     SA4    I           CHECK INPUT FILE STATUS
          LX4    59-0
          PL     X4,SBC10    IF BUFFER BUSY
          SA1    I+FTIN
          LX4    59-11-59+0
          NG     X4,SBC10    IF PARITY ERROR STATUS IN FET
          LX4    59-3-59+11
          NG     X4,SBC10    IF EOF/EOI ENCOUNTERED
          LX4    59-13-59+3
          NG     X4,SBC10    IF FATAL ERROR STATUS IN FET
          SX3    BUFL/3      CHECK BUFFER THRESHOLD
          SA2    A1+B1
          IX1    X1-X2       (IN-OUT)
          IX2    X3+X1       1/3(BUFFER SIZE) + (IN-OUT)
          ZR     X1,SBC9     IF BUFFER EMPTY
          NG     X1,SBC8     IF OUT .GT. IN
          LX3    1
          IX2    X1-X3       (IN-OUT) - 2/3(BUFFER SIZE)
 SBC8     PL     X2,SBC10    IF BUFFER THRESHOLD NOT REACHED
 SBC9     READCW I,0         INITIATE CONTROL WORD READ TO EOI
 
*         CHECK FOR RECALL.
 
 SBC10    NZ     X0,SBC1     IF INPUT AND/OR OUTPUT BLOCKS TRANSFERRED
          RECALL             WAIT FOR DATA TRANSFER
          EQ     SBC1        CHECK FOR INPUT BLOCKS
 
*         PROCESS EOI.
 
 SBC11    ZR     X5,SBC14    IF NO FILE LENGTH ERROR
 
*         PROCESS INPUT FILE TOO SHORT.
 
 SBC12    WRITEW O,SBCA,B1+B1  PAD FILE WITH EOF
          SX1    B1
          IX5    X5-X1
          NZ     X5,SBC12    IF FILE NOT YET CORRECT LENGTH
 
*         PROCESS INPUT FILE TOO LONG.
 
 SBC13    SX5    -1
 
*         FLUSH OUTPUT BUFFER.
 
 SBC14    RECALL O
          RJ     COS         CHECK OUTPUT FILE STATUS
          NZ     X1,SBCX     IF ERROR OCCURRED
          SA1    O+FTIN      CHECK IN = OUT
          SA2    A1+B1
          IX1    X1-X2
          ZR     X1,SBC15    IF OUTPUT BUFFER EMPTY
          WRITECW  O,R       FLUSH OUTPUT BUFFER
          RJ     COS         CHECK OUTPUT FILE STATUS
          NZ     X1,SBCX     IF ERROR OCCURRED
 
*         PROCESS FILE LENGTH ERROR.
 
 SBC15    ZR     X5,SBCX     IF NO FILE LENGTH ERROR
          SA2    SBCC
          SX6    /ERRMSG/FLE *FILE LENGTH ERROR*
          NZ     X2,SBC16    IF ERROR DUE TO HARDWARE FAILURE
          SX6    X6+EIDF     SET ERROR IDLE FLAG
 SBC16    SA6    ERRF        SET ERROR FLAG
          BX1    X6
          EQ     SBCX        RETURN WITH (X1) = 0
 
 
 SBCA     VFD    60/0        CONTROL WORD EOF
          VFD    12/17B,48/0
 
 SBCB     CON    0           BLOCK COUNT
 SBCC     CON    0           LENGTH ERROR DUE TO HARDWARE FAILURE
          SPACE  4,10
*         COMMON DECKS.
 
 
*CALL     COMCCIO
*CALL     COMCCPM
*CALL     COMCPFM
*CALL     COMCSYS
*CALL     COMCWTW
          TITLE  BUFFERS.
*         BUFFERS.
 
          USE    LITERALS
 
 BUF      EQU    *           BUFFER FOR SINGLE BUFFER COPY
 BUFLWA   EQU    BUF+BUFL+4  END OF BUFFERS
 PRS      TITLE  PRESET.
**        PRESET.
*
*         ENTRY  PARAMETER BLOCK FROM *PFM* AT *SPPR*.
*
*         EXIT   INPUT AND OUTPUT FILE NAMES SET.
*                RANDOM BITS SET IN OUTPUT FET.
*                (APFL) = APPEND FILE LENGTH.
*                (LENG) = TOTAL FILE LENGTH TO COPY.
*                (SPPR) PRESET WITH ERROR REPLAY FOR *PFM*.
*                (LFNM) = LOCAL FILE NAME.
*
*         USES   X - ALL.
*                A - 1, 2, 6, 7.
*
*         MACROS ABORT, MESSAGE, REPRIEVE.
 
 
 PRS      SUBR               ENTRY/EXIT
          SA1    ACTR
          ZR     X1,PRS1     IF NOT COMMAND CALL
          MESSAGE  (=C*INCORRECT COMMAND.*),,R
          ABORT
 
 PRS1     REPRIEVE  ERRA,SET,277B  SET EXTENDED REPRIEVE
          SA1    SPPR        GET COMMAND CODE
          MX0    -18
          BX6    -X0*X1
          SA6    PFMC        SAVE COMMAND CODE
          SA1    A1+B1       GET LOCAL FILE NAME
          BX5    -X0*X1      SAVE INTERLOCK FLAG
          BX1    X0*X1
          SX6    3
          BX6    X1+X6
          BX1    X6
          SA6    LFNM
 
*         SET FILE NAMES IN FETS.
 
          SA2    PFNM        GET PERMANENT FILE NAME
          SA4    PFMC        CHECK COMMAND CODE
          SX3    X4-CCGT
          ZR     X3,PRS2     IF *GET*
          SX3    X4-CCOD
          ZR     X3,PRS2     IF *OLD*
          BX1    X2          SWITCH FILE NAMES
          BX2    X6
 PRS2     BX6    X2          SET FILE NAMES
          BX7    X1
          SA6    I
          SA7    O
          SA1    SPPR+2      GET FILE LENGTHS
          MX0    -24
          BX6    -X0*X1
          AX1    24
          BX7    -X0*X1
          SA6    LENG
          SA7    APFL
          SA1    PRSA        PRESET ERROR REPLY
          BX6    X1
          SA6    SPPR
          SA4    PFMC        CHECK COMMAND CODE
          SX2    X4-CCGT
          ZR     X2,PRSX     IF *GET*
          SX2    X4-CCOD
          ZR     X2,PRSX     IF *OLD*
          SX1    EIDF        SET ERROR IDLE FLAG IN ERROR REPLY
          LX1    24
          BX6    X1+X6
          SA6    A6
 
*         SET RANDOM REWRITE BITS.
 
          R=     X6,FGIA
          BX5    X6*X5
          NZ     X5,PRSX     IF SEQUENTIAL WRITE (AT END OF CHAIN)
          SX6    B1          SET RANDOM ACCESS BIT
          LX6    47-0
          SA1    O+1
          BX6    X6+X1
          SA6    A1
          SX6    B1          SET RANDOM REWRITE REQUEST
          LX6    29-0
          SA1    O+6
          BX6    X1+X6
          SA2    SPPR+3      GET RANDOM ADDRESS
          BX6    X2+X6
          SA6    A1
          EQ     PRSX        RETURN
 
 
 PRSA     VFD    24/0,3/1,1/0,8//ERRMSG/ABT,24/0  ERROR REPLY
          SPACE  4,10
          ERRNG  MFL=-*      OVERFLOW PAST END OF BUFFERS
          SPACE  4,10
          IDENT
 
 
 .1       SET    BUFLWA+77B  CALCULATE FIELD LENGTH
 
*         SET IGNORE RESOURCE LIMITS FOR PROGRAM EXECUTION.
*         FORCE *OVERRIDE REQUIRED* BIT TO BE SET.
*         PREVENT *DMP=* ON COMMAND CALL.
*         DO NOT RELEASE EXTRA FIELD LENGTH ON LOAD.
 
 DMP=     EQU    .1/100B+320000B
 MFL=     EQU    .1/100B*100B
          SPACE  4
          END