FTN4
      SUBROUTINE TMGLD(IERFL),92080-1X402 REV.2026  800200
C 
C 
C     NAME:   TMGLD,BIDLD,IUPPT 
C     SOURCE: &TMGLD    92080-18402 
C     RELOC:  %TMGLD    92080-1X402    PART OF  $TMGLB
C 
C     PGMR:   FRANCOIS GAULLIER   HPG 
C 
C 
C     **************************************************************
C     * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979.  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),ISIZ2(2) 
      DIMENSION ISTAT(7)
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/ 
      DATA ISIZ2/0,0/ 
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 
      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 
C     ISSGA=1 
      ISSGA=0 
      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 
      ASSIGN 1090 TO LDRTN
C 
C-----TRY TO GENERATE DCLOG AT THIS POINT 
C 
      IF(NCRTH(13).EQ.0) GO TO 1090 
      CALL VFLOG(NCRTH(13),ISTAT) 
      IF(ISTAT(1).NE.900) GO TO 1090
      CALL MOVCA(5HDCLOG,1,ITRSF,2,5) 
      ISSGA=1 
      GO TO 2000
C 
C     LOADING PHASE IS COMPLETED, IF CRT HAS BEEN UNLOCKED, RE-LOCK IT
C 
1090  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 
C 
C-----IF NOT FOR DCLOG, CALL BIDLD USING NCRTH(J) 
C 
2200  IF(ITRSF.NE.2H>D.OR.ITRSF(2).NE.2HCL
     .   .OR.ITRSF(3).NE.2HOG)
     .CALL BIDLD(LUPRT,ITRSF,ISSGA,NCRTH(J),IOPT,IRLO2,L) 
C 
C-----IF FOR DCLOG, CALL BIBLD USING 0 (?) FOR SIZE VALUE 
C 
      IF(ITRSF.EQ.2H>D.AND.ITRSF(2).EQ.2HCL 
     .   .AND.ITRSF(3).EQ.2HOG) 
     .CALL BIDLD(LUPRT,ITRSF,ISSGA,ISIZ2,IOPT,IRLO2,L)
C 
      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),92080-1X402 REV.2026  790514
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            NO BITS-NEITHER SSGA NOR SYSTEM COMMON 
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 
      IBUF(22)=2H 
      IBUF(24)=2H 
      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),92080-1X402 REV.2026  790312
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$
              