FTN4
      SUBROUTINE TMGLD(IERFL),92903-16402 REV.1913  781113
C 
C 
C     NAME:   TMGLD,BIDLD,IUPPT 
C     SOURCE: &TMGLD    92903-18402 
C     RELOC:  %TMGLD    92903-16402    PART OF  RTMGLB
C 
C     PGMR:   FRANCOIS GAULLIER   HPG 
C 
C 
C     **************************************************************
C     * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978.  ALL RIGHTS    *
C     * RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- *
C     * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH-  *
C     * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.  *
C     **************************************************************
C 
C 
C     **************************************************
C     *                                                *
C     *     THIS SUBROUTINE LOAD ALL PROGRAMS OF A TMS *
C     *     APPLICATION ACCORDING TO THE USER REQUEST  *
C     *     [IMOTR(2)] AND THE LOADING REQUEST FLAG    *
C     *     SET BY OTHERS TMSGN MODULE [IRQFLG(1:30)]  *
C     *                                                *
C     **************************************************
C 
C     IERFL   IS AN ERROR FLAG
C             = 0  OK, NO ERROR 
C             = -2 ERROR OCCURED, REPORT IT TO OPERATOR 
C 
C 
C-----LABEL COMMON # 1  GENERAL INFORMATION 
C 
      COMMON /TMGC1/LU,LUPRT,LUOUT,ISYTP
C 
C-----LABEL COMMON # 2  FLAGS 
C 
      COMMON /TMGC2/ITMFL,IRQFLG(30),IMOTR(9) 
C 
C-----LABEL COMMON # 3  BUFFER AREA 
C 
      COMMON /TMGC3/IDUM0(7),NCRTH(1) 
C 
C-----LABEL COMMON # 4  BUFFER USED IN CREATION PHASE & ERROR FLAG
C 
      COMMON /TMGC4/IERFLG,IERNB,IERTN,IERMS(7),IRLOC(70),ITRSF(20) 
C 
      DIMENSION IREG(2),LOADR(3),ILODP(23),IOPT(3)
C 
      INTEGER AREG,BREG 
      LOGICAL ISBIT,IDCLR 
      EQUIVALENCE (REG,IREG,AREG),(IREG(2),BREG)
      EQUIVALENCE (IRLO2,IRLOC(2))
C 
      DATA LOADR/2HLO,2HAD,2HR /
      DATA ILODP/15530B,15555B,15446B,2Hk0,2HB ,15510B,15512B,15542B
     .,2H  ,15446B,2HdC,2HLO,2HAD,2HIN,2HG ,2HPH,2HAS,2HE ,15446B 
     .,2Hd@,6412B,5012B,15554B/ 
C 
      IERFL=0 
C 
C     LOADING TO PERFORM ?
C 
      IF(IMOTR(2) .LE. 1)  GOTO 1100
      CALL MOVEW(IMOTR(2),IOPT,2) 
      IOPT(3)=ISYTP 
C 
C-----IF LOADER LIST ON CRT, UNLOCK THE CRT 
C 
      IF(LUPRT .EQ. LU)  CALL LURQ(0,LU,1)
C 
C-----LOADING OPERATION 
C 
      CALL EXEC(2,LU,ILODP,23)
      CALL EXEC(3,1100B+LUPRT,-1) 
      CALL BLANC(ITRSF(4),8)
      IF(NCRTH(7) .EQ. 0)  GOTO 120 
      NCRTH(4)=2H:
      CALL JASC(NCRTH(7),ITRSF,9,6) 
120   IF(NCRTH(8) .EQ. 0)  GOTO 150 
      ITRSF(4)=2H:
      ITRSF(8)=2H:
      CALL JASC(NCRTH(8),ITRSF,17,6)
150   IF(IRQFLG(2) .EQ. 0) GOTO 1000
C 
C     LOAD %TMSL - %TMST - IMAGE MODULES
C 
      ITRSF=2H%T
C-----IF BIT 15 SET INTO RQFLAG, USE COMMAND FILE 
      IF( ISBIT(IRQFLG(2),15) )  ITRSF=2H>T 
      CALL MOVEW(NCRTH(5),ITRSF(2),2) 
      ASSIGN 400 TO LDRTN 
      ISSGA=0 
      J=2378
      CALL NUL(NCRTH(J),2)
