ASMB,R,L,C
*     NAM PUTID,7 09570-16723 PRE-REL 770302
      NAM PUTID,7 PRE-REL (RTE-IV) 780327 (DLB) 
* 
*-------------------------------------------------------- 
* 
*     RELOC.       09570-16723
*     SOURCE       09570-18723
* 
*     W A GROVES         22 FEB 77 PRE-RELEASE
*     MODIFIED 3-3-77    (DLB)
* 
*     (C) COPYRIGHT HEWLETT-PACKARD COMPANY,1976. 
*     ALL RIGHTS RESERVED.THE INFORMATION CONTAINED ON
*     THIS MEDIUM MAY BE USED WITH ONLY ONE COMPUTER
*     AT A TIME.IT SHALL NOT OTHERWISE BE RECORDED, 
*     TRANSMITTED,OR STORED IN A RETRIEVAL SYSTEM.
*     COPYING OR OTHER REPRODUCTION WITHOUT PRIOR WRITTEN 
*     CONSENT OF HEWLETT-PACKARD COMPANY IS PROHIBITED, 
*     EXCEPT THAT ONE COPY MAY BE MADE AND RETAINED FOR ARCHIVE 
*     PURPOSES ONLY.
* 
*                ---------------
* 
*     THE INFORMATION CONTAINED ON THIS MEDIUM IS PROPRIETARY 
*     TO HEWLETT-PACKARD COMPANY. IT MAY BE USED WITH ONE 
*     COMPUTER ONLY AND IS NOT TO BE DISCLOSED TO ANY THIRD 
*     PARTIES OR REPRODUCED IN ANY FORM EXCEPT THAT IT MAY BE 
*     TRANSFERRED TO ONE BACKUP COMPUTER DURING A COMPUTER
*     MALFUNCTION OR DURING PREVENTIVE MAINTENANCE. 
* 
*-------------------------------------------------------- 
      ENT PUTID 
      EXT IDRPL,IDDUP,IDSGA,.DFER 
      EXT .ENTR,FSTAT,LOPEN 
      EXT LCLOS 
      EXT .XLA
A     EQU 0 
B     EQU 1 
XEQT  EQU 1717B 
SECT3 EQU 1760B 
* 
*     THIS SUBROUTINE WILL DO WHATEVER IS NECESSARY 
*     TO MAKE A PROGRAM SCHEDULEABLE BY AN EXEC CALL. 
*     THE PROGRAM WILL BE RENAMED WITH TERMINAL LU
*     AS THE LAST 2 CHARACTERS OF THE NAME IF THE 
*     ID SESSION BIT OF THE CALLING PROGRAM IS SET
*     AND THE "IH" FLAG IS NOT SET UNLESS THE PROGRAM 
*     TO BE SCHEDULED IS A NON-DUPLICATABLE PROGRAM.
*     (NOT SET UP AS TYPE 6 FILE OR IF ID-SEGMENT IS
*     IN CORE, ID SEGMENT WAS NOT SET UP BY ":RP")
* 
*     CALLING SEQUENCE: 
*     CALL PUTID(IDCB,IERR,NAME,LU,IRPFLG)
* 
*     WHERE:
*                   IDCB= 144 WORD FMGR DCB BUFFER FOR SUBROUTINE USE 
*                   IERR= FMGR ERROR RETURN VARIABLE
*                   NAME= 6-ELEMENT ARRAY AS FOLLOWS: 
* 
*                   NAME(1-3)= PROGRAM NAME 
*                   NAME(4)= NOT USED FOR 
*                            "NAMR" COMPATABILITY.
*                   NAME(5)=   TYPE 6 FILE SECURITY 
*                              IF "IH", INHIBIT RENAMING. 
*                   NAME(6)=   TYPE 6 FILE CRN
*                              IF "0", SEARCH LU 2,3
*                   NAME(1-3) WILL BE CHANGED BY PUTID
*                         TO THE APPROPRIATE SESSION NAME 
*                         IF SESSION CONDITIONS ARE MET.
*                   LU=   TERMINAL LU 
*                   IRPFLG= NON-ZERO IF CALLING PROGRAM 
*                           SHOULD RELEASE PROGRAM'S ID 
*                           SEGMENT (CALL IDRPD) AFTER PROGRAM
*                           HAS COMPLETED.
* 
      HED FORTRAN EXAMPLE 
