FTN4 PROGRAM TMPG1(5),92080-16453 REV.2026 800314 C C C NAME: TMPG1 C SOURCE: &TMG1A 92080-18453 C BINARY: %TMG1A 92080-16453 C C PGMR: DANIEL POT/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 * THIS PROGRAM ALLOWS USER EITHER TO * C * LIST ALL FILES OF AN APPLICATION * C * OR TO LOAD ALL PROGRAMS ASSOCIATED * C * TO THIS APPLICATION. * C * * C * IF P1 = 0 FUNCTION LIST * C * IF P1 = 1 FUNCTION LOAD * C ****************************************** C C C STOP USED: 1000 C ---------- C C NOTE: WORKS ON PACKED FORM OF NCRTH C ------ C C CCB1 C********************************************************************* C C-----LABELED COMMON # 1 GENERAL INFORMATION C COMMON /TMGC1/LU,LUPRT,LUOUT,ISYTP,IPARAM(5) C C LU - USER TERMIAL LU C LUPRT - LISTING LU C LUOUT - NOT USED C ISYTP - SYSTEM TYPE (MUST BE .EQ. -9, RTE-IV) C IPARAM - TMSGN OPERATING PARAMETERS: C ISCRN - CURRENT SCREEN NO. EQUIVALENCE (ISCRN,IPARAM(1)) C IOFST - OFFSET INTO BUFFER NCRTH EQUIVALENCE (IOFST,IPARAM(2)) C IEND - INTERACTIVE OPERATION INDICATOR C 0 - CURRENT PROCESS C 1 - END OF PROCESS C 2 - ABORT TMSGN C 3 - PREVIOUS SCREEN EQUIVALENCE (IEND,IPARAM(3)) C IJOB - TMS FUNCTION INDICATOR C 0 - DEFINE (INT. AND AUX. LU'S, AND T.U.S.) C 1 - SCREEN HAS BEEN PRINTED, PERFORM ANALYSIS C 3 - DEFINE T.U.S. INTO USER PARTITION EQUIVALENCE (IJOB,IPARAM(4)) C C********************************************************************* CCB1 C C CCB3 C********************************************************************* C C-----LABELED COMMON # 3 BUFFER AREA C COMMON /TMGC3/IREFC,ILUGH,INTMS,ILPRG,IDECL,ILGMX,NBPRO . ,NCRTH(2540) C C IREFC - C ILUGH - C INTMS - C ILPRG - C IDECL - C ILGMX - C NBPRO - C NCRTH - OUTPUT FILE BUFFER: C NCNOWD - NO. OF WORDS IN FILE EQUIVALENCE (NCNOWD,NCRTH(1)) C NCINLU - BUFFER ADDR OF INTERACTIVE LU TABLE EQUIVALENCE (NCINLU,NCRTH(2)) C NCAXLU - BUFFER ADDR OF AUX LU TABLE EQUIVALENCE (NCAXLU,NCRTH(3)) C NCPAR1 - BUFFER ADDR OF FIRST PARTITION EQUIVALENCE (NCPAR1,NCRTH(4)) C NCNAME - APPLICATION NAME (2 WDS) DIMENSION NCNAME(2) EQUIVALENCE (NCNAME,NCRTH(5)) C NCSCOD - SECURITY CODE EQUIVALENCE (NCSCOD,NCRTH(7)) C NCCRNO - CARTRIDGE NO. EQUIVALENCE (NCCRNO,NCRTH(8)) C NCEMAS - EMA SIZE IN KWDS EQUIVALENCE (NCEMAS,NCRTH(9)) C NCMSEG - MSEG SIZE IN KWDS EQUIVALENCE (NCMSEG,NCRTH(10)) C NCPARS - PARTITION SIZE IN KWDS EQUIVALENCE (NCPARS,NCRTH(11)) C NCPARN - PARTITION NO. EQUIVALENCE (NCPARN,NCRTH(12)) C NCLOGD - LOGGING DEVICE LU OR FILENAME (5 WDS) DIMENSION NCLOGD(5) EQUIVALENCE (NCLOGD(1),NCRTH(13)) C NCTUSP - TUS NAME OF STARTING PROCESS (3 WDS) DIMENSION NCTUSP(3) EQUIVALENCE (NCTUSP(1),NCRTH(18)) C NCSTCK - STACK LENGTH EQUIVALENCE (NCSTCK,NCRTH(21)) C NCINIP - TUS NAME OF INITIAL PROCESS (3 WDS) DIMENSION NCINIP(3) EQUIVALENCE (NCINIP(1),NCRTH(22)) C NCLUIN - LU FOR INITIAL PROCESS EQUIVALENCE (NCLUIN,NCRTH(25)) C NCDBNO - NO. OF DATA BASES EQUIVALENCE (NCDBNO,NCRTH(26)) C C NOTE: THE FOLLOWING VARIABLES ARE EQUIVALENCED TO "NCRTH" FOR USE C BY TMSG5. C C IEXFL - EQUIVALENCE (IEXFL,NCRTH(2101)) C IPTR - EQUIVALENCE (IPTR,NCRTH(2102)) C NBSCR - EQUIVALENCE (NBSCR,NCRTH(2103)) C IFSCR - EQUIVALENCE (IFSCR,NCRTH(2104)) C ILAST - EQUIVALENCE (ILAST,NCRTH(2105)) C IFLG - DIMENSION IFLG(29) EQUIVALENCE (IFLG(1),NCRTH(2106)) C IPRVS - DIMENSION IPRVS(29) EQUIVALENCE (IPRVS(1),NCRTH(2135)) C IBUFR - DATA BUFFER USED BY SUBROUTINE "TMPRS" DIMENSION IBUFR(62) EQUIVALENCE (IBUFR(1),NCRTH(2164)) C ITEMP - DIMENSION ITEMP(3) EQUIVALENCE (ITEMP(1),NCRTH(2226)) C ITOSC - EQUIVALENCE (ITOSC,NCRTH(2229)) C C********************************************************************* CCB3 C C C DIMENSION IBUF(350),NUMB(40),ILIS(20),IHEAD(40),MTMPR(28) DIMENSION JTEMP(3),KTEMP(3) C LOGICAL PRINT C EQUIVALENCE (NCRT5,NCRTH(5)) C DATA ILIS/15530B,15555B,15446B,2Hk0,2HB ,15542B,15510B,15512B .,2H ,15446B,2HdC,2HLI,2HST,2HIN,2HG ,15446B,2Hd@,6412B .,5012B,15554B/ DATA IHEAD/2H P,2HAG,2HE ,2H00,2H01,2H ,2H D,2HAT,2HAC . ,2HAP,2H/1,2H00,2H0 ,2H- ,2HHP,2H92,2H08,2H0A . ,2H R,2HEV,2H 2,2H02,2H6 ,17*2H / DATA ICH/83/,LINPAG/60/,IUPT0/3/ C IF(ISCRN.EQ.1) GOTO 2000 IF(ISCRN.NE.0) STOP 1000 C C ********************* C * LISTING OPERATION * C ********************* C C CALL EXEC(2,LU,ILIS,20) C C-----IF LIST DEVICE IS NOT CRT, LOCK IT C CALL LCKLL(LU,LUPRT,500) CALL FTIME(IHEAD(25)) IPAGE=0 ASSIGN 320 TO IRTN GOTO 900 320 K=NCRTH(11)+NCRTH(9) I=2HP IF(NCRTH(6) .NE. 2HP1) I=2HPD CALL JASC(NCRTH(8),JTEMP,1,6) CALL TCVTA(JTEMP,6) WRITE(LUPRT,100)I,JTEMP,K,(NCRTH(I),I=9,10) WRITE(LUPRT,240) IF(NCRTH(13) .EQ. 0) GOTO 350 IF(NCRTH(13) .LT. 256) GOTO 340 WRITE(LUPRT,132)(NCRTH(I),I=13,17) GOTO 360 340 WRITE(LUPRT,130)NCRTH(13) GOTO 360 350 WRITE(LUPRT,135) 360 LINB=LINB+7 IF(NCRTH(26) .EQ. 0) GOTO 380 J=27 DO 372 I=1,NCRTH(26) CALL JASC(NCRTH(J+6),JTEMP,1,6) CALL TCVTA(JTEMP,6) CALL JASC(NCRTH(J+7),KTEMP,1,6) CALL TCVTA(KTEMP,6) WRITE(LUPRT,140)I,(NCRTH(K),K=J,J+5),JTEMP,KTEMP LINB=LINB+2 372 J=J+15 GOTO 390 380 WRITE(LUPRT,270) LINB=LINB+2 390 WRITE(LUPRT,240) LINB=LINB+1 J=(NCRTH(3)-NCRTH(2))/2 WRITE(LUPRT,160) J LINB=LINB+2 J=J/7 K=NCRTH(2) IF(J.EQ.0) GOTO 401 C C PRINT 3070 LU'S C 408 DO 400 I=1,J WRITE(LUPRT,170)(NCRTH(L),L=K,K+12,2) DO 4000 LTMP=1,28 4000 MTMPR(LTMP)=020040B DO 4001 LTMP=K+1,K+13,2 IF(NCRTH(LTMP).EQ.10000)GO TO 4002 CALL JASC(NCRTH(LTMP),SHOLD,1,4) GO TO 4003 4002 SHOLD=4H NA 4003 CALL MOVEW(SHOLD,MTMPR(LTMP-K),2) 4001 CONTINUE WRITE(LUPRT,180)(MTMPR(L),L=1,28) LINB=LINB+2 K=K+14 400 CONTINUE IF(K.EQ.NCRTH(3)) GOTO 402 401 WRITE(LUPRT,170)(NCRTH(L),L=K,(NCRTH(3)-2),2) DO 4050 LTMP=1,28 4050 MTMPR(LTMP)=020040B DO 4051 LTMP=K+1,(NCRTH(3)-2)+1,2 IF(NCRTH(LTMP).EQ.10000)GO TO 4052 CALL JASC(NCRTH(LTMP),SHOLD,1,4) GO TO 4053 4052 SHOLD=4H NA 4053 CALL MOVEW(SHOLD,MTMPR(LTMP-K),2) 4051 CONTINUE WRITE(LUPRT,180)(MTMPR(L),L=1,28) LINB=LINB+2 402 J=(NCRTH(4)-NCRTH(3))/2 WRITE(LUPRT,240) LINB=LINB+1 C C USER'S MODULES PROGRAMS C CALL BLANC(IBUF,350) CALL PUTCA(IBUF,1H&,3) CALL MOVCA(NCRTH,9,IBUF,4,4) CALL PUTCA(IBUF,1H%,13) CALL MOVCA(NCRTH,9,IBUF,14,4) CALL PUTCA(IBUF,1H>,23) CALL MOVCA(NCRTH,9,IBUF,24,4) IBUF(17)=2H%T CALL MOVEW(NCRT5,IBUF(18),2) IBUF(22)=2H>T CALL MOVEW(NCRT5,IBUF(23),2) CALL MOVEW(IBUF(17),IBUF(27),10) CALL PUTCA(IBUF,1HL,54) CALL PUTCA(IBUF,1HL,64) ICH=73 C-----SET UP IMAGE MODULE IF ANY IF(NCRTH(26) .EQ. 0) GOTO 630 J=53 DO 620 I=1,NCRTH(26) CALL PUTCA(IBUF,1H%,ICH) CALL PUTCA(IBUF,1H>,ICH+10) CALL MOVCA(NCRTH,J,IBUF,ICH+1,5) CALL MOVCA(NCRTH,J,IBUF,ICH+11,5) ICH=ICH+20 620 J=J+30 630 IUPT=0 ITUS=0 J=NCRTH(4) C C-----LOOP ON EACH USER PARTITION C 640 I=NCRTH(J) K=J PRINT = IUPT .GE. IUPT0 J=((I-J-3)/18)+1 IF( I-K-3 .EQ. 18*(J-1) ) J=J-1 IF( .NOT. PRINT ) GOTO 650 645 LINB=LINB+J+4 ASSIGN 645 TO IRTN IF( LINB .GE. LINPAG ) GOTO 900 WRITE(LUPRT,240) C-----WRITE PROGRAM NUMBER, SWAP OPTION ... M=IUPT-IUPT0+1 WRITE(LUPRT,200) M C-----WRITE LOADER OPTION WRITE(LUPRT,240) 650 CALL PUTCA(IBUF,1H%,20*IUPT+ICH) CALL PUTCA(IBUF,1H>,20*IUPT+ICH+10) CALL MOVCA(NCRTH,9,IBUF,20*IUPT+ICH+1,4) CALL MOVCA(NCRTH,9,IBUF,20*IUPT+ICH+11,4) CALL PUTCA(IBUF,1HA+IUPT*256,20*IUPT+ICH+5) CALL PUTCA(IBUF,1HA+IUPT*256,20*IUPT+ICH+15) CALL ISUPB(IBUF((20*IUPT+ICH+1)/2),3) CALL ISUPB(IBUF((20*IUPT+ICH+11)/2),3) K=K+3 LINE=0 690 L=K CALL BLAN(NUMB,1,79) M=(2*(L-(K-3))/3) 695 CALL MOVEW(6H LB: ,NUMB(M),3) IF(IAND(NCRTH(L),100000B).NE.0) GOTO 698 ITUS=ITUS+1 NUMB(M+2)=2H - CALL JASC(ITUS,NUMB(M+1),-1,3) 698 NUMB(M+3)=IAND(NCRTH(L),77777B) CALL MOVEW(NCRTH(L+1),NUMB(M+4),2) L=L+3 M=M+6 IF(L.EQ.I) GOTO 699 IF(L.NE.K+18) GOTO 695 699 IF( PRINT ) CALL EXEC(2,LUPRT,NUMB,38) K=K+18 LINE=LINE+1 IF(LINE.NE.J) GOTO 690 J=I IUPT=IUPT+1 IF(J .NE. NCRTH+1) GOTO 640 C C-----PRINT " NO USER MODULES " IF # OF PART. = 2 C IF( IUPT .NE. IUPT0 ) GOTO 710 WRITE(LUPRT,250) LINB=LINB+2 C C-----PREPARE DCLOG MODULES FOR PRINTING C 710 IF(NCRTH(13).EQ.0) GO TO 720 CALL MOVCA(6H%DCLOG,1,IBUF,20*IUPT+ICH,6) CALL MOVCA(6H>DCLOG,1,IBUF,20*IUPT+ICH+10,6) IUPT=IUPT+1 C C-----WRITE DIRECTORY (ALL FILES CREATED BY TMPGN) C 720 ASSIGN 720 TO IRTN K=1+(20*(IUPT+1)+ICH)/80 LINB=LINB+5+K IF( LINB .GE. LINPAG ) GOTO 900 WRITE(LUPRT,230) J=1 DO 80 I=1,K CALL EXEC(2,LUPRT,IBUF(J),39) 80 J=J+40 C CALL EXEC(3,1100B+LUPRT,-1) C C-----IF LIST DEVICE IS NOT CRT, UNLOCK THE LIST DEVICE C IF(LU .NE. LUPRT) CALL LURQ(0,LUPRT,1) GO TO 3100 C C-----PRINT THE PAGE HEADER C 900 IPAGE=IPAGE+1 CALL JASC(IPAGE,IHEAD,-7,4) CALL EXEC(3,1100B+LUPRT,-1) WRITE(LUPRT,110)IHEAD LINB=4 GOTO IRTN C C FORMATS USED BY LISTG C 110 FORMAT(40A2,2/, .,5X"T R A N S A C T I O N M O N I T O R G E N E R A T O R" ." L I S T" ,/) 100 FORMAT(/,3X,"TM"A2" IS GENERATED ON CARTRIDGE #"3A2, .2/,3X,"REQUIRES A MOTHER PARTITION OF"I4" K WORDS (EMA=" .I4,", MSEG="I3,")") 120 FORMAT(/,3X,"NO USER'S MODULES") 130 FORMAT(/,3X,"LOGGING ON MAGNETIC TAPE LU :"I3) 132 FORMAT(/,3X,"LOGGING ON DISC FILE: "3A2," SC ="I6, ." ON CARTRIDGE #"I7) 135 FORMAT(/,3X,"NO LOGGING") 140 FORMAT(/,3X,"DATA BASE #"I2", NAME: "3A2", LEVEL WORD: "3A2, .", SEC-COD: "3A2,", CR# ",3A2) 160 FORMAT(/,3X,"NUMBER OF DATA CAPTURE TERMINALS: "I2) 170 FORMAT(/,3X,"LU : "I2,6(7X,I2)) 180 FORMAT(3X, "TS#: "2A2,6(5X,2A2)) 200 FORMAT(/,3X,"USER MODULES PROGRAM UNIT #: "I2,2X) 220 FORMAT(3X,6(5A2,2X)) 230 FORMAT(3/,3X"FILES CREATED BY TMPGN:",/) 240 FORMAT(5X) 250 FORMAT(/,3X,"NO USER MODULES.") 270 FORMAT(/,3X,"NO DATA BASE") C C C C========================================================================== C C ******************** C * LOAD OPERATION * C ******************** C C 2000 CALL TMGLD(IEND) C-----IF LOAD OPERATION HAS FAILED, REPORT ERROR TO OPERATOR IF(IEND .LT. 0) GOTO 3120 C C LISTING OR LOADING PHASE IS FINISH, C WRITE MESSAGE ON CRT IF NEEDED & EXIT C 3100 IF(LU .NE. LUPRT) GOTO 3300 IEND=3 3120 CALL TMGSC(0,0,0,IEND,IJOB) C C-----ACKNOWLEDGMENT NOT NEEDED, TERMINATE TMPGN C 3300 CALL TMGSC(0,0,0,2) C C DUMMY CALL TO MAIN !! C CALL TMPGN END END$