*DECK CLSFDRM 
          IDENT     CLSF$RM 
          COMMENT   CRM CLOSE ROUTINE 
          TITLE     CLOSE (ALL FO-S)
          TITLE     CLSF$SQ 
          SST 
          B1=1
 CLSF$SQ  TITLE     CLSF$SQ 
*#
*1CD      CLSF$RM 
*0D   PURPOSE 
*0        CLOSE A FILE. 
*0D   CALL
*0                  SB6       RETURN-ADDRESS
*                   EQ        =XCLSF$RM 
*0D   PARAMETERS
*0        A0        FIT ADDRESS.
*         B1        1.
*0D   ACTION
*0        FLUSH THE BUFFER IF THE LAST OPERATION WAS AN OUTPUT TYPE.
*         PERFORM ANY REQUIRED LABEL PROCESSING, ISSUE THE
*         APPROPRIATE CIO CLOSE DEPENDING ON CF, PERFORM ANY
*         REQUIRED LABEL PROCESSING, UNLOAD ANY CAPSULES WHOSE
*         USAGE COUNT GOES TO ZERO, GO TO OE$CRM TO OUTPUT ANY
*         ACCUMULATED ERRORS (RM ERROR NNN MMM MORE TIMES...),
*         AND RETURN TO THE USER. 
*0D   REGISTERS USED
*0        ALL EXCEPT A0,B1,B6 
*0D   OTHER CODE REQUIRED 
*0        CMM.FRF - TO FREE BUFFER
*         LOF$RM - ENTRY MAY BE DELETED FROM LIST OF FILES
*         ERR$RM
*         OE$CRM - ISSUE ANY ACCUMULATED REPEATED ERRORS
*         LBUF$SQ - FOR TRAILER LABELS
*         RM$TMP, RM$UTC - TO UNLOAD CAPSULES 
*          FLSH$SQ, FLSH$WA, FLSH$S - TO FLUSH OUTPUT FILES 
*0D   NARRATIVE DESCRIPTION 
*#
 CLSF$RM  CAP.RM    INTERMEDIATE
          ENTRY     CLSF$SQ,CLSF$WA 
 CLSF$SQ  EQU       CLSF$RM 
 CLSF$WA  EQU       CLSF$RM 
*#
*0        SAVE B6: THE USERS RETURN ADDRESS.
*#
          SAVE                     SAVE USERS RETURN ADDRESS
*#
*0        IF THE FILE HAS ALREADY BEEN CLOSED, BRANCH TO CSF.DUP
*         TO PROCESS THE REDUNDANT REQUEST. 
*#
          NE.RM     OC,#OPE#,CSF.DUP,B2   IF NOT OPEN, REDUNDANT CLOSE
*#
*0        IF THIS IS AN AAM FILE - GO TO AAM$GO 
*         IF THIS IS FO=WA FILE - 
*                   LOP=PUT        GO TO FLSH$WA
*                   ELSE           GO ISSUE CIO REQUEST 
*         IF PD IS  INPUT          GO CHECK LABEL PARAMETERS
*         IF WSI/RSI IS YES        GO CHECK LABEL PARAMETERS
*         IF WPN IS OFF            GO CHECK LABEL PARAMETERS
*         IF CNF IS  YES           ISSUE WRITE ON ZZZZZOU FILE
*         IF LAST OP IS PUT        GO TO FLSH$SQ
*#
          F.RM      LOP,B3,-#PU#   (USED TWICE) 
          SB4       #CLS# 
          F.RM      FO,B2 
          SB6       UNLAAM
          AAM.FO    =YAAM$GO,B2 
          ERRNZ     #SQ#  NEXT INST EXPECTS SQ=0
          ZR        B2,SQFLSH      IF NOT WA
  
* WA FLUSH
          NZ        B3,WAF1        FLUSH ONLY AFTER PUT 
          F.RM      CPRU
          ZR        X1,WAF1 
          F.RM      IN,B2          INPUT TO FLSH$WA 
          BX0       0              INPUT
          SB6       WAF1           RETURN ADDR
          EQ        =YFLSH$WA 
 WAF1     RCL.RM    A0,AUTO        WAIT FOR IO TO COMPLETE
          SET.RM    FP,#BOI#
          F.RM      IN,X7 
          SET.RM    OUT,X7         PREVENT BUFFER FLUSHING
          SB6       CSF.EOL2
          EQ        CSF.CIO 
  
