ASMB,R,L,C
*     NAME:   CLOSE 
*     SOURCE: 92070-18039 
*     RELOC:  92070-16039 
*     PGMR:   G.A.A.
*     MOD:    M.L.K.
* 
*  ***************************************************************
*  * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979.  ALL RIGHTS     *
*  * RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED,      *
*  * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT*
*  * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.       *
*  ***************************************************************
* 
* 
      NAM CLOSE,7  92070-1X039  REV.1941  790709
* 
      HED CLOSE 
      ENT CLOSE,ECLOS 
      EXT .ENTR,R/W$,CLD.R,.P1,.P2,.P3,.P4,.R1
      EXT GTOPN,$DBLX,LURQ
      SUP 
* 
*  THIS IS THE CLOSE SUBROUTINE--A PART OF THE
*  REAL-TIME FILE MANAGEMENT PACKAGE
* 
*  THE ASSEMBLY CALL TO CLOSE A FILE IS:
* 
*     JSB CLOSE 
*     DEF RTN       RETURN ADDRESS
*     DEF IDCB      DATA CONTROL BLOCK ADDRESS
*     DEF IERR      (OPTIONAL) ERROR CODE RETURNED HERE AND IN A REG
*     DEF IRX       (OPTIONAL) NO. OF 128 WORD DOUBLE 
*RTN                SECTORS TO BE DELETED FROM THE FILE 
* 
*     ERRORS ARE: 
*     0       NONE
*    -1       DISC DOWN 
*    -10      NOT ENOUGH PARAMETERS 
*    -11      FILE NOT OPEN 
*    -13      DISC LOCKED 
* 
* 
* 
      SKP 
ECLOS NOP           DOUBLE WORD ENTRY 
      CCA           SET DBL FLAG
      LDB ECLOS     SET UP RETURN ADDRESS 
      JMP SETUP     FINISH SET UP 
      SPC 5 
CLOSE NOP 
      CLA           SET DBL FLAG FALSE
      LDB CLOSE     GET RETURN ADDRESS
SETUP STA DBLWD     SAVE DBL FLAG 
      STB DLOSE     SAVE RETURN ADDRESS 
      LDA DZERO 
      STA IDCB
      STA IRX 
      LDA DM
      STA IERR
      CLA 
      STA ZERO
      STA .P1       FUNCTION CODE FOR CLOSE 
      JMP DLOSE+1 
* 
* 
* 
IDCB  DEF ZERO      DCB ADDRESS 
IERR  DEF IDCB      ERROR CODE ADDRESS
IRX   DEF ZERO      TRUNICATE CODE ADDRESS
      SPC 1 
DLOSE NOP           ENTRY POINT 
      JSB .ENTR     TRANSFER THE ADDRESSES
DM    DEF IDCB
      ISZ DBLWD     TEST DBL FLAG 
      JMP SINGL     SINGLE ENTRY, SKIP TESTS
      DLD IRX,I     GET DOUBLE TRUNC CODE 
      JSB $DBLX     CHECK RANGE 
      JMP EXIT      ERROR (A = ERROR CODE)
      ISZ IRX       POINT TO LOW BITS 
* 
SINGL LDA IDCB      IF NO PARAMETERS
      CPA DZERO     THEN
      JMP ER10      ERROR EXIT
      INA           STEP TO WORD TWO
      LDB A,I       FETCH OFFSET SECTOR 
      STB .P3       SAVE FOR D.RTR CALL 
      ADA .8        ADD 8 TO GET THE THE OPEN FLAG
      STA OPNFL     SAVE THE OPEN FLAG ADDRESS
      ADA N2        BACK UP TO THE
      STA SC        SAVE THE SECURITY CODE ADDRESS
      JSB GTOPN     GET CURRENT OPEN FLAG 
      DEF *+1 
      CPA OPNFL,I   COMPARE TO FILE'S, OK?
      CLE,RSS       YES, SKIP 
      JMP ER11      NO, ERROR EXIT
* 
      LDB IDCB      GET THE DCB ADDRESS 
* 
      LDA B,I       IF DUMMY LU OPEN
      CPA FAKE          DON'T CALL D.RTR
      JMP DUMMY                JUST CLOSE DCB AND GET OUT 
* 
      JSB R/W$      CALL TO FLUSH THE BUFFER
      JMP EXIT      DISC ERROR EXIT 
      LDB IDCB      GET THE TYPE FLAG 
      ADB .2
      LDA B,I       A 
      SZA           IF ZERO NO TRUNCATE 
      LDA IRX,I     DISC FILE SET TRUNCATE CODE 
      ALS           ADJUST FOR 64 WORD SECTORS
      ADB .13       STEP TO EXTENT WORD 
      LDB B,I       IF NOT
      SZB           FIRST EXTENT
      CLA           DO NOT ALLOW TRUNCATION 
      LDB SC,I      GET THE SECURITY FLAG 
      SSB,RSS       IF BAD SC 
      CLA           DIS ALLOW TRUNCATION
      CMA,INA       SET NEGATIVE
      STA .P4       SAVE FOR D.RTR
* 
      LDA IDCB,I    SET DIRECTORY ADDRESS FOR D.RTR 
      STA .P2 
      JSB CLD.R      SCHED D.RTR
      LDB .R1       GET ERROR RETURN
      RSS           SKIP DUMMY LU EXIT WORK 
* 
DUMMY CLB 
      STB IRX       SAVE ERROR CODE 
* 
      CLA 
      STA OPNFL,I   CLEAR THE OPEN FLAG 
* 
*     UNLOCK TYPE 0 LU'S
* 
      LDB IDCB      GET DCB ADDRESS 
      ADB .2        POINT TO FILE TYPE
      LDA B,I       GET TYPE
      SZA           IF NOT TYPE 0 
      JMP EXI         THEN DONE, EXIT 
* 
      INB           POINT TO LU 
      LDA B,I       GET LU
      AND B77       ISOLATE LU
      STA LU        AND SAVE
      ADB .12       POINT TO LOCK/UNLOCK FLAG (DCB 15)
      LDA B,I       AND GET FLAG
      SZA           SHOULD WE UNLOCK? 
      JMP EXI       NO, EXIT
      JSB LURQ      CALL TO UNLOCK
      DEF *+4 
      DEF B40K      UNLOCK NO ABORT 
      DEF LU
      DEF .1
      NOP           ERROR RETURN (IGNORE) 
* 
EXI   LDA IRX       RESTORE ERROR CODE
* 
EXIT  STA IERR,I    SET THE ERROR CODE
      JMP DLOSE,I   EXIT ERROR CODE IN A
      SPC 3 
ER10  CLA,RSS       NOT ENOUGH PRAMS - ERROR 10 
ER11  CCA           FILE NOT OPEN - ERROR 11
      ADA N10 
      JMP EXIT      GO EXIT 
      SPC 3 
FAKE  OCT 177700
B40K  OCT 40000 
B77   OCT 77
N10   DEC -10 
N2    DEC -2
.1    DEC 1 
.2    OCT 2 
.8    DEC 8 
.12   DEC 12
.13   DEC 13
SC    NOP 
OPNFL NOP 
ZERO  NOP           \ THESE TWO ARE DUMMY PARAMETERS
      NOP           / TWO NECESSARY FOR DOUBLE WORD 
DZERO DEF ZERO
DBLWD NOP           DOUBLE WORD FLAG
LU    NOP 
      SPC 2 
A     EQU 0 
B     EQU 1 
      SPC 1 
END   EQU * 
      SPC 1 
      END 
                                                                                                                                                        