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$