ASMB,R,L,C
      HED "IDRPD" FTN SUBROUTINE TO DO A FMGR ":RP,,PROG" 
*     SOURCE: 92067-18236 
*     RELOC:  92067-16185 
*     PGMR:   D.L.B.
* 
*  ***************************************************************
*  * (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 IDRPD,7 92067-16185 REV.2040 800909 
* 
*  MODIFICATION RECORD: 
*   OLD DATE   NEW DATE   REASON   BY WHOM
* 1) 12-7-75    2-3-76   TO FIX BUG IF PROGRAM IS ON DISC LU=3  (DLB) 
* 2)  2-3-76   10-4-76   OF,PROGM CLEAN UP INCASE OF SERIAL REUSABLE(DLB) 
* 3) 10-4-76  11-15-77   TO SUPPORT RTE-IV PROGRAM TYPES AND ID EXTENSIONS
* 4) 11-15-77   4-3-78   CROSS-MAP ACCESS TO ID SEGMENTS FOR RTE-IV 
*                        TYPE 4 PROGRAMS USING THIS ROUTINE 
* 5)  4-3-78   9-20-78   TO CHECK THE COPY FLAG BEFORE DELETING 
* 6) 9-20-78   9-29-78   TO RESTORE MESSAGE BUFFER FOR MESSS CALL 
*                        TO OVERRIDE MESSS SESSION CAPABILITY CHECKS
* 7) 9-29-78   2-27-80   TO ALLOW :RP,, OF DORMANT TEMPORARILY LOADED 
*                        PROGRAMS (BECAUSE OF :RP ENHANCEMENT TO ALLOW
*                        TYPE 6 FILES ON ANY CARTRIDGE).  (DCL) 
* 8) 2-27-80   7-31-80   TO REPLACE ABORT PROCESSING WITH 
*                        'OF,PROG,8,NP'  (SST #4857)
* 
      ENT IDRPD 
      EXT $LIBR,$LIBX,IDSGA,.ENTP,$OPSY 
      EXT MESSS,SESSN       
A     EQU 0 
B     EQU 1 
TAT   EQU 1656B     TAT BASE ADDRESS
TATLG EQU 1755B     NEGATIVE LENGTH OF TAT
TATSD EQU 1756B     # TRACKS ON LU#2
SECT2 EQU 1757B     # SECTORS PER TRACK ON LU#2 
SECT3 EQU 1760B     # SECTORS PER TRACK ON LU#3 
XEQT  EQU 1717B     ID SEGMENT ADDR OF CURRENT PROGRAM
* 
      SUP PRESS EXTRANEOUS LISTINGS 
      SKP 
*  PURPOSE: 
*    TO ACCOMPLISH THE EQUIVALENT OF A FMGR :RP,,PROG IN A SUBROUTINE.
* 
*  CALLED:
*     CALL IDRPD (NAME,IERR)
*           -OR-
*     IF (IDRPD (NAME,IERR).NE.0) GO TO IERROR
*           -OR-
*     IERR  =  IDRPD(NAME)
* 
*  WHERE: 
*     NAME = 5 CHARACTER BUFFER OF THE PROGRAM NAME DELETED FROM SYSTEM 
*     IERR = (OPTIONAL) RETURN ERROR CODE (SAME AS ERROR CODES IN FMGR) 
* 
*  RETURN:
*     IERR =  0 > SUCCESSFUL DELETION OF ID SEGMENT FROM SYSTEM 
*     E-REG = 1 IF ERROR, ELSE E-REG =  0 (FOR FRETURN SPL) 
*     IERR =  9 > ID-SEGMENT NOT FOUND
*     IERR = 17 > ID-SEGMENT NOT SET UP BY RP 
*                 (MEANING THAT THE PROGRAM IS NOT A TEMPORARY
*                 LOAD OF A TYPE 2,3,4, OR 5 PROGRAM) 
*     IERR = 18 > PROGRAM NOT DORMANT 
* 
*  NOTES: 
* 
*    (1)  A-REG = IERR ON RETURN, THEREFORE MAY BE USED AS FUNCTION 
*    (2)  E-REG = 1, IF ERROR, E=0, IF NO ERROR(FOR SPL)
*    (3)  IERR   IS AN OPTIONAL PARAMETER.
*    (4)  CALLING PROGRAM MUST NOT BE PRIVILEGED. 
* 
*  TEST PROGRAM:
*FTN,L
*      PROGRAM TYRPD(2,99)
*      DIMENSION NAME(3),LU(5)
*      CALL RMPAR(LU) 
*      IF (LU.EQ.0) LU = 1
*    1 WRITE (LU,11)
*   11 FORMAT ("INPUT PROGRAM TO DELETE? _")
*      READ (LU,12) NAME
*      IF (NAME.EQ.2H/E) GO TO 9999 
*   12 FORMAT (3A2) 
*      IF(IDRPD(NAME,IERR).EQ.0) GO TO 9999 
*   33 WRITE (LU,46) IERR 
*   46 FORMAT ("FMGR ERROR "I3) 
*      GO TO 1
* 9999 STOP             
*      END
*      END$ 
      SKP 
NAME  NOP           PROGRAM NAME ADDRESS
IERR  NOP           RETURNED ERROR CODE 
* 
IDRPD NOP           ENTRY 
      JSB $LIBR     GO PRIVILEGED 
      NOP 
      JSB .ENTP 
      DEF NAME
* 
      LDA $OPSY     OP SYSTEM IDENTIFIER           *780403* 
      ERA           MOVE MAPPED BIT FOR SLA        *780403* 
      STA STYPE     SAVE FOR LOADA,STORA ROUTINES  *780403* 
* 
      JSB IDSGA     FIND ID SEGMENT ADDR OF PROGRAM 
      DEF *+2 
      DEF NAME,I
      STA IDADR     SAVE ID(1) ADDRESS
      STA B         SAVE IN B-REG 
      LDA D9        GET SET FOR ERROR 9 
      SEZ           FOUND?
      JMP ENDTA     NO,FMGR ERROR 09
* 
      ADB D8        BUMP TO XSUSP 
      JSB LOADA     GET XSUSP VALUE                *780403* 
      STA TEMP      SAVE IT                        *780403* 
      ADB O4        BUMP TO PROGRAM NAME WORD 
      STB ID13      SAVE FOR LATER USE
      ADB O2        BUMP TO PROGRAM TYPE WORD 
      STB ID15      SAVE FOR LATER USE
* 
      INB           BUMP TO STATUS WORD (ID(16))
      JSB LOADA     GET STATUS WORD                *780403* 
      IOR TEMP      MERGE WITH XSUSP VALUE         *780403* 
      ADB O2        BUMP TO ID(18) (CHECK NOT IN TIME LIST) 
      STA TEMP      TEMPORARY SAVE                 *780403* 
      JSB LOADA     GET THE T-BIT(IN TIME LIST)    *780403* 
      LDB TEMP      RESTORE                        *780403* 
      CCE,SZB,RSS   SET E-REG IF PROG BUSY?        *780403* 
      ALF,CLE,ERA   SET E=1 IF IN TIME LIST        *780403* 
      LDB ID15      GET ID(15)                     *780403* 
      JSB LOADA                                    *780403* 
      AND O227      GET PROG TYPE & IDSEG TYPE BITS 
      XOR O200      COMPLEMENT BIT 7
*     LDB ID15      GET ID(15) ADDRESS             *780403* 
      ADB O5        MAKE ID(20) ADDRESS 
      CPA O25       SHORT ID? 
      JMP OKTYP     YES                              800227 
      ADB O7        BUMP TO ID(27)
      CPA O5        IF TYPE 5 LONG ID, THEN MAKE
      CLE,ARS       SAME AS TYPE 2, NOT BUSY
      ARS           CHANGE 2 & 3 TO 1 
      STA TEMP      SAVE PGM TYPE & IDSEG TYPE BITS (SHIFTED) 
      CPA O1        TYPE 2 OR 3?
      JMP TYPCK     YES, TYPE 2, 3 OR 5 LONG ID 
      LDA $OPSY     OP SYSTEM IDENTIFIER
      CPA M9        RTE-IV? 
      RSS           YES, SO ALLOW TYPE 4
      JMP ERR17     NO, WRONG TYPE
      LDA TEMP      RESTORE PGM TYPE & IDSEG TYPE BITS (SHIFTED)
      CPA O2        TYPE 4 AND TEMPORARY? 
      JMP TYPC2     YES, ALLOW FOR RTE-IV                *780524*GLM
ERR17 CLA,CCE       WRONG PROGRAM TYPE FMGR ERR 17
TYPCK INA 
TYPC2 ADA O20       A= 17 OR 18 
      SEZ,RSS       CHECK IF ERR 17 OR PROG BUSY(ERR 18)
      JMP OKTYP     NO, CONTINUE      
* 
ENDTA JSB $LIBX     YES, RETURN ERROR 
      DEF *+1 
      DEF EXIT
* 
*  AT THIS POINT, WE KNOW THAT WE HAVE A TEMPORARY LOAD OF A
*  TYPE 2, 3, 4, OR 5 PROGRAM.
*   
*  EXECUTE AN 'OF,PROG,8,NP' TO CLEAN UP ANY ID SEG OWNED RESOURCES 
* 
OKTYP DLD NAME,I    NAME PASSED IN CALL 
      DST PNAME     (FIRST 2 WORDS OF NAME) 
      LDB NAME      ADDRESS OF NAME PASSED IN 
      ADB O2        OFFSET TO 3RD WORD OF NAME
      LDA B,I       GET 3RD WORD OF NAME
      AND C377      MASK OFF LOW BYTE 
      IOR COMMA     MERGE IN COMMA
      STA PNAM3     SAVE IN MESSAGE BUFFER
* 
      JSB SESSN     TEST IF IN SESSION
      DEF *+2 
      DEF XEQT
      SEZ           SKIP IF IN SESSION
      CLB,RSS       NON-SESSION, ZERO THE SES PARAMETER 
      CMB           SESSION, PASS -SCB ADDRESS (IDSEG WD 32)
      STB SES 
* 
      JSB $LIBX     NOW TURN BACK ON INTERRUPT SYSTEM 
      DEF *+1 
      DEF *+1       FOR CALL TO MESSS (GEORGE)
* 
      JSB OFF       SEND 'OF,PROG,8,NP'         
      NOP                                         
      NOP                                       
      JSB OFF       ONCE MORE IN CASE ID SEG WASN'T CLEARED 
*               
      CLA,CLE       RETURN GOOD EXIT                            
EXIT  STA IERR,I    RETURN ERROR CODE 
      CLB           CLEAR OPTIONAL PARAMETER
      STB IERR        FOR NEXT CALLER TO DEFAULT
      JMP IDRPD,I   RETURN
* 
      SKP 
* 
*  MISC ROUTINES
* 
* 
LOADA NOP           DOES XLA B,I IF MAPPED SYS     *780403* 
      LDA STYPE     OP SYS IDENTIFIER (AFTER ERA)  *780403* 
      SLA           MAPPED SYSTEM?                 *780403* 
      JMP MAPSY     YES                            *780403* 
      LDA B,I       NO, DO DIRECT LOAD             *780403* 
      JMP LOADA,I   RETURN                         *780403* 
MAPSY XLA B,I       DO CROSS-LOAD (2-WD INSTRUCT.) *780403* 
      JMP LOADA,I   RETURN                         *780403* 
      SPC 1 
OFF   NOP 
      LDA DOFMS     ADDRESS OF MESSAGE      
      LDB DOUTM     DESTINATION ADDRESS 
      MVW O7        7 WORDS IN MESSAGE
      JSB MESSS     SEND 'OF,PROG,8,NP' REQUEST 
      DEF *+5 
DOUTM DEF OUTMS     MESSAGE BUFFER
      DEF D14       14 CHARACTERS 
      DEF ZERO
      DEF SES       SCB ADDR TO OVERRIDE CAPABILITY CHECK 
      JMP OFF,I     RETURN
      SKP 
STYPE BSS 1         OP SYSTEM IDENTIFIER (AFTER ERA) 800227 
IDADR NOP 
ID13  NOP 
ID15  NOP 
SES   NOP 
TEMP  NOP 
M9    DEC -9
ZERO  OCT 0 
O2    OCT 2 
O1    OCT 1 
O4    OCT 4 
O5    OCT 5 
O7    OCT 7 
D8    DEC 8 
D9    DEC 9 
D14   DEC 14
O20   OCT 20
O25   OCT 25
O227  OCT 227 
O200  OCT 200 
C377  OCT 177400
COMMA OCT 54
DOFMS DEF OFMSG 
OFMSG ASC 2,OF,     DON'T REORDER THE NEXT 7 WORDS
PNAME ASC 2,    
PNAM3 ASC 1, ,
PWRAB ASC 2,8,NP
OUTMS BSS 7 
      END 
                                                                                                                                                                                                                        