C 
      DO 400 I=1,6
      IF( .NOT. ISBIT(IRQFLG(2),I) )  GOTO 400
      IF(I .EQ. 2)  CALL PUTCA(ITRSF,1HL,2) 
      IF(I .LT. 3)  GOTO 2000 
      J=27+9+15*(I-3) 
      CALL MOVCA(NCRTH,2*J-1,ITRSF,2,5) 
      J=J+3 
      ISSGA=1 
      GOTO 2000 
400   CONTINUE
C 
1000  ITRSF=2H% 
      IF( ISBIT(IRQFLG,15) )  ITRSF=2H> 
      ITRSF(3)=2H 
      CALL MOVCA(NCRTH,9,ITRSF,2,4) 
      IF(IRQFLG .EQ. 0)  GOTO 1020
C 
C     LOAD MAIN PROGRAM 
C 
      ASSIGN 1020 TO LDRTN
      ISSGA=1 
      IF( ISBIT(IRQFLG,14) )  ISSGA=3 
      J=11
      GOTO 2000 
C 
C     LOAD USER PARTITION 
C 
1020  I=3 
      IDEX=NCRTH(4) 
      CALL PUTCA(ITRSF,1H>,1) 
      CALL PUTCA(ITRSF,1HA,6) 
      ASSIGN 1040 TO LDRTN
1030  IF(IRQFLG(I) .EQ. 0) GOTO 1040
      J=IUPPT(I-2,N)+1
      ISSGA=0 
      IF( ISBIT(NCRTH(J+1),15) )  ISSGA=2 
      GOTO 2000 
1040  ITRSF(3)=ITRSF(3)+1 
      I=I+1 
      IDEX=NCRTH(IDEX)
      IF(IDEX.NE.NCRTH+1) GOTO 1030 
C 
C     LOADING PHASE IS COMPLETED, IF CRT HAS BEEN UNLOCKED, RE-LOCK IT
C 
1090  IF(LU .EQ. LUPRT)  CALL LURQ(1,LU,1)
C 
C     CLEAR LOADING REQUEST FLAG
C 
1100  DO 1150 I=1,28
1150  IRQFLG(I)=0 
      RETURN
C 
C     CALL THE LOADER AND CHECK RESULT
C 
2000  IRLOC=2H
      IRLOC(4)=2H 
      CALL MOVCA(ITRSF,2,IRLO2,1,5) 
      CALL ISUPB(IRLO2,3) 
      CALL MOVEW(IRLO2,IERMS(5),3)
      IF(IMOTR(2).NE.2 .AND. IMOTR(2).NE.5)  GOTO 2200
      IF( .NOT. IDCLR(IRLO2,IERR) )  GOTO 2050
      IF(IERR .EQ. -1)  GOTO 2200 
C-----PROGRAM IS LOADED PERMANENTLY, REPORT 'DUPL' ERROR
      CALL MOVEW(4HDUPL,IERMS(3),2) 
      GOTO 2500 
2050  CALL MOVEW(10H ABORTED  ,IRLOC(5),5)
      IF(LUPRT .EQ. 1)  GOTO 2200 
      CALL EXEC(2,LUPRT,IRLOC,9)
      CALL EXEC(2,LUPRT,IRLOC,-1) 
C 
2200  CALL BIDLD(LUPRT,ITRSF,ISSGA,NCRTH(J),IOPT,IRLO2,L) 
      CALL EXEC(2,LUPRT,IRLOC,L+1)
      CALL EXEC(2,LUPRT,IRLOC,-1) 
      IRLOC=5012B 
      IF(LU .NE. LUPRT)  CALL EXEC(2,LU,IRLOC,L+1)
      CALL EXEC(100027B,LOADR,LUPRT,0,0,0,0,IRLO2,L)
      GOTO 2400 
C-----GET PARAMETERS FROM THE LOADER, SAVE ERROR MESS INTO
C     IERMS(3) & IERMS(4),   THE PROGRAM NAME IS IN IERMS(5:7)
2250  CALL RMPAR(IERTN) 
      IF(IERTN .GT. 0)  GOTO LDRTN
C-----REPORT LOADER ERROR MESSAGE TO THE USER 
      GOTO 2500 
C-----IF PROGRAM 'LOADR' IS NOT PRESENT, REPORT ERROR TO THE USER 
2400  CALL MOVEW(4HL MI,IERMS(3),2) 
2500  IERFL=-2
      GOTO 1090 
      END 
      SUBROUTINE BIDLD(LUPRT,NAME,ISSGA,ISIZ,ILDOP,IBUF 
     .,L),92903-16402 REV.1913  781004