* CONNECTED OUTPUT
ZAPZOU    DATA      0 
          OFF.RM    CNF,ZAPZOU     NOT A CONNECTED FILE 
          SA1       =XLOF$RM
          SA3       X1+B1          FIRST LOF ENTRY
          MX7       12
          BX7       X3+X7 
          SA7       A3             1ST LOF ENTRY MASKED-OUT 
          EQ        ZAPZOU
  
* SQ FLUSH
 SQFLSH   BSS 
          ON.RM     CNF,CSF.CNF 
          F.RM      PD,B4 
          LE        B4,B1,CSF.LABL  PD=INPUT
          ON.RM     WSI,CSF.RET1   NO NEED TO FLUSH SBF FILES 
          ON.RM     WPN,CSF.FLSH
          EQ        CSF.LABL
CSF.CNF   BSS       0 
          F.RM   ZOU,X2 
          SA1    =XLOF$RM 
          SA1    X1+B1
          MX7    42D
          BX1    -X7*X1 
          IX7       X1-X2          ZERO IF ZOU
          ZR        X7,DOFLSH 
*         CHECK IF BUFFER USED FOR CONNECTED FILE OUTPUT BELONGS TO 
*         THE FILE BEING CLOSED 
*                                  FLUSH BUFFER 
*                                  SET BUFFER ALLOCATION FLAG 
          SX1       =YUSBF$RM 
          NG        X1,RESA0
          SA1       X1
          AX1       18
          SX2       A0
          IX1       X1-X2 
          NZ        X1,RESA0       NOT USED FOR OUTPUT
DOFLSH    BSS       0 
          SB4       A0
          SA0       =YPFET$RM 
          RCL.RM    A0,AUTO 
          F.RM      IN,2
          F.RM      OUT,3 
          IX7       X2-X3 
          ZR        X7,EMPTY       NOTHING TO FLUSH 
          SYSY      24B,R 
EMPTY     SA0       B4
          MX7       59
          SA7       =YUSBF$RM      SET BUFFER ALLOCATION FLAG 
          SA0       B4
 RESA0    BSS       0 
          SA1       A0             SET COMPLETE BIT IN CASE RECOVR
          SX2       B1             CALLED WHILE READ IN PROGRESS
          BX7       X1+X2 
          SA7       A0
          SB6       UNLOAD
          EQ        CSF.CIO        ISSUE CLOSE, DEL LOF, RETURN CSF.EOL2
  
CSF.FLSH  BSS       0 
          NZ        B3,CSF.LABL    IF LOP"PUT 
          SET.RM    LVL,0 
          SET.RM    WEOX,0
          SB6       CSF.RET1       FLSH$SQ RETURN ADDRESS 
          F.RM      RT,X1,-#ST# 
          NZ        X1,=YFLSH$SQ
          EQ        =YFLSH$S
  
 CSF.RET1 BSS       0 
          SET.RM    FP,#EOP#
          TITLE     CLSF - LABELS 
 CSF.LABL BSS       0 