*                   FORTRAN EXAMPLE:
*     FTN4,L
*           PROGRAM RPTST(3,1000) 
*           DIMENSION NAME(13),IBUF(10),IDCB(144) 
*     C  GET TERMINAL LU (ITMLU MUST BE CALLED FIRST!)
*           LU=ITMLU(IDMY)
*           WRITE (LU,10000)
*     10000 FORMAT ("ENTER PROGRAM NAMR") 
*           READ (LU,10100)NAME 
*     10100 FORMAT (13A2) 
*     C 
*     C PARSE USING NAMR
*     C 
*           IST=1 
*           IEND=26 
*           CALL NAMR(IBUF,NAME,IEND,IST) 
*           CALL PUTID(IDCB,IERR,IBUF,LU,IRP) 
*           IF (IERR .NE. 0) GO TO 9000 
*     C 
*     C SCHEDULE PROGRAM
*     C 
*           CALL EXEC(100027B,IBUF,LU)
*           GO TO 8000
*     100   IF (IRP .NE. 0) CALL IDRPD(IBUF)
*           STOP
*     8000  WRITE (LU,10200)
*     10200 FORMAT ("SCHEDULE CALL FAILED.")
*           GO TO 100 
*     9000  WRITE (LU,10300) IERR,(IBUF(I),I=1,3) 
*     10300 FORMAT (/"/FMGR: ERR#"I6" ON "3A2)
*           GO TO 100 
*           END 
*           END$
      HED SUBROUTINE TO MAKE PROGRAM SCHEDULEABLE 
ADDCB NOP           * 
ADERR NOP           * 
ADNAM NOP           * 
ADLU  NOP           * 
ADRPF NOP           * 
PUTID NOP           * 
      JSB .ENTR     * 
      DEF ADDCB     * 
      JSB .DFER     * MOVE PROGRAM NAME 
      DEF NWNAM     * TO INTERNAL BUFFER. 
      DEF ADNAM,I   * 
      LDB ADNAM     * 
      ADB =D4       * 
      LDA B,I       * GET FILE SECURITY.
      STA SEC       * 
      INB           * 
      LDA B,I       * GET FILE CRN
      STA CRN       * 
      CLA           * 
      STA ADRPF,I   * CLEAR RP FLAG 
      STA RNFLG     * CLEAR RENAME FLAG.
      STA ADERR,I   * CLEAR ERROR VARIABLE
      LDA IH        * 
      CPA SEC       * INHIBIT OPTION? 
      JMP TRYOV     * YES.
      LDA XEQT      * 
      ADA =D20      * CHECK IF SESSION BIT IS SET 
      JSB .XLA      * 
      DEF A,I       *  LDA A,I
      AND SESBT     * 
      SZA,RSS       * IN SESSION? 
      JMP TRYOV     * NO. 
      CCA           * YES. SET RENAMING FLAG. 
      STA RNFLG     * 
      CLB           * 
      LDA ADLU,I    * GET TERMINAL LU 
      DIV =D10      * CHANGE TERMINAL LU TO ASCII 
      ALF,ALF       * 
      IOR B         * 
      IOR "00"      * 
      STA TEMP      * 
      DLD NWNAM     * GET FIRST 2 CHARACTERS OF 
      AND =B377     * PROGRAM NAME
      CPA =B40      * IMBEDDED SPACE? 
      LDA DOT       * YES. REPLACE WITH DOT.
      IOR NWNAM     * 
      STA NWNAM     * 
      LSR 8         * CHECK THIRD CHARACTER.
      CPB =B40      * BLANK?
      LDB DOT       * YES. MAKE DOT.
      LDA TEMP      * 
      RRL 8         * 
      IOR =B40      * MAKE LAST CHARACTER BLANK.
      STB NWNAM+1   * 
      STA NWNAM+2   * 
TRYOV JSB IDSGA     * IS GENERIC ID-SEGMENT IN CORE?
      DEF *+2       * 
      DEF ADNAM,I   * USE GENERIC NAME. 
      SZA,RSS       * FIND IT?
      JMP RPIT      * NO. 
      LDB RNFLG     * YES.
      SZB,RSS       * NEED TO RENAME IT?
      JMP PUTID,I   * NO. EXIT. 
      ADA =D26      * INDX TO DISC ADDRESS WORD 
      JSB .XLA      * GET DISC ADDRESS
      DEF A,I       * LDA A,I 
      STA TEMP      * SAVE TILL LATER 
      JSB IDDUP     * TRY IN-CORE DUPLICATE.
      DEF *+4       * 
      DEF ADNAM,I   * OLD NAME
      DEF NWNAM     * NEW NAME
      DEF ADERR,I   * ERROR VARIABLE
      SZA,RSS       * ERROR?
      JMP RPFEX     * NO. EXIT. 
      CPA =D16      * (UNKNOWN BASKINS ERROR) 
      JMP OKERR     * EXIT. 
      CPA =D17      * ID SEGMENT NOT SET-UP BR ":RP" ?
      JMP OKERR     * YES. USE GENERIC NAME ID. 
      CPA =D23      * DUPLICATE ID ?
      RSS           * YES.
      JMP PUTID,I   * ERROR EXIT. 
      JSB IDSGA     * GET ID# OF DUPLICATE ID.
      DEF *+2       * 
      DEF NWNAM     * 
      SZA,RSS       * FIND ID?
      JMP TRYOV     * NO. WHO OFF'D MY ID?
      ADA =D26      * YES. BUMP TO DISC TRACK ADDRESS.
      JSB .XLA      * 
      DEF A,I       * LDA A,I 
      CPA TEMP      * DISC ADDRESS SAME AS GENERIC ID?
      JMP RPFEX     * YES. USE IT, BUT SET ":RP,," FLAG.
      JMP BDERR     * NO. ERROR EXIT. 
