ASMB,R,L,C
      HED CLOSE 
*     NAME:   CLOSE 
*     SOURCE: 92067-18137 
*     RELOC:  92067-16125 
*     PGMR:   G.A.A. N.J.S. 
* 
*  ***************************************************************
*  * (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 92067-16125 REV.2001 791019 
      ENT CLOSE, ECLOS
      EXT EXEC, .ENTR, R/W$, RMPAR, .DNG, 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   OR   JSB ECLOS
*     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 SECTORS TO BE 
*RTN                DELETED FROM THE FILE.  FOR CLOSE IRX IS A SINGLE 
*                   WORD INTEGER.  FOR ECLOS IRX IS A DOUBLE WORD INTEGER.
* 
*     ERRORS ARE: 
*     0       NONE
*    -1       DISC DOWN 
*    -10      NOT ENOUGH PARAMETERS 
*    -11      FILE NOT OPEN 
*    -13      DISC LOCKED 
*    -19      ILLEGAL ACCESS TO A SYSTEM DISC 
* 
* 
* 
      SKP 
ECLOS DEC -1        EXTENDED FILE CLOSE ROUTINE ENTRY POINT 
      LDA ECLOS     TRANSFER RETURN ADDRESS 
      STA CLOSE      TO CLOSE ENTRY POINT 
      JMP CLOSE+1    AND JUMP TO CLOSE ROUTINE
* 
* 
IDCB  DEF ZERO      DCB ADDRESS 
IERR  DEF IDCB      ERROR CODE ADDRESS
IRX   DEF ZERO      TRUNICATE CODE ADDRESS
* 
CLOSE NOP           ENTRY POINT 
      JSB .ENTR     TRANSFER THE ADDRESSES
DM    DEF IDCB       OF THE INCOMING PARAMETERS 
      LDA ECLOS     GET CLOSE\ECLOS FLAG
      SSA           DOUBLE WORD CALL? 
      JMP CLOS0     NO - SKIP 
* 
      DLD IRX,I     GET DOUBLE WORD TRUNCATE CODE 
      JMP CLOS1      AND GO SAVE IT 
* 
CLOS0 CLA           GET SINGLE WORD TRUNCATE CODE 
      LDB IRX,I      AND MAKE IT A DOUBLE WORD
      SSB             TAKING INTO ACCOUNT THAT IT 
      CCA              MAY BE POSITIVE OR NEGATIVE
CLOS1 DST TRUNC     SAVE DOUBLE WORD # SECTORS TO BE TRUNCATED
      LDA IDCB      IF NO PARAMETERS
      CPA DEF.0      THEN 
      JMP ER10        ERROR EXIT
* 
      INA           STEP TO WORD TWO
      STA DCB2      SAVE FOR D.RTR CALL 
      ADA .8        ADD 8 TO GET THE THE OPEN FLAG
      STA OPNFL     SAVE THE OPEN FLAG ADDRESS
      LDB A,I       GET THE OPEN FLAG 
      ADA N2        BACK UP TO THE SECURITY CODE
      STA SC         AND SAVE SECURITY CODE ADDRESS 
      CPB XEQT      FILE OPEN?
      CLE,RSS       YES SKIP
      JMP ER11      NO; ERROR EXIT
      LDB IDCB      GET THE DCB ADDRESS 
      JSB R/W$      CALL TO FLUSH THE BUFFER
      JMP EXIT      DISC ERROR EXIT 
* 
      LDA IDCB,I    GET LU 1ST WORD OF DCB
      CPA OPFLG      WAS THIS DCB SET UP BY OPENF 
      JMP CLOS3     YES - SKIP D.RTR CALL 
* 
      LDB DCB2      GET THE TYPE FLAG 
      CLE,INB        TO THE A-
      LDA B,I         REGISTER. 
      SZA,RSS       IF ZERO NO TRUNCATE 
      CCE            SO SET E = 1 FOR FLAG
      ADB .13       STEP TO EXTENT WORD 
      LDB B,I       IF NOT THE
      SZB            FIRST EXTENT 
      CCE             DO NOT ALLOW TRUNCATION.  SET E = 1 
      LDB SC,I      GET THE SECURITY FLAG 
      LDA ATRUN     IF TRUNCATE IS VALID (E # 1)
      SSB            AND SC MATCHES, GET DOUBLE WORD TRUNCATE 
      SEZ             PARAMETER PASSED IN CALL. 
      LDA DEF.0     ELSE WANT 0 FOR TRUNCATE CODE 
      DLD A,I        SO LOAD DOUBLE WORD ZERO.
      SWP 
      ASL 1         MULTIPLY BY 2 TO ADJUST TO SECTORS
      SWP 
      JSB .DNG      MAKE NEGATIVE 
      DST TRUNC     AND SAVE AS TRUNCATE CODE 
* 
SCHED JSB EXEC      CALL EXEC 
      DEF SCHRT     TO
      DEF .23       SCHEDULE QUEUE WITH WAIT
      DEF D.RTR     D.RTR 
      DEF XEQT      WITH THE EXECUTING PROGRAM'S ID 
      DEF ZERO      CLOSE REQUEST NUMBEWR 
      DEF IDCB,I    THE FILE'S DIRECTORY
DCB2  NOP            ADDRESS
DEF.0 DEF ZERO
ATRUN DEF TRUNC     AND A TWO WORD STRING CONTAINING
      DEF .2         THE DOUBLE WORD # OF SECTORYS TO BE TRUNCATED
      SPC 2 
SCHRT JSB RMPAR     CALL RMPAR TO GET 
      DEF *+2        RETURN PARAMETERS
      DEF ERTN        TO LOCAL AREA 
      JMP CLOS4     GO CLEAR OPEN FLAG IN DCB AND RETURN
* 
CLOS3 CLA           SET TO ZERO FOR NO ERROR
      STA ERTN
CLOS4 LDB DCB2      GET DCB WORD 2 ADDRESS
      INB           POSITION TO TYPE WORD 
      LDA B,I        AND GET IT 
      SZA           IF NOT TYPE 0 THEN
      JMP EX         JUST RETURN
      INB           SET TO LU WORD
      LDA B,I       GET LU AND
      AND B377       MASK TO LOWER BYTE 
      STA ERTN+4    SAVE IT 
      ADB .12       POSITION TO EXTENT WORD 
      LDA B,I       GET LOCK UNLOCK FLAG
      SZA           LOCKED ON OPEN? 
      JMP EX        NO - JUST RETURN
      JSB LURQ      YES - UNLOCK THE LU 
      DEF *+4 
      DEF BIT14     (NO ABORT)
      DEF ERTN+4     LU 
      DEF .1        ONE LU
      NOP           IGNORE ERROR RETURN 
* 
EX    LDA ERTN      GET ERROR RETURN
EXIT  STA IERR,I    SET THE ERROR CODE
      CLA           CLEAR OPEN FLAG WORD
      STA OPNFL,I    IN DCB 
      LDB DM        RESET THE 
      STB IERR       CALL WORDS 
      LDB DEF.0       FOR THE 
      STB IRX          NEXT CALL
      STB IDCB
      CCB           RESET CLOSE\ECLOS 
      STB ECLOS      FLAG 
      JMP CLOSE,I   RETURN WITH ERROR CODE IN A 
      SPC 3 
ER11  CCA           FILE NOT OPEN - ERROR 11
ER10  ADA N10       NOT ENOUGH PRAMS - ERROR 10 
      JMP EXIT      GO EXIT 
      SPC 3 
N10   DEC -10 
N2    DEC -2
.1    DEC 1 
.2    DEC 2 
.3    DEC 3 
.8    DEC 8 
.12   DEC 12
.13   DEC 13
.23   DEC 23
BIT14 OCT 40000 
OPFLG OCT 177700
B377  OCT 377 
SC    NOP 
OPNFL NOP 
D.RTR ASC 3,D.RTR 
ERTN  NOP 
      NOP           LOCAL STORAGE FOR 
      NOP            RETURN PARAMETERS
      NOP             FROM D.RTR
      NOP 
ZERO  NOP           MUST BE DOUBLE WORD FOR 
      NOP            DEFAULT CASE IN ECLOS
TRUNC BSS 2         DOUBLE WORD TRUNCATE CODE 
      SPC 2 
      SPC 3 
A     EQU 0 
B     EQU 1 
XEQT  EQU 1717B 
      SPC 1 
END   EQU * 
      SPC 1 
      END 
                            