*#
*0        LABEL CHECKING IS EXECUTED TWICE
*                   FIRST - BEFORE CIO CLOSE
*                     LT=S INPUT -LABELS CAN BE PUTL FOR CHECKING BY CIO
*                     LT=S OUTPUT -LABELS CAN BE PUTL FOR WRITING 
*                     LT=NS INPUT -LABELS CAN BE GETL FROM DEVICE 
*                     LT=NS OUTPUT-LABELS CAN BE PUTL TO DEVICE 
*                   SECOND - AFTER CIO CLOSE
*                     LT=S INPUT  -LABELS CAN BE GETL FOR CHECKING
*                     LT=S OUTPUT -LABELS CAN BE GETL FOR CHECKING
*                                    DEFAULTS 
*                     LT=NS       -LX NOT TAKEN 
*0        CHECK FOR VALID PARAMETERS BEFORE BRANCHING TO THE USERS
*         LABEL EXIT (LX).
*         DO NOT BRANCH IF (1) LT=UL OR ANY 
*                          (2) ULP=NO 
*                          (3) LX=0 
*                          (4) FP"EOP,EOI ON I/P TYPE FILE
*         FOR STANDARD LABELS (LT=S), FET FIELD LAL CONTAINS THE
*         LABEL AREA AND ITS LENGTH. STANDARD LABELS ARE ALWAYS READ
*         TO AND WRITTEN FROM LAL.  NON-STANDARD LABELS (LT=NS) ARE 
*         READ TO AND WRITTEN FROM THE USERS LABEL AREA (LA) DIRECTLY.
*         FOR STANDARD LABELS THEREFORE, CLEAR LAL IF LX BRANCH IS
*         NOT TAKEN AND SET LAL IF LX IS TAKEN.  SET USER LABEL RETURN
*         (ULR) TO 1 SO RETURN FROM LX IS THROUGH ULX.
*         SET ULX TO THE RETURN ADDRESS.  BRANCH TO LX. 
*#
          SET.RM    ULX,CSF.EOL1   FIRST TRIP RETURN ADDRESS
 CSF.LAB0 BSS       0 
          EQ.RM     ULP,#NO#,CSF.EOL1  NO USER PROCESSING 
          LT        B1,B4,CSF.LAB1      NOT INPUT 
          F.RM      FP,4,X2,-#EOP#
          ZR        X2,CSF.LAB1         EOP 
          SX2       X2+#EOP#-#EOI#
          NZ        X2,CSF.EOL1         NOT EOI 
 CSF.LAB1 BSS       0 
          F.RM      LT,4,X2,-#UL# 
          ZR        X2,CSF.EOL1 
          SX2       X2+#UL#-#ANY# 
          ZR        X2,CSF.EOL1 
          SX2       X2+#ANY#-#S#
          NZ        X2,CSF.ULR1    JP NOT #S# LABELS
          SB5       =XLBUF$RM 
          PL        B5,CSF.CKLX    LABEL BUFFER LOADED
          LOAD.BAM  LBUF           LOAD LABEL BUFFER
          SA6       TMP.LBUF
          BX7       0 
          SA7       =XRM$TMP
 CSF.CKLX BSS       0 
          SET.RM    JNK,0 
          SX4       9*#LBLIM#      8-WD LABEL + CONTROL WORD
          SX6       B5             ADDRESS OF LABEL AREA
          LX4       18
          BX6       X4+X6 
          SET.RM    LAL,X6         36-BIT FIELD 
 CSF.ULR1 BSS       0 
          F.RM      LX,B3 
          ZR        B3,CSF.EOL1    NO EXIT ADDRESS
          SET.RM    ULR,1 
          JP        B3
  
 LBUF     FAKEPL    =YLBUF$RM 
 TMP.LBUF CON       0 
  
 CSF.EOL1 BSS       0 
          F.RM      OC,X1,-#OPE#
          NZ        X1,CSF.EOL2    IF FILE CLOSED 
*#
*0        IF SBF FILE, SET CIRCULAR BUFFER POINTERS TO FIT TO AVOID 
*         BUFFER ARGUMENT ERRORS FROM THE CIO CLOSE CAUSED BY THE 
*         USER RELEASING HIS BUFFER SPACE BEFORE CLOSING HIS FILE.
*#
          OFF.RM    WSI,CSF.CLO 
          RCL.RM    A0,AUTO 
          SX6       A0+#FTL#
          SX5       A0+#FTL#+2
          SET.RM    FIRST,X6
          SET.RM    IN,X6 
          SET.RM    OUT,X6
          SET.RM    LIMIT,X5
 CSF.CLO  BSS       0 
*#
*0        CALL CSF.CIO TO ISSUE THE CIO REQUEST.
*#
          SB4       B0             CSF.CIO NORMAL CLOSE FLAG
          SB6       CSF.LAB2       RETURN ADDRESS 
          EQ        CSF.CIO 
 CSF.LAB2 BSS       0 