RPIT  JSB IDSGA     * 
      DEF *+2       *  SEE IF RENAMED ID IS IN CORE 
      DEF NWNAM     * 
      SZA           * FIND IT?
      JMP RPFEX     * YES. EXIT.
      LDA CRN       * NO. 
      STA LUCRN     * 
      SZA           * CRN SEARCH? 
      JMP ONECR     * NO. USE GIVEN CRN.
      LDA SECT3     * YES. GET# OF LU 3 SECTOR/TRACK
      SZA           * LU 3 MISSING? 
      JMP GTCRN     * NO. 
      LDA =D-2      * YES. SEARCH LU 2 ONLY.
      STA LUCRN     * 
ONECR CCA           * ONLY ONE CARTRIDGE TO SEARCH. 
      STA #CRNS     * 
      JMP OPNIT     * TRY TO OPEN.
GTCRN JSB FSTAT     * GET MOUNTED CARTRIDGE LIST
      DEF *+2       * 
      DEF ADDCB,I   *3-3 USE PASSED DCB BUFFER
      CLA           * 
      STA LUCRN     * 
      LDA ADDCB     * 
      STA CRADD     * SET CURRENT ADDRESS TO START OF BUFFER
GTLOP LDA CRADD,I   * GET CARTRIDGE LU
      SZA,RSS       * END OF LIST?
      JMP OPNIT     * YES.
      AND =B77      * 
      CPA =D2       * LU=2? 
      JMP FOUND     * YES.
      CPA =D3       * NO. IS THIS LU 3? 
      JMP FOUND     * YES.
      LDA CRADD     * NO. 
      ADA =D4       * BUMP ADDRESS
      STA CRADD     * 
      JMP GTLOP     * DO SOME MORE. 
FOUND CMA,INA       * 
      STA LUCRN     * SAVE STARTING LU. 
      LDA =D-2      * SET # CRN'S TO SEARCH AS 2. 
      STA #CRNS     * 
OPNIT JSB LOPEN     * OPEN TYPE 6 FILE
      DEF *+7       * FOR THIS PROGRAM
      DEF ADDCB,I   * 
      DEF ADERR,I   * 
      DEF ADNAM,I   * USE GENERIC NAME
      DEF D1        * 
      DEF SEC       * 
      DEF LUCRN     * USE APPROPRIATE CRN 
      SSA,RSS       * OPEN SUCCESSFUL?
      JMP RPLIT     * YES.
      CPA =D-6      * NO. VALID ERROR (NOT FOUND) ? 
      RSS           * YES.
      JMP PUTID,I   * NO. BAIL OUT. 
      ISZ #CRNS     * SEARCH ANOTHER CRN? 
      RSS           * YES.
      JMP PUTID,I   * NO. BAIL OUT. 
      LDA LUCRN     * GET CURRENT CRN.
      CLB,INB       * 
      CPA =D-2      * WAS THIS LU 2?
      CCB           * YES.
      ADA B         * BUMP CRN UP OR DOWN APPROPRIATELY.
      STA LUCRN     * 
      JMP OPNIT     * TRY OPEN AGAIN
RPLIT JSB IDRPL     * 
      DEF *+4       * DO ":RP" ON PROGRAM 
      DEF ADDCB,I   * 
      DEF ADERR,I   * 
      DEF NWNAM     * PUT IN NEW NAME 
      JSB LCLOS     * 
      DEF *+2       * CLOSE PROGRAM FILE
      DEF ADDCB,I   * 
      LDA ADERR,I   * 
      SZA,RSS       * ANY ERROR?
      JMP RPFEX     * NO. EXIT. 
      CPA =D23      * YES. DUPLICATE ID?
      JMP RPFEX     * USE THE ID ALREADY THERE. 
      JMP PUTID,I   * ERROR EXIT. 
RPFEX CCA           * 
      STA ADRPF,I   * SET ":RP,," FLAG. 
      CLA           * 
      STA ADERR,I   * CLEAR ERROR VARIABLE. 
BDERR JSB .DFER     * 
      DEF ADNAM,I   * RETURN NEW NAME (IF CHANGED)
      DEF NWNAM     * 
      JMP PUTID,I   * EXIT
OKERR CLA           * 
      STA ADERR,I   * RESET ERROR PARAMETER 
      JMP PUTID,I   * DON'T SET ":RP,," SWITCH. DON'T RENAME. 
      HED PUTID VARIABLES 
CRADD NOP           * 
CRN   NOP           * 
#CRNS NOP           * 
D1    DEC 1         * 
DOT   OCT 56        * 
IH    ASC 1,IH      * 
LUCRN NOP           * 
NWNAM BSS 3         * 
"00"  ASC 1,00      * 
RNFLG NOP           * 
SEC   NOP           * 
SESBT OCT 20000     * 
TEMP  NOP           * 
      END 
                                                                                                      