C 
C     BUILD  "RU,LOADR . . . .   "  STATEMENT 
C 
C     LU   - LIST LU FOR LOADING MAP
C 
C     NAME - NAMR = NAME:SC:CR   (11 WORDS) 
C            IF 1ST CHAR=%  --->  INPUT FILE
C            ELSE IT IS A COMMAND FILE. 
C     ISSGA- SSGA/SYSTEM COMMON FLAG
C            BIT 0   ACCES SSGA 
C            BIT 1   ACCES SYSTEM COMMON
C     ISIZ - ARRAY OF DIMENSION = 2 
C            1ST WORD = PARTITION SIZE
C            2ND WORD = PARTITION NUMBER
C     ILDOP- LOADR OPTION (3 WORDS) 
C            1ST WORD = OPTION   BG/RT   RP/PE/TE 
C            2ND WORD = LIST  (0 --> NO LIST) 
C            3RD WORD = SYSTEM TYPE  ($OPSY)   RTE-IV = -9
C     IBUF - ARRAY (AT LEAST 31 WORDS)
C            USED TO RETURN THE STRING
C     L    - INTEGER VARIABLE 
C            RETURN THE LENGTH OF THE STRING GENERARTED 
C 
C 
C             01                  11
C   RU,LOADR  AAAAAA: 123456: 123456  LU, BGRPSS, SCNLDB, 1234, 12
C   01      05                      17    20    23      27    30
C 
C 
      DIMENSION ISIZ(1),IBUF(1),ILDOP(1)
      LOGICAL ISBIT 
C 
      CALL MOVEW(8HRU,LOADR,IBUF,4) 
      CALL MOVEW(NAME,IBUF(6),11) 
C-----SET COMMAND OR INPUT FILE 
      IBUF(5)=2H, 
      IBUF(17)=2H,, 
      IF(IGET1(NAME,1) .NE. 1H% ) GOTO 50 
      IBUF(5)=2H,,
      IBUF(17)=2H,
C-----SET LIST LU 
50    CALL JASC(LUPRT,IBUF,35,2)
      CALL MOVEW(26H, BG    ,       ,         ,IBUF(19),13) 
      I=2*ILDOP-3 
      IF(I.LT.7)  GOTO 60 
      IBUF(20)=2HRT 
      I=I-6 
60    CALL MOVCA(6H  RPPE,I,IBUF,41,2)
C-----OVERRIDE  BG/RT  WITH  LB IF RTE-IV 
      IF(ILDOP(3) .EQ. -9)  IBUF(20)=2HLB 
C-----SET COMMON ID 
      IF( ISBIT(ISSGA,0) )  IBUF(22)=2HSS 
      IF( ISBIT(ISSGA,1) )  IBUF(24)=2HSC 
C-----SET LIST OPTION 
      IF(ILDOP(2) .EQ. 0) IBUF(25)=2HNL 
C-----SET PARTITION NUMBER
      CALL JASC(IAND(ISIZ(2),377B),IBUF,55,4) 
      IF(IBUF(29).EQ.2H 0)  IBUF(29)=2H 
C-----SET PARTITION SIZE
      IF(ISIZ.EQ.0)  GOTO 80
      IBUF(30)=2H,
      CALL JASC(ISIZ,IBUF,61,2) 
80    L=ISUPB(IBUF,31)
      RETURN
      END 
      INTEGER FUNCTION IUPPT(IUPT,NTUS),92903-16402 REV.1913  780927
C 
C 
C 
C     ******************************************************************
C     *                                                                *
C     * THIS FUNCTION RETURNS THE POINTER INTO NCRTH FOR A GIVEN USER  *
C     * USER PARTITION, IT REURN ALSO THE NUMBER OF TUS IN THAT USER   *
C     * PARTITION.                                                     *
C     *                                                                *
C     *                                                                *
C     *    IPT = IUPPT(UPT#,NTUS)                                      *
C     *                                                                *
C     ******************************************************************
C 
C 
C 
C-----LABEL COMMON # 3  BUFFER AREA 
C 
      COMMON /TMGC3/IDUM0(7),NCRTH(1) 
C 
C 
      J=NCRTH(4)
      M=1 
100   K=NCRTH(J)
      IF(J.EQ.NCRTH+1) STOP 3043
      IF(M.EQ.IUPT) GOTO 200
      J=K 
      M=M+1 
      GOTO 100
200   N=0 
      DO 300 L=J+3,K-3,3
      IF(IAND(NCRTH(L),100000B).NE.0) GOTO 400
300   N=N+1 
400   IUPPT=J 
      NTUS=N
      RETURN
      END 
      END$
                                                                                                                                                                                                                                                          