*#
*0        IF FILE IS INPUT TYPE AND LABEL TYPE IS STANDARD, USER
*         CAN PROCESS TRAILER LABELS RETURNED AFTER THE CIO CLOSE 
*         HAS BEEN ISSUED. BRANCH TO CSF.LABL TO SEE IF THE 
*         REQUIRED PARAMETERS ARE VALID FOR A BRANCH TO LX. 
*#
          F.RM      PD,X2,-#OUTPUT# 
          ZR        X2,CSF.EOL2 
          NG        X2,CSF.IP      DEFINITE INPUT 
          NE.RM     LCR,#ELCR#,CSF.EOL2,B2   I-O, CHECK LCR 
 CSF.IP   BSS       0 
          SB4       X2+#OUTPUT#    SET UP PD
          F.RM      LT,X2,-#S#
          SET.RM    ULX,CSF.EOL2   RETURN ADDRESS 
          ZR        X2,CSF.LAB0 
 CSF.EOL2 BSS       0 
          SET.RM    LAL,0          UN-POINT TO LABEL BUFFER 
          SET.RM    ULX,0 
          SET.RM    ULR,0 
          RJ        =XRM$UTC
          SA1       TMP.LBUF       RESTORE PREVIOUS TMP CONTENTS
          BX7       0 
          LX6       X1
          SA7       A1
          SA6       =XRM$TMP
          TITLE     CLSF - UNLOAD 
 UNLOAD   BSS 
*#
*0        UNLOAD GET/PUT CAPSULES IF DYNAMICALLY LOADED AND USAGE 
*         COUNT GOES TO ZERO. 
*#
          SB2       =0LBAM         FOR /UNL/
          RJ        =XRM$UTC
* CALL /UNLGET/ 
*CALL /UNLGET/
* CALL /UNLPUT/ 
*CALL /UNLPUT/
*#
*0        BEFORE EXITING, SET THE LAST OP TO CLOSEM,
*         CALL RSPT$SQ TO RESET SELECTED FIT/FET POINTERS, AND
*         RESTORE THE USERS RETURN ADDRESS TO B5.  CALL OE$CRM TO 
*         DISPLAY ANY ERRORS ACCUMULATED BY ERR$RM AND RETURN TO USER 
*         FROM OE$CRM.
*#
          SET.RM    LOP,#CM#       SET LOP=CLOSEM, WPN=0
          SET.RM    LCR,#ELCR#     SET LCR=EXITING LABEL
          SB6       CSF.RET2
          EQ.RM     FO,#SQ#,=XRSPT$SQ,B2
  
* WA
          SX6       =YCOMM$WA 
          RJ        UNL            UNLOAD COMM$WA 
          EQ        CSF.RET2
  
 RT.AAM   VFD       42/0,18/=YPUT$R 
          VFD       42/0,18/=YPUT$Z 
          VFD       42/0,18/=YPUT$D 
          VFD       42/0,18/=YPUT$T 
