ASMB,R,L,C
      HED (FMP) CLOSE: CLOSE A FILE 
*     NAME:   CLOSE 
*     SOURCE: 92071-18039 
*     RELOC:  92071-16039 
*     PGMR:   G.A.A.
*     MOD:    M.L.K., E.D.B.
* 
*  ***************************************************************
*  * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980.  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 92071-1X039 REV.2041 800811
* 
      ENT CLOSE,ECLOS 
* 
      EXT GTOPN, R/W$, $DBLX
      EXT CLD.R, .P1, .P2, .P4, .R1 
      EXT .ENTR, LURQ, $SETP
* 
      EXT F.DCB, F.LU, F.TYP, F.ST1, F.FLG
      EXT F.EXN, F.DLU
      SUP 
      SKP 
* 
*     DESCRIPTION 
* 
*     THIS IS THE CLOSE SUBROUTINE--A PART OF THE 
*     REAL-TIME FILE MANAGEMENT PACKAGE 
* 
*     THE FORTRAN CALLING SEQUENCE IS:
* 
*     CALL CLOSE(IDCB,IERR,ITRUN) 
*     CALL ECLOS(IDCB,IERR,ITRUN) 
* 
*     WHERE:
* 
*     IDCB   IS THE USER DATA CONTROL BLOCK.
* 
*     IERR   WILL BE THE ERROR RETURN CODE (OPTIONAL).
*            ALSO RETURNED IN A-REG.
* 
*     ITRUN  IS THE NUMBER OF 128-WORD BLOCKS 
*            TO BE DELETED FROM THE FILE (OPTIONAL).
* 
*     POSSIBLE ERRORS ARE:
* 
*      0      NONE
*     -10     NOT ENOUGH PARAMETERS 
*     -11     FILE NOT OPEN 
*     -17     ILLEGAL LU REQUEST
      SKP 
* 
*     ENTRY 
* 
ECLOS NOP           DOUBLE WORD ENTRY 
      CCA           SET DBL FLAG
      LDB ECLOS     SET UP RETURN ADDRESS 
      JMP SETUP     FINISH SET UP 
* 
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 ITRUN 
      LDA DDMER 
      STA IERR
      JMP DLOSE+1 
* 
IDCB  DEF ZERO      DCB ADDRESS 
IERR  DEF DUMER     ERROR CODE ADDRESS
ITRUN DEF ZERO      TRUNCATE CODE ADDRESS 
* 
DLOSE NOP           ENTRY POINT 
      JSB .ENTR     TRANSFER THE ADDRESSES
      DEF IDCB
* 
      LDA IDCB      CHECK FOR ENOUGH PARAMS 
      CPA DZERO      ENOUGH?
      JMP ER10        NO, TAKE ERROR EXIT 
* 
      LDA IDCB      SET UP POINTERS INTO DCB
      LDB F.DCB 
      JSB $SETP 
      DEF .16 
      NOP 
* 
      JSB GTOPN     GET PROGRAM'S OPEN FLAG 
      DEF *+1 
      CPA F.FLG,I   IS THE SAME AS IN DCB?
      RSS           YES, CONTINUE 
      JMP ER11
      SKP 
* 
*     PROCESS REQUEST 
* 
      ISZ DBLWD     TEST DBL FLAG 
      JMP SINGL      GO DO 16-BIT THING 
      DLD ITRUN,I   GET 32-BIT TRUNC CODE 
      JSB $DBLX 
      JMP EREX
      JMP SAVTR 
* 
SINGL LDB ITRUN,I   GET 16-BIT TRUNC CODE 
* 
SAVTR STB ITRUN     SAVE TRUNCATION CODE
* 
      LDA F.LU,I    GET FILE LU 
      AND B77        ISOLATE LU 
      CLE,SZA,RSS   IF ZERO (DUMMY),
      JMP TYPE0      THEN DON'T CALL D.RTR
* 
      LDB IDCB      GET DCB ADDRESS 
      JSB R/W$      CALL TO FLUSH THE BUFFER
      JMP EREX      DISC ERROR EXIT 
      SKP 
* 
*     SET UP D.RTR REQUEST
* 
      CLA           GET FUNCTION CODE 
      STA .P1        SAVE FOR D.RTR 
* 
      DLD F.LU,I    GET FILE ENTRY LU AND ENTRY NUMBER
      DST .P2 
* 
      CLA           ASSUME ZERO FOR TRUNCATION CODE 
      LDB F.TYP,I   GET FILE TYPE 
      SZB,RSS       IF TYPE ZERO, 
      JMP CLOS1      THEN FORGET TRUNCATION 
* 
      LDB F.EXN,I   GET EXTENT NUMBER 
      SZB           IF NOT MAIN EXTENT, 
      JMP CLOS1      THEN FORGET TRUNCATION 
* 
      LDB F.ST1,I   GET FIRST STATUS WORD 
      SSB,RSS       IF SECCD DOESN'T MATCH, 
      JMP CLOS1      THEN FORGET TRUNCATION 
* 
      LDA ITRUN     GET TRUNCATION CODE 
      ALS            CONVERT TO SECTORS 
* 
CLOS1 CMA,INA       NEGATE TRUNCATION CODE
      STA .P4        AND SAVE FOR D.RTR 
* 
      JSB CLD.R     SCHEDULE D.RTR
* 
      LDA .R1       GET D.RTR ERROR 
      SZA           IF ERROR OCCURRED,
      JMP EREX1      THEN EXIT
* 
      LDA F.TYP,I   GET FILE TYPE AGAIN 
      SZA           IF NOT TYPE 0,
      JMP EXIT       THEN EXIT
      SKP 
* 
*     UNLOCK DEVICE 
* 
TYPE0 LDA F.ST1,I   GET FIRST STATUS WORD 
      AND .2         ISOLATE LU LOCK FLAG 
      SZA,RSS       IF NOT LOCKED,
      JMP EXIT       THEN EXIT
* 
      LDA F.DLU,I   GET DEVICE LU 
      AND B77        ISOLATE LU 
      STA NLU         SAVE FOR LURQ 
* 
      JSB LURQ      CALL TO UNLOCK DEVICE 
      DEF *+4 
      DEF B40K      UNLOCK NO ABORT 
      DEF NLU 
      DEF .1
      JMP ER17      ERROR RETURN
      SKP 
* 
*     EXIT
* 
EXIT  CLA           NO ERROR INTENDED 
      JMP EREX1 
* 
ER10  LDA N10       NOT ENOUGH PARAMETERS 
      JMP EREX
* 
ER11  LDA N11       FILE NOT OPEN 
      JMP EREX
* 
ER17  LDA N17       ILLEGAL EXEC REQUEST
* 
EREX1 CLB           CLEAR OPEN FLAG 
      STB F.FLG,I 
* 
EREX  STA IERR,I    SAVE ERROR CODE 
      JMP DLOSE,I    AND RETURN 
      SKP 
* 
*     STORAGE AREA
* 
ZERO  NOP 
      NOP 
* 
N10   DEC -10 
N11   DEC -11 
N17   DEC -17 
* 
.1    DEC 1 
.2    DEC 2 
.16   DEC 16
* 
B77   OCT 77
B40K  OCT 40000 
* 
DZERO DEF ZERO
DDMER DEF DUMER 
* 
DBLWD NOP           DOUBLE WORD FLAG
DUMER NOP           DUMMY ERROR WORD
NLU   NOP           TEMP LU WORD
* 
A     EQU 0 
B     EQU 1 
* 
END   EQU * 
* 
      END 
                          