* AAM  RETURNS HERE - - - - - - - 
 UNLAAM   RJ        =XRM$UTC       UNLOAD ANY TRANSIENTS LYING AROUND 
          SB4       B0
          SB6       AAM1
          EQ        CSF.CIO 
 AAM1     F.RM      RTJP,X6 
          ZR        X6,ENDRTA 
          ECHO      2,P1=(#RT#,#ZT#,#DT#,#TT#),P2=(2,3,4,5) 
          IFNE      P1,P2,1 
          ERR       RECORD TYPE VALUES CHANGED - CODE INVALID 
          F.RM      RT,B2,-#RT#,6  PICK UP RT OFFSET
          SA1       RT.AAM+B2      PICK UP TRUE ENTRY POINT 
          BX6       X1       USE FOR UNLOADING
          SB2       =0LBAM
          RJ        UNL            UNLOAD PUT$RT IF NEEDED
          SET.RM    RTJP,0
          SB2       =0LBAM
          SX6       =YLDRT$AA 
          RJ        UNL            UNLOAD LDRT$AA IF LAST USE.
 ENDRTA   BSS 
          SX6       =YAAM.CTL 
          OFF.RM    ORG,UNLCTL
          SX6       =YAAM$CTL 
 UNLCTL   BSS       0 
          SB2       X6-1           GROUP NAME = CAPSULE NAME
          RJ        UNL 
          SX7       B4
          SA7       AAMCTL         SAVE CAPSULE USAGE COUNT 
          TITLE     CLSF - COMMON EXIT
 CSF.RET2 BSS       0 
          SB5       CKALLCL 
          SB2       =YOE$CRM
          PL        B2,=YOE$CRM    HANDLE ANY ERROR ACCUMULATION
 CKALLCL  BSS       0 
M.        IFC       EQ,/"OS.NAME"/KRONOS/ 
          AAM.FO    NOTMFN
          F.RM      MFN 
          ZR        X1,NOTMFN 
          F.RM      LFN,3 
          MX7       60-42+6 
          BX7       X7*X3          LFN 1ST CHAR 
          BX1       X1+X7          RESET LFN ON 7 CHAR
          SET.RM    LFN,X1,,2 
          AX3       6              RESET MFN ON 6 CHAR
          SET.RM    MFN,X3
NOTMFN    BSS       0 
M.        ENDIF 
          SA2       =YOFCT$RM 
          MX1       -1
          IX6       X2+X1          DECREMENT OPEN FILES COUNT 
          SA6       A2
          NZ        X6,ULCL        IF ANY OTHER FILES OPEN
          ON.RM     EES,ULCL       IF AAM ERROR, LET CRMEP CALL FLEF$RM 
          SB3       ULCL
          SB2       =YFLEF$RM 
          PL        B2,FLEF$RM     FLUSH THE ERROR FILE 
 ULCL     BSS       0 
          SA1       CAPSTAT 
          BX6       X1
          SA6       =XRM$TMP
          F.RM      EES,2 
          CRMEP     IFOP=(MI X2)   TAKE ERROR EXIT IF AAM ERROR 
          RESTORE 
          SA1       =XOFCT$RM 
          SB3       B6             RETURN TO USER 
          SB2       B1+B1          TO UNLOAD CLSF 
          ZR        X1,=XRM$ULJ 
          SA1       AAMCTL
          ZR        X1,=XRM$ULJ 
          JP        B6             RETURN TO USER 
 AAMCTL   DATA      77777777777777777776B   AAM($/.)CTL USAGE COUNT 
          SPACE     1 
 CSF.DUP  BSS       0 
*#
*0        FOR REDUNDANT CLOSE REQUESTS, ISSUE THE APPROPRIATE CIO 
*         FUNCTION THEN BRANCH TO ERR$RM TO ISSUE AN ERROR FOR THE
*         REDUNDANT REQUEST.
*#
          SB4       B1             CSF.CIO REDUNDANT CLOSE FLAG 
          SET.RM    CMPLT,1 
          SB6       CSF.ER60       RETURN ADDRESS 
          EQ        CSF.CIO 
 CSF.ER60 BSS       0 
          SA1       CAPSTAT 
          BX7       X1
          SA7       =XRM$TMP       SO CLSF WILL GET UNLOADED
          SX6       060B           REDUNDANT CLOSE
          EQ        =XERR$RM
          TITLE     CLSF - ISSUE CIO, PLAY WITH LOF 
 CSF.CIO  BSS       0 
*#
*0        ISSUE CIO CODE 130B, 150B, 170B, 174B DEPENDING ON CF.
*         IF B4=0, THIS IS A NORMAL CLOSE. IF B4=1, THIS IS A 
*         REDUNDANT CLOSE. FOR REDUNDANT CLOSE, IF THE FUNCTION CODE
*         IS ZERO, DO NOT ISSUE A CIO REQUEST (A NORMAL CLOSE 
*         FOLLOWED BY CLOSE,NR  OR  CLOSE,DET  OR  CLOSE,DIS  DOES
*         NOT ALTER THE FILE POSITION. A NORMAL CLOSE,NR COULD
*         BE FOLLOWED BY A  CLOSE,R  OR  CLOSE,U  OR  CLOSE,RET 
*         AND AN ADDITIONAL CIO REQUEST IS IN ORDER). 
*         SET OC TO CLOSED. 
*         THE BITS IN THE WORD  FILELST  INDICATE FOR EACH CF 
*         WHETHER OR NOT TO REMOVE THE LFN FROM THE LIST OF FILES 
*         AND RELEASE BUFFER SPACE (1=YES AND 0=NO).
*#
          SET.RM    OC,#CLO#
          F.RM      CF,X3 
          SA4       CLODES
          SB3       X3-#DIS#
          SB2       X3-#N#
          PL        B2,NORW 
          SET.RM    FP,#BOI#       CLOSE/R, SET FP TO BOI 
NORW      BSS       0 
          LX3       3              *8 
          SB2       X3
          MX2       -7
          AX4       B2             CHOSE CIO CODE ACCORDING TO CF 
          BX3       -X2*X4         CODE (KEEP FOR A WHILE)
          LX4       -8             LOF FLAG (KEEP)
*#
*0        SCAN LIST OF FILES TO SEE IF ANY OTHER FIT IS OPEN AND HAS
*         THE SAME NAME.  IF SUCH A FIT IS FOUND, DO NOT ISSUE THE
*         CIO CALL. 
*#
          SA1       =XLOF$RM
          MX6       42
          SA5       A0
          SA2       X1             INITIALIZE A2
  
 OPNLOOP  SA2       A2+B1          GET NEXT LOF ENTRY 
          ZR        X2,OPNEND      IF END OF LOF
          BX1       X5-X2 
          BX7       X6*X1 
          NZ        X7,OPNLOOP     IF DIFFERENT LFN 
          SA0       X2
          F.RM      FTS,X1,-#MNF# 
          NG        X1,OPNLOOP     IGNORE INTERNAL FET
          NE.RM     OC,#OPE#,OPNLOOP,B2 
  
          SA0       A5             RESTORE A0 
          EQ        CSF.CKX4       JUMP AROUND CIO CALL 
 OPNEND   BSS 
          SA0       A5
          NZ        B3,CSF.FC      IF NOT DISCONNECT TYPE CLOSE 
          OFF.RM    CNF,CSF.FC     CONNECT IN BATCH DOESNT CONNECT
          F.RM      LFN,X7
          LX7       18
          SA7       CONWRD
 DTCHK    IFC       NE,/"OS.NAME"/KRONOS/ 
          SYSTEM    CON,RCL,CONWRD,100B 
 DTCHK    ELSE
          SB3       A0             SAVE FIT ADDRESS 
          SX2       B1
          BX7       X7+X2 
          SA7       CONWRD         SET THE COMPLETE BIT 
          SA0       CONWRD
          SYSY      70B,R          RETURN THE FILE
          SA0       B3             RESTORE FIT ADDRESS
          SET.RM    DVT,1523B 
          SYSTEM    LFM,RECALL,A0,15B*100B     ASSIGN TO MS 
 DTCHK    ENDIF 
 CSF.FC   BSS       0 
          EQ        B4,B0,CSF.SYSY
          ZR        X3,CSF.CKX4 
 CSF.SYSY BSS       0 
          SX3       X3+130B 
          SET.RM    SRB,0 
*         SET FIRST,IN,OUT,LIMIT (MAINLY FOR AAM) 
          RCL.RM    A0,AUTO 
          F.RM      FIRST,X2
          NZ        X2,FWBOK
          SX2       A0+#FTL#       DEFAULT
          SET.RM    FIRST,X2
 FWBOK    SET.RM    IN,X2 
          SET.RM    OUT,X2
          SX2       X2+2
          SET.RM    LIMIT,X2
          SYSY      X3,R
 CSF.CKX4 BSS       0 
          PL        X4,CSF.CIOX 
* CALL /CLSFLOF/
*CALL /CLSFLOF/ 
  
          OFF.RM    BAL,CSF.CMMR   JUMP IF BUFFER NOT ALLOCATED BY CRM
          F.RM      FIRST,1 
          SB2       B6             SAVE B6 AROUND CMM CALL
          RJU       =XCMM.FRF      FREE CRM-ALLOCATED BUFFER
          SB6       B2             RESTORE B6 
          SX6       A0+#FTL#       SET FIRST TO INDICATE NO BUFFER
          SET.RM    FIRST,X6
          SET.RM    BAL,0 
 CSF.CMMR BSS       0 
          SET.RM    OC,0           SO BUFR CAN BE ALLOCATED IF REOPENED 
 CSF.CIOX BSS       0 
          JP        B6
  
 CLODES   VFD       4/
          ECHO      1,LOF=(1,1,1,1,0,0,0),CODE=(130,130,174,170,130,150,
,150) 
          VFD       1/LOF,7/CODE_B-130B 
 CONWRD   BSSZ      1 
* CALL /UNL/
*CALL /UNL/ 
* CALL /RSPTDSQ/
*CALL /RSPTDSQ/ 
          SET.RM    BN,0,7,1
          JP        B6